webcrank-wai (empty) → 0.1

raw patch · 12 files changed

+393/−0 lines, 12 filesdep +basedep +bytestringdep +exceptionssetup-changed

Dependencies added: base, bytestring, exceptions, lens, mtl, unix-compat, unordered-containers, wai, wai-lens, webcrank, webcrank-dispatch

Files

• .gitignore +2/−0
• .travis.yml +46/−0
• HLint.hs +5/−0
• LICENSE +25/−0
• README.md +4/−0
• Setup.hs +5/−0
• examples/LICENSE +25/−0
• examples/Main.hs +63/−0
• examples/Setup.hs +5/−0
• examples/webcrank-wai-examples.cabal +28/−0
• src/Webcrank/Wai.hs +133/−0
• webcrank-wai.cabal +52/−0

@@ -0,0 +1,2 @@+dist+examples/dist

@@ -0,0 +1,46 @@+# From https://github.com/hvr/multi-ghc-travis++# NB: don't set `language: haskell` here++# The following enables several GHC versions to be tested; often it's enough to test only against the last release in a major GHC version. Feel free to omit lines listings versions you don't need/want testing for.+env:+ - CABALVER=1.18 GHCVER=7.6.3+ - CABALVER=1.18 GHCVER=7.8.3+ - CABALVER=1.22 GHCVER=7.10.1+ - CABALVER=head GHCVER=head   # see section about GHC HEAD snapshots++matrix:+  allow_failures:+   - env: CABALVER=head GHCVER=head++# Note: the distinction between `before_install` and `install` is not important.+before_install:+ - travis_retry sudo add-apt-repository -y ppa:hvr/ghc+ - travis_retry sudo apt-get update+ - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER # see note about happy/alex+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH++install:+ - cabal --version+ - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"+ - travis_retry cabal update+ - cabal install --only-dependencies --enable-tests --enable-benchmarks++# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail.+script:+ - if [ -f configure.ac ]; then autoreconf -i; fi+ - cabal configure --enable-tests --enable-benchmarks -v2  # -v2 provides useful information for debugging+ - cabal build   # this builds all libraries and executables (including tests/benchmarks)+ - cabal test+ - cabal check+ - cabal sdist   # tests that a source-distribution can be generated++# The following scriptlet checks that the resulting source distribution can be built & installed+ - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;+   cd dist/;+   if [ -f "$SRC_TGZ" ]; then+      cabal install --force-reinstalls "$SRC_TGZ";+   else+      echo "expected '$SRC_TGZ' not found";+      exit 1;+   fi

@@ -0,0 +1,5 @@+import "hint" HLint.Default+import "hint" HLint.Generalise++ignore "Use import/export shortcut"+

@@ -0,0 +1,25 @@+Copyright (c) 2012, Webcrank, Mark Hibberd and others.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. The name of the author may not be used to endorse or promote products+   derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.+IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,4 @@+# Webcrank on Wai [![TravisCI](https://travis-ci.org/webcrank/webcrank-wai.svg)](https://travis-ci.org/webcrank/webcrank-wai) [![Hackage](https://img.shields.io/hackage/v/webcrank-wai.svg?style=flat)](https://hackage.haskell.org/package/webcrank-wai)++A library for building [Webcrank](https://github.com/webcrank/webcrank.hs) [WAI](https://hackage.haskell.org/package/wai) `Application`s.+

@@ -0,0 +1,5 @@+#!/usr/bin/env runhaskell++import Distribution.Simple++main = defaultMain

@@ -0,0 +1,25 @@+Copyright (c) 2012, Webcrank, Mark Hibberd and others.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. The name of the author may not be used to endorse or promote products+   derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.+IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,63 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Applicative+import Control.Monad.State+import Control.Monad.Catch+import Data.Monoid+import Data.Text (Text)+import qualified Network.Wai.Handler.Warp as Warp++import Webcrank.Wai++data MyData = MyData String++newtype MyApp a = MyApp { unMyApp :: StateT MyData Wai a }+  deriving+    ( Functor+    , Applicative+    , Monad+    , MonadIO+    , MonadThrow+    , MonadCatch+    , MonadWai+    )++runMyApp :: MyApp a -> MyData -> Wai a+runMyApp = evalStateT . unMyApp++runMyAppF :: MyData -> MyApp a -> Wai a+runMyAppF = flip runMyApp++index :: Path '[]+index = ""++indexResource :: MonadIO m => Resource m+indexResource = resourceWithHtml $ return $ textBody $ mconcat+  [ "<h1>Welcome to Webcrank!</h1>"+  , "<a href=\""+  , renderRoute echoPath $ "Hello" .*. HNil+  , "\">Allow me to greet you properly</a>"+  ]++echoPath :: Path '[Text]+echoPath = "echo" </> var++echoResource :: Monad m => Text -> Resource m+echoResource t = resourceWithHtml $ return $ textBody $  mconcat ["<h1>", t, "</h1>"]++myApp+  :: Request+  -> (Response -> IO ResponseReceived)+  -> IO ResponseReceived+myApp = dispatch (runMyAppF (MyData "a")) $ mconcat+  [ index ==> indexResource+  , echoPath ==> echoResource+  ]++main :: IO ()+main = Warp.run 3000 myApp+

@@ -0,0 +1,5 @@+#!/usr/bin/env runhaskell++import Distribution.Simple++main = defaultMain

@@ -0,0 +1,28 @@+name:               webcrank-wai-examples+version:            0.0.1+license:            BSD3+license-file:       LICENCE+author:             Richard Wallace <rwallace@thewallacepack.net>+maintainer:         Richard Wallace <rwallace@thewallacepack.net>+copyright:          (c) 2015 Richard Wallace+synopsis:           Example WAI Application built with Webcrank+category:           Web+homepage:           https://github.com/webcrank/webcrank-wai+bug-reports:        https://github.com/webcrank/webcrank-wai/issues+cabal-version:      >= 1.8+build-type:         Simple++flag                small_base+  description:      Choose the new, split-up base package.++executable examples+  main-is:          Main.hs+  build-depends:    base                            >= 4.6 && < 5+                  , bytestring+                  , exceptions+                  , mtl+                  , text+                  , warp+                  , webcrank-wai++  ghc-options:      -Wall

@@ -0,0 +1,133 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RankNTypes #-}++module Webcrank.Wai+  ( WaiResource+  , WaiCrankT+  , dispatch+  , HasRequest(..)+  , HasRequestDate(..)+  , WaiData+  , ReqData+  , module Webcrank+  , module Webcrank.Dispatch+  ) where++import Control.Applicative+import Control.Lens+import Control.Monad.Catch+import Control.Monad.RWS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.HashMap.Strict as HashMap+import Data.Maybe+import Data.Traversable+import Network.Wai hiding (pathInfo, requestHeaders)+import Network.Wai.Lens+import System.PosixCompat.Time++import Webcrank+import Webcrank.Dispatch hiding (dispatch)+import qualified Webcrank.Dispatch as W+import Webcrank.ServerAPI hiding (handleRequest)+import qualified Webcrank.ServerAPI as API++-- | Holds the request and resource state during request processing.+data WaiData m = WaiData+  { _resourceData :: ResourceData m+  , _waiDataRequest :: Request+  , _waiDataRequestDate :: HTTPDate+  }++makeFields ''WaiData++instance HasResourceData (WaiData m) m where+  resourceData f ~(WaiData rd rq d) = fmap (\rd' -> WaiData rd' rq d) (f rd)++-- | Monad transformer that all resource functions will run in. Provides+-- the ability to read the WAI @'Request'@ inside resource functions.+newtype WaiCrankT m a =+  WaiCrankT { unWaiCrankT :: RWST (WaiData (WaiCrankT m)) LogData ReqData m a }+  deriving+    ( Functor+    , Applicative+    , Monad+    , MonadIO+    , MonadReader (WaiData (WaiCrankT m))+    , MonadState ReqData+    , MonadWriter LogData+    , MonadThrow+    , MonadCatch+    , MonadMask+    )++instance MonadTrans WaiCrankT where+  lift = WaiCrankT . lift++type WaiResource m = Resource (WaiCrankT m)++type WaiServerAPI m = ServerAPI (WaiCrankT m)++-- | Function for turning @'Dispatcher'@s into @'Application'@s.+-- A @run@ function must be provided for executing the application+-- logic.  In the simplest case, where @m@ is @IO@, this can just be+-- @'id'@.+dispatch+  :: (Applicative m, MonadIO m, MonadCatch m)+  => (forall a. m a -> IO a) -- ^ run+  -> Dispatcher (WaiResource m)+  -> Application+dispatch f d rq = f . dispatch' d rq++dispatch'+  :: (Applicative m, MonadIO m, MonadCatch m)+  => Dispatcher (WaiResource m)+  -> Request+  -> (Response -> IO ResponseReceived)+  -> m ResponseReceived+dispatch' d rq respond = maybe (sendNotFound respond) run disp where+  run r = handleRequest r rq respond+  disp = W.dispatch d (rq ^. pathInfo)++sendNotFound+  :: MonadIO m+  => (Response -> IO ResponseReceived)+  -> m ResponseReceived+sendNotFound respond = liftIO $ respond $ responseLBS notFound404 [] "404 Not Found"++runWaiCrankT+  :: (Applicative m, MonadCatch m, MonadIO m)+  => WaiCrankT m a+  -> WaiData (WaiCrankT m)+  -> m (a, ReqData, LogData)+runWaiCrankT w d = do+  runRWST (unWaiCrankT w) d newReqData++handleRequest+  :: (Applicative m, MonadCatch m, MonadIO m)+  => WaiResource m+  -> Request+  -> (Response -> IO ResponseReceived)+  -> m ResponseReceived+handleRequest r rq respond = do+  now <- liftIO epochTime+  let rd = WaiData (newResourceData api r) rq (epochTimeToHTTPDate now)+  res <- API.handleRequest (flip runWaiCrankT rd)+  liftIO $ respond $ waiRes res++waiRes :: (Status, HeadersMap, Maybe Body) -> Response+waiRes (s, hs, b) = responseLBS s (hdrs hs) (fromMaybe LBS.empty b) where+  hdrs = join . fmap sequenceA . HashMap.toList++api :: (Applicative m, Monad m) => WaiServerAPI m+api = ServerAPI+  { srvGetRequestMethod = requestMethod <$> view request+  , srvGetRequestHeader = \h ->+      preview (request . headers . value h)+  , srvGetRequestURI = undefined+  , srvGetRequestTime = view requestDate+  }

@@ -0,0 +1,52 @@+name:               webcrank-wai+version:            0.1+license:            BSD3+license-file:       LICENSE+author:             Richard Wallace <rwallace@thewallacepack.net>+maintainer:         Richard Wallace <rwallace@thewallacepack.net>+copyright:          (c) 2015 Richard Wallace+synopsis:           Build a WAI Application from Webcrank Resources+category:           Web+homepage:           https://github.com/webcrank/webcrank-wai+bug-reports:        https://github.com/webcrank/webcrank-wai/issues+cabal-version:      >= 1.8+build-type:         Simple+description:+  Build a WAI Application from Webcrank Resources.++extra-source-files:+  .gitignore+  .travis.yml+  examples/LICENSE+  examples/webcrank-wai-examples.cabal+  examples/*.hs+  HLint.hs+  LICENSE+  README.md++source-repository   head+  type:             git+  location:         https://github.com/webcrank/webcrank-wai.git++flag                small_base+  description:      Choose the new, split-up base package.++library+  hs-source-dirs:   src++  exposed-modules:  Webcrank.Wai++  ghc-options:      -Wall++  build-depends:    base                            >= 4.6 && < 5+                  , bytestring+                  , exceptions+                  , lens+                  , mtl+                  , unix-compat+                  , unordered-containers+                  , wai+                  , wai-lens+                  , webcrank+                  , webcrank-dispatch+