airship 0.3.0.0 → 0.4.0.0

raw patch · 13 files changed

+299/−470 lines, 13 filesdep +microlensdep +mmorphdep +wai-extradep −warpdep ~basedep ~eitherdep ~http-typesPVP ok

version bump matches the API change (PVP)

Dependencies added: microlens, mmorph, wai-extra

Dependencies removed: warp

Dependency ranges changed: base, either, http-types, tasty, tasty-quickcheck, wai

API changes (from Hackage documentation)

Files

• airship.cabal +12/−23
• bin/Main.hs +0/−135
• src/Airship.hs +6/−1
• src/Airship/Config.hs +41/−0
• src/Airship/Headers.hs +4/−4
• src/Airship/Helpers.hs +5/−2
• src/Airship/Internal/Decision.hs +76/−94
• src/Airship/Internal/Helpers.hs +51/−34
• src/Airship/Internal/Route.hs +6/−6
• src/Airship/Resource.hs +33/−33
• src/Airship/Resource/Static.hs +5/−5
• src/Airship/Types.hs +51/−111
• test/unit/test.hs +9/−22

@@ -1,7 +1,9 @@ name:                   airship synopsis:               A Webmachine-inspired HTTP library description:            A Webmachine-inspired HTTP library-version:                0.3.0.0+homepage:               https://github.com/helium/airship/+Bug-reports:            https://github.com/helium/airship/issues+version:                0.4.0.0 license:                MIT license-file:           LICENSE author:                 Reid Draper and Patrick Thomson@@ -19,6 +21,7 @@   hs-source-dirs: src   ghc-options:  -Wall   exposed-modules:   Airship+                   , Airship.Config                    , Airship.Headers                    , Airship.Helpers                    , Airship.Types@@ -41,14 +44,16 @@                       , case-insensitive                       , cryptohash == 0.11.6.*                       , directory-                      , either == 4.3.*+                      , either >= 4.3 && < 4.6                       , filepath >= 1.3 && < 1.5                       , http-date                       , http-media-                      , http-types >= 0.7+                      , http-types == 0.9.*                       , lifted-base == 0.2.*-                      , mime-types == 0.1.0.*+                      , microlens                       , monad-control >= 1.0+                      , mime-types == 0.1.0.*+                      , mmorph == 1.0.*                       , mtl                       , network                       , old-locale@@ -60,23 +65,7 @@                       , unix == 2.7.*                       , unordered-containers                       , wai == 3.0.*--executable airship-example-  main-is:              Main.hs-  hs-source-dirs: bin-  ghc-options:  -Wall-  default-language:    Haskell2010-  build-depends:        base >=4.7 && < 5-                      , airship-                      , blaze-builder >=0.3 && < 0.5-                      , bytestring-                      , http-types >= 0.7-                      , mtl-                      , text-                      , time-                      , unordered-containers-                      , wai == 3.0.2.*-                      , warp == 3.0.*+                      , wai-extra == 3.0.*  test-suite unit   default-language: Haskell2010@@ -87,8 +76,8 @@                , airship                , text             == 1.2.*                , bytestring       >= 0.9.1   && < 0.11-               , tasty            == 0.10.*-               , tasty-quickcheck == 0.8.3.*+               , tasty            >= 0.10.1  && < 0.12+               , tasty-quickcheck >= 0.8.3   && < 0.8.5                , tasty-hunit        >= 0.9.1 && < 0.10                , transformers                , wai == 3.0.*

@@ -1,135 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}--module Main where--import           Airship-import           Airship.Resource.Static (StaticOptions(..), staticResource)--import           Blaze.ByteString.Builder.Html.Utf8 (fromHtmlEscapedText)--#if __GLASGOW_HASKELL__ < 710-import           Control.Applicative ((<$>))-#endif-import           Control.Concurrent.MVar-import           Control.Monad.Trans (liftIO)--import           Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HM-import qualified Data.ByteString.Lazy as LB-import           Data.ByteString.Lazy.Char8 (unpack)-import           Data.Maybe (fromMaybe)-import           Data.Monoid ((<>))-import           Data.Text(Text, pack)-import           Data.Time.Clock--import qualified Network.HTTP.Types as HTTP-import           Network.Wai.Handler.Warp ( runSettings-                                          , defaultSettings-                                          , setPort-                                          , setHost-                                          )---- ***************************************************************************--- Helpers--- ***************************************************************************--getBody :: Handler s IO LB.ByteString-getBody = do-    req <- request-    liftIO (entireRequestBody req)--readBody :: Handler s IO Integer-readBody = read . unpack <$> getBody--routingParam :: Text -> Handler s m Text-routingParam t = do-    p <- params-    return (p HM.! t)--newtype State = State { _getState :: MVar (HashMap Text Integer) }--resourceWithBody :: Text -> Resource State IO-resourceWithBody t = defaultResource { contentTypesProvided = return [("text/plain", return (escapedResponse t))]-                                     , lastModified = Just <$> liftIO getCurrentTime-                                     , generateETag = return $ Just $ Strong "abc123"-                                     }--accountResource :: Resource State IO-accountResource = defaultResource-    { allowedMethods = return [ HTTP.methodGet-                              , HTTP.methodHead-                              , HTTP.methodPost-                              , HTTP.methodPut-                              ]-    , knownContentType = contentTypeMatches ["text/plain"]--    , contentTypesProvided = do-        let textAction = do-                s <- getState-                m <- liftIO (readMVar (_getState s))-                accountNameM <- HM.lookup "name" <$> params-                let val = fromMaybe 0 (accountNameM >>= flip HM.lookup m)-                return $ ResponseBuilder (fromHtmlEscapedText-                                                (pack (show val) <> "\n"))-        return [("text/plain", textAction)]--    , allowMissingPost = return False--    , lastModified = Just <$> liftIO getCurrentTime--    , resourceExists = do-        accountName <- routingParam "name"-        s <- getState-        m <- liftIO (readMVar (_getState s))-        return $ HM.member accountName m--    -- POST'ing to this resource adds the integer to the current value-    , processPost = return (PostProcess $ do-        (val, accountName, s) <- postPutStates-        liftIO (modifyMVar_ (_getState s) (return . HM.insertWith (+) accountName val))-        return ()-        )--    , contentTypesAccepted = return [("text/plain", do-        (val, accountName, s) <- postPutStates-        liftIO (modifyMVar_ (_getState s) (return . HM.insert accountName val))-        return ()-    )]-    }--postPutStates :: Handler State IO (Integer, Text, State)-postPutStates = do-    val <- readBody-    accountName <- routingParam "name"-    s <- getState-    return (val, accountName, s)--myRoutes :: Resource State IO -> RoutingSpec State IO ()-myRoutes static = do-    root                        #> resourceWithBody "Just the root resource"-    "account" </> var "name"    #> accountResource-    "static"  </> star          #> static--main :: IO ()-main = do-    static <- staticResource Cache "assets"-    let port = 3000-        host = "127.0.0.1"-        settings = setPort port (setHost host defaultSettings)-        routes = myRoutes static-        response404 = escapedResponse "<html><head></head><body><h1>404 Not Found</h1></body></html>"-        resource404 = defaultResource { resourceExists = return False-                                      , contentTypesProvided = return-                                            [ ( "text/html"-                                              , return response404-                                              )-                                            ]-                                      }--    mvar <- newMVar HM.empty-    let s = State mvar-    putStrLn "Listening on port 3000"-    runSettings settings (resourceToWai routes resource404 s)

@@ -1,11 +1,16 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes        #-}+ module Airship-  ( module Airship.Resource+  ( module Airship.Config+  , module Airship.Resource   , module Airship.Headers   , module Airship.Helpers   , module Airship.Route   , module Airship.Types   ) where +import           Airship.Config import           Airship.Headers import           Airship.Helpers import           Airship.Resource

@@ -0,0 +1,41 @@+module Airship.Config+    ( AirshipConfig+    , HeaderInclusion (..)+    , includeTraceHeader+    , includeQuipHeader+    , defaultAirshipConfig+    ) where++import           Lens.Micro (Lens', lens)++-- | An opaque data type encapsulating all Airship-specific configuration options.+--+-- We use lenses to modify 'AirshipConfig' values -- though Airship only depends on the+-- microlens library, its lenses are compatible with Control.Lens.+data AirshipConfig = AirshipConfig+    { _includeTraceHeader :: HeaderInclusion+    , _includeQuipHeader :: HeaderInclusion+    }++data HeaderInclusion = IncludeHeader | OmitHeader deriving (Eq, Show)++-- | Determines whether or not the @Airship-Trace@ header, which traces the execution of+-- a given request in the Airship decision tree, is included in every HTTP response.+-- While exposing the decision tree is usually innocuous (and makes for significantly easier+-- debugging), you may want to turn it off in certain circumstances.+--+-- Defaults to 'IncludeHeader' (enabled).+includeTraceHeader :: Lens' AirshipConfig HeaderInclusion+includeTraceHeader = lens _includeTraceHeader (\s n -> s { _includeTraceHeader = n })++-- | Determines whether or not the @Airship-Quip@ header, which includes a pithy+-- quote in your response headers, is included in every HTTP response.+--+-- Defaults to 'IncludeHeader' (enabled).+includeQuipHeader :: Lens' AirshipConfig HeaderInclusion+includeQuipHeader = lens _includeQuipHeader (\s n -> s { _includeQuipHeader = n })++-- | The default configuration. Use this, in conjunction with the lenses declared+-- above, to get and modify an 'AirshipConfig' to pass to 'resourceToWai'.+defaultAirshipConfig :: AirshipConfig+defaultAirshipConfig = AirshipConfig IncludeHeader IncludeHeader

@@ -5,15 +5,15 @@     , modifyResponseHeaders     ) where -import Airship.Types (Handler, ResponseState(..))+import Airship.Types (Webmachine, ResponseState(..)) import Control.Monad.State.Class (modify) import Network.HTTP.Types (ResponseHeaders, Header) --- | Applies the given function to the 'ResponseHeaders' present in this 'Handler''s 'ResponseState'.-modifyResponseHeaders :: (ResponseHeaders -> ResponseHeaders) -> Handler s m ()+-- | Applies the given function to the 'ResponseHeaders' present in this handlers 'ResponseState'.+modifyResponseHeaders :: Monad m => (ResponseHeaders -> ResponseHeaders) -> Webmachine m () modifyResponseHeaders f = modify updateHeaders     where updateHeaders rs@ResponseState{stateHeaders = h} = rs { stateHeaders = f h }  -- | Adds a given 'Header' to this handler's 'ResponseState'.-addResponseHeader :: Header -> Handler s m ()+addResponseHeader :: Monad m => Header -> Webmachine m () addResponseHeader h = modifyResponseHeaders (h :)

@@ -1,7 +1,10 @@ module Airship.Helpers-    ( contentTypeMatches-    , fromWaiRequest+    ( parseFormData+    , contentTypeMatches+    , redirectTemporarily+    , redirectPermanently     , resourceToWai+    , resourceToWaiT     ) where  import           Airship.Internal.Helpers

@@ -35,65 +35,49 @@                                                    get, modify) import           Control.Monad.Writer.Class (tell) -import           Data.ByteString (ByteString) import           Blaze.ByteString.Builder (toByteString)-import           Data.Maybe (fromJust, isJust)+import           Data.Maybe (isJust) import           Data.Text (Text) import           Data.Time.Clock (UTCTime)+import           Data.ByteString                  (ByteString, intercalate)  import           Network.HTTP.Media import qualified Network.HTTP.Types as HTTP----------------------------------------------------------------------------------- HTTP Headers--- These are headers not defined for us already in--- Network.HTTP.Types---------------------------------------------------------------------------------hAcceptCharset :: HTTP.HeaderName-hAcceptCharset = "Accept-Charset"--hAcceptEncoding :: HTTP.HeaderName-hAcceptEncoding = "Accept-Encoding"--hIfMatch :: HTTP.HeaderName-hIfMatch = "If-Match"--hIfUnmodifiedSince :: HTTP.HeaderName-hIfUnmodifiedSince = "If-Unmodified-Since"--hIfNoneMatch :: HTTP.HeaderName-hIfNoneMatch = "If-None-Match"--hIfModifiedSince :: HTTP.HeaderName-hIfModifiedSince = "If-Modified-Since"+import qualified Network.HTTP.Types.Header as HTTP  ------------------------------------------------------------------------------ -- FlowState: StateT used for recording information as we walk the decision -- tree ------------------------------------------------------------------------------ -data FlowState s m = FlowState-    { _contentType :: Maybe (MediaType, Webmachine s m (ResponseBody m)) }+data FlowState m = FlowState+    { _contentType :: Maybe (MediaType, Webmachine m ResponseBody) } -type FlowStateT s m a = StateT (FlowState s m) (Webmachine s m) a+type FlowStateT m a = StateT (FlowState m) (Webmachine m) a -type Flow s m = Resource s m -> FlowStateT s m (Response m)+type Flow m = Resource m -> FlowStateT m Response -initFlowState :: FlowState s m+initFlowState :: FlowState m initFlowState = FlowState Nothing -flow :: Monad m => Resource s m -> Webmachine s m (Response m)+flow :: Monad m => Resource m -> Webmachine m Response flow r = evalStateT (b13 r) initFlowState -trace :: Monad m => Text -> FlowStateT s m ()+trace :: Monad m => Text -> FlowStateT m () trace t = lift $ tell [t]  ------------------------------------------------------------------------------+-- Header value data newtypes+------------------------------------------------------------------------------++newtype IfMatch = IfMatch ByteString+newtype IfNoneMatch = IfNoneMatch ByteString++------------------------------------------------------------------------------ -- Decision Helpers ------------------------------------------------------------------------------ -negotiateContentTypesAccepted :: Monad m => Resource s m -> FlowStateT s m ()+negotiateContentTypesAccepted :: Monad m => Resource m -> FlowStateT m () negotiateContentTypesAccepted Resource{..} = do     req <- lift request     accepted <- lift contentTypesAccepted@@ -105,13 +89,13 @@         (Just process) -> lift process         Nothing -> lift $ halt HTTP.status415 -appendRequestPath :: Monad m => [Text] -> Webmachine s m ByteString+appendRequestPath :: Monad m => [Text] -> Webmachine m ByteString appendRequestPath ts = do     currentPath <- pathInfo <$> request     return $ toByteString (HTTP.encodePathSegments (currentPath ++ ts))  requestHeaderDate :: Monad m => HTTP.HeaderName ->-                                Webmachine s m (Maybe UTCTime)+                                Webmachine m (Maybe UTCTime) requestHeaderDate headerName = do     req <- request     let reqHeaders = requestHeaders req@@ -119,7 +103,7 @@         parsedDate = dateHeader >>= parseRfc1123Date     return parsedDate -writeCacheTags :: Monad m => Resource s m -> FlowStateT s m ()+writeCacheTags :: Monad m => Resource m -> FlowStateT m () writeCacheTags Resource{..} = lift $ do     etag <- generateETag     case etag of@@ -134,21 +118,24 @@ -- Type definitions for all decision nodes ------------------------------------------------------------------------------ -b13, b12, b11, b10, b09, b08, b07, b06, b05, b04, b03 :: Monad m => Flow s m-c04, c03 :: Monad m => Flow s m-d05, d04 :: Monad m => Flow s m-e06, e05 :: Monad m => Flow s m-f07, f06 :: Monad m => Flow s m-g11, g09, g08, g07 :: Monad m => Flow s m-h12, h11, h10, h07 :: Monad m => Flow s m-i13, i12, i07, i04 :: Monad m => Flow s m-j18 :: Monad m => Flow s m-k13, k07, k05 :: Monad m => Flow s m-l17, l15, l14, l13, l07, l05 :: Monad m => Flow s m-m20, m16, m07, m05 :: Monad m => Flow s m-n16, n11, n05 :: Monad m => Flow s m-o20, o18, o16, o14 :: Monad m => Flow s m-p11, p03 :: Monad m => Flow s m+b13, b12, b11, b10, b09, b08, b07, b06, b05, b04, b03 :: Monad m => Flow  m+c04, c03 :: Monad m => Flow  m+d05, d04 :: Monad m => Flow  m+e06, e05 :: Monad m => Flow  m+f07, f06 :: Monad m => Flow  m+g11, g09 :: Monad m => IfMatch -> Flow m+g08, g07 :: Monad m => Flow  m+h12, h11, h10, h07 :: Monad m => Flow  m+i13 :: Monad m => IfNoneMatch -> Flow m+i12, i07, i04 :: Monad m => Flow  m+j18 :: Monad m => Flow  m+k13 :: Monad m => IfNoneMatch -> Flow m+k07, k05 :: Monad m => Flow  m+l17, l15, l14, l13, l07, l05 :: Monad m => Flow  m+m20, m16, m07, m05 :: Monad m => Flow  m+n16, n11, n05 :: Monad m => Flow  m+o20, o18, o16, o14 :: Monad m => Flow  m+p11, p03 :: Monad m => Flow  m  ------------------------------------------------------------------------------ -- B column@@ -192,7 +179,9 @@     allowed <- lift allowedMethods     if requestMethod req `elem` allowed         then b09 r-        else lift $ halt HTTP.status405+        else do+            lift $ addResponseHeader ("Allow",  intercalate "," allowed)+            lift $ halt HTTP.status405  b09 r@Resource{..} = do     trace "b09"@@ -239,8 +228,11 @@ b03 r@Resource{..} = do     trace "b03"     req <- lift request+    allowed <- lift allowedMethods     if requestMethod req == HTTP.methodOptions-        then lift $ halt HTTP.status200+        then do+            lift $ addResponseHeader ("Allow",  intercalate "," allowed)+            lift $ halt HTTP.status204         else c03 r  ------------------------------------------------------------------------------@@ -313,7 +305,7 @@     trace "e05"     req <- lift request     let reqHeaders = requestHeaders req-    case lookup hAcceptCharset reqHeaders of+    case lookup HTTP.hAcceptCharset reqHeaders of         (Just _h) ->             e06 r         Nothing ->@@ -332,7 +324,7 @@     trace "f06"     req <- lift request     let reqHeaders = requestHeaders req-    case lookup hAcceptEncoding reqHeaders of+    case lookup HTTP.hAcceptEncoding reqHeaders of         (Just _h) ->             f07 r         Nothing ->@@ -342,34 +334,29 @@ -- G column ------------------------------------------------------------------------------ -g11 r@Resource{..} = do+g11 (IfMatch ifMatch) r@Resource{..} = do     trace "g11"-    req <- lift request-    let reqHeaders = requestHeaders req-        ifMatch = fromJust (lookup hIfMatch reqHeaders)-        etags = parseEtagList ifMatch+    let etags = parseEtagList ifMatch     if null etags         then lift $ halt HTTP.status412         else h10 r -g09 r@Resource{..} = do+g09 ifMatch r@Resource{..} = do     trace "g09"-    req <- lift request-    let reqHeaders = requestHeaders req-    case fromJust (lookup hIfMatch reqHeaders) of+    case ifMatch of         -- TODO: should we be stripping whitespace here?-        "*" ->+        (IfMatch "*") ->             h10 r         _ ->-            g11 r+            g11 ifMatch r  g08 r@Resource{..} = do     trace "g08"     req <- lift request     let reqHeaders = requestHeaders req-    case lookup hIfMatch reqHeaders of-        (Just _h) ->-            g09 r+    case IfMatch <$> lookup HTTP.hIfMatch reqHeaders of+        (Just h) ->+            g09 h r         Nothing ->             h10 r @@ -388,7 +375,7 @@ h12 r@Resource{..} = do     trace "h12"     modified <- lift lastModified-    parsedDate <- lift $ requestHeaderDate hIfUnmodifiedSince+    parsedDate <- lift $ requestHeaderDate HTTP.hIfUnmodifiedSince     let maybeGreater = do             lastM <- modified             headerDate <- parsedDate@@ -399,7 +386,7 @@  h11 r@Resource{..} = do     trace "h11"-    parsedDate <- lift $ requestHeaderDate hIfUnmodifiedSince+    parsedDate <- lift $ requestHeaderDate HTTP.hIfUnmodifiedSince     if isJust parsedDate         then h12 r         else i12 r@@ -408,7 +395,7 @@     trace "h10"     req <- lift request     let reqHeaders = requestHeaders req-    case lookup hIfUnmodifiedSince reqHeaders of+    case lookup HTTP.hIfUnmodifiedSince reqHeaders of         (Just _h) ->             h11 r         Nothing ->@@ -418,7 +405,7 @@     trace "h07"     req <- lift request     let reqHeaders = requestHeaders req-    case lookup hIfMatch reqHeaders of+    case lookup HTTP.hIfMatch reqHeaders of         -- TODO: should we be stripping whitespace here?         (Just "*") ->             lift $ halt HTTP.status412@@ -429,24 +416,22 @@ -- I column ------------------------------------------------------------------------------ -i13 r@Resource{..} = do+i13 ifNoneMatch r@Resource{..} = do     trace "i13"-    req <- lift request-    let reqHeaders = requestHeaders req-    case fromJust (lookup hIfNoneMatch reqHeaders) of+    case ifNoneMatch of         -- TODO: should we be stripping whitespace here?-        "*" ->+        (IfNoneMatch "*") ->             j18 r         _ ->-            k13 r+            k13 ifNoneMatch r  i12 r@Resource{..} = do     trace "i12"     req <- lift request     let reqHeaders = requestHeaders req-    case lookup hIfNoneMatch reqHeaders of-        (Just _h) ->-            i13 r+    case IfNoneMatch <$> lookup HTTP.hIfNoneMatch reqHeaders of+        (Just h) ->+            i13 h r         Nothing ->             l13 r @@ -485,12 +470,9 @@ -- K column ------------------------------------------------------------------------------ -k13 r@Resource{..} = do+k13 (IfNoneMatch ifNoneMatch) r@Resource{..} = do     trace "k13"-    req <- lift request-    let reqHeaders = requestHeaders req-        ifNoneMatch = fromJust (lookup hIfNoneMatch reqHeaders)-        etags = parseEtagList ifNoneMatch+    let etags = parseEtagList ifNoneMatch     if null etags         then l13 r         else j18 r@@ -518,7 +500,7 @@  l17 r@Resource{..} = do     trace "l17"-    parsedDate <- lift $ requestHeaderDate hIfModifiedSince+    parsedDate <- lift $ requestHeaderDate HTTP.hIfModifiedSince     modified <- lift lastModified     let maybeGreater = do             lastM <- modified@@ -530,7 +512,7 @@  l15 r@Resource{..} = do     trace "l15"-    parsedDate <- lift $ requestHeaderDate hIfModifiedSince+    parsedDate <- lift $ requestHeaderDate HTTP.hIfModifiedSince     now <- lift requestTime     let maybeGreater = (> now) <$> parsedDate     if maybeGreater == Just True@@ -541,7 +523,7 @@     trace "l14"     req <- lift request     let reqHeaders = requestHeaders req-        dateHeader = lookup hIfModifiedSince reqHeaders+        dateHeader = lookup HTTP.hIfModifiedSince reqHeaders         validDate = isJust (dateHeader >>= parseRfc1123Date)     if validDate         then l15 r@@ -551,7 +533,7 @@     trace "l13"     req <- lift request     let reqHeaders = requestHeaders req-    case lookup hIfModifiedSince reqHeaders of+    case lookup HTTP.hIfModifiedSince reqHeaders of         (Just _h) ->             l14 r         Nothing ->@@ -623,13 +605,13 @@  n11 r@Resource{..} = trace "n11" >> lift processPost >>= flip processPostAction r -create :: Monad m => [Text] -> Resource s m -> FlowStateT s m ()+create :: Monad m => [Text] -> Resource m -> FlowStateT m () create ts r = do     loc <- lift (appendRequestPath ts)     lift (addResponseHeader ("Location", loc))     negotiateContentTypesAccepted r -processPostAction :: Monad m => PostResponse s m -> Flow s m+processPostAction :: Monad m => PostResponse m -> Flow  m processPostAction (PostCreate ts) r = do     create ts r     p11 r

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes        #-} {-# LANGUAGE RecordWildCards   #-}@@ -8,29 +8,40 @@ #if __GLASGOW_HASKELL__ < 710 import           Control.Applicative #endif-import           Data.ByteString     (ByteString)+import           Data.ByteString           (ByteString)+import qualified Data.ByteString.Lazy      as LazyBS import           Data.Maybe #if __GLASGOW_HASKELL__ < 710 import           Data.Monoid #endif-import           Data.Text           (Text, intercalate)+import           Data.Text                 (Text, intercalate) import           Data.Text.Encoding-import           Data.Time           (getCurrentTime)+import           Data.Time                 (getCurrentTime)+import           Lens.Micro                ((^.)) import           Network.HTTP.Media-import qualified Network.HTTP.Types  as HTTP-import qualified Network.Wai         as Wai+import qualified Network.HTTP.Types        as HTTP+import qualified Network.Wai               as Wai+import           Network.Wai.Parse import           System.Random +import           Airship.Config+import           Airship.Headers import           Airship.Internal.Decision+import           Airship.Internal.Route import           Airship.Resource import           Airship.Types-import           Airship.Internal.Route +-- | Parse form data uploaded with a @Content-Type@ of either+-- @www-form-urlencoded@ or @multipart/form-data@ to return a+-- list of parameter names and values and a list of uploaded+-- files and their information.+parseFormData :: Request -> IO ([Param], [File LazyBS.ByteString])+parseFormData r = parseRequestBody lbsBackEnd r  -- | Returns @True@ if the request's @Content-Type@ header is one of the -- provided media types. If the @Content-Type@ header is not present, -- this function will return True.-contentTypeMatches :: [MediaType] -> Handler s m Bool+contentTypeMatches :: Monad m => [MediaType] -> Webmachine m Bool contentTypeMatches validTypes = do     headers <- requestHeaders <$> request     let cType = lookup HTTP.hContentType headers@@ -38,26 +49,19 @@         Nothing -> True         Just t  -> isJust $ matchAccept validTypes t --- | Construct an Airship 'Request' from a WAI request.-fromWaiRequest :: Wai.Request -> Request IO-fromWaiRequest req = Request-    { requestMethod = Wai.requestMethod req-    , httpVersion = Wai.httpVersion req-    , rawPathInfo = Wai.rawPathInfo req-    , rawQueryString = Wai.rawQueryString req-    , requestHeaders = Wai.requestHeaders req-    , isSecure = Wai.isSecure req-    , remoteHost = Wai.remoteHost req-    , pathInfo = Wai.pathInfo req-    , queryString = Wai.queryString req-    , requestBody = Wai.requestBody req-    , requestBodyLength = Wai.requestBodyLength req-    , requestHeaderHost = Wai.requestHeaderHost req-    , requestHeaderRange = Wai.requestHeaderRange req-    }+-- | Issue an HTTP 302 (Found) response, with `location' as the destination.+redirectTemporarily :: Monad m => ByteString -> Webmachine m a+redirectTemporarily location =+    addResponseHeader ("Location", location) >> halt HTTP.status302 -toWaiResponse :: Response IO -> ByteString -> ByteString -> Wai.Response-toWaiResponse Response{..} trace quip =+-- | Issue an HTTP 301 (Moved Permantently) response,+-- with `location' as the destination.+redirectPermanently :: Monad m => ByteString -> Webmachine m a+redirectPermanently location =+    addResponseHeader ("Location", location) >> halt HTTP.status301++toWaiResponse :: Response -> AirshipConfig -> ByteString -> ByteString -> Wai.Response+toWaiResponse Response{..} cfg trace quip =     case _responseBody of         (ResponseBuilder b) ->             Wai.responseBuilder _responseStatus headers b@@ -67,20 +71,32 @@             Wai.responseStream _responseStatus headers streamer         Empty ->             Wai.responseBuilder _responseStatus headers mempty-    where headers = _responseHeaders ++ [("Airship-Trace", trace), ("Airship-Quip", quip)]+    where+        headers = traced ++ quipHeader ++ _responseHeaders+        traced  = if cfg^.includeTraceHeader == IncludeHeader+                      then [("Airship-Trace", trace)]+                      else [] +        quipHeader  = if cfg^.includeQuipHeader == IncludeHeader+                      then [("Airship-Quip", quip)]+                      else []+ -- | Given a 'RoutingSpec', a 404 resource, and a user state @s@, construct a WAI 'Application'.-resourceToWai :: RoutingSpec s IO () -> Resource s IO -> s -> Wai.Application-resourceToWai routes resource404 s req respond = do+resourceToWai :: AirshipConfig -> RoutingSpec IO () -> Resource IO -> Wai.Application+resourceToWai cfg routes resource404 =+  resourceToWaiT cfg (const id) routes resource404++-- | Given a 'RoutingSpec', a 404 resource, and a user state @s@, construct a WAI 'Application'.+resourceToWaiT :: Monad m => AirshipConfig -> (Request -> m Wai.Response -> IO Wai.Response) -> RoutingSpec m () -> Resource m -> Wai.Application+resourceToWaiT cfg run routes resource404 req respond = do     let routeMapping = runRouter routes         pInfo = Wai.pathInfo req-        airshipReq = fromWaiRequest req         (resource, (params', matched)) = route routeMapping pInfo resource404     nowTime <- getCurrentTime     quip <- getQuip-    (response, trace) <- eitherResponse nowTime params' matched airshipReq s (flow resource)-    let traceHeaderValue = traceHeader trace-    respond (toWaiResponse response traceHeaderValue quip)+    (=<<) respond . run req $ do+      (response, trace) <- eitherResponse nowTime params' matched req (flow resource)+      return $ toWaiResponse response cfg (traceHeader trace) quip  getQuip :: IO ByteString getQuip = do@@ -95,6 +111,7 @@                 , "evacuation not done in time"                 , "javascript doesn't have integers"                 , "WARNING: ulimit -n is 1024"+                , "shut it down"                 ]  traceHeader :: [Text] -> ByteString

@@ -15,7 +15,8 @@ #if __GLASGOW_HASKELL__ < 710 import           Control.Applicative #endif-import Control.Monad.Writer (Writer, execWriter)+import Control.Monad.Identity+import Control.Monad.Writer (Writer, WriterT (..), execWriter) import Control.Monad.Writer.Class (MonadWriter)  import Data.String (IsString, fromString)@@ -32,7 +33,7 @@ instance IsString Route where     fromString s = Route [Bound (fromString s)] -runRouter :: RoutingSpec s m a -> [(Route, Resource s m)]+runRouter :: RoutingSpec m a -> [(Route, Resource m)] runRouter routes = execWriter (getRouter routes)  -- | @a '</>' b@ separates the path components @a@ and @b@ with a slash.@@ -68,7 +69,7 @@ -- | Represents a fully-specified set of routes that map paths (represented as 'Route's) to 'Resource's. 'RoutingSpec's are declared with do-notation, to wit: -- -- @---    myRoutes :: RoutingSpec MyState IO ()+--    myRoutes :: RoutingSpec IO () --    myRoutes = do --      root                                 #> myRootResource --      "blog" '</>' var "date" '</>' var "post" #> blogPostResource@@ -76,9 +77,8 @@ --      "anything" '</>' star                  #> wildcardResource -- @ ---newtype RoutingSpec s m a = RoutingSpec { getRouter :: Writer [(Route, Resource s m)] a }-    deriving (Functor, Applicative, Monad, MonadWriter [(Route, Resource s m)])-+newtype RoutingSpec m a = RoutingSpec { getRouter :: Writer [(Route, Resource m)] a }+    deriving (Functor, Applicative, Monad, MonadWriter [(Route, Resource m)])  route :: [(Route, a)] -> [Text] -> a -> (a, (HashMap Text Text, [Text])) route routes pInfo resource404 = foldr' (matchRoute pInfo) (resource404, (mempty, mempty)) routes

@@ -23,96 +23,96 @@ -- | Used when processing POST requests so as to handle the outcome of the binary decisions between -- handling a POST as a create request and whether to redirect after the POST is done. -- Credit for this idea goes to Richard Wallace (purefn) on Webcrank.-data PostResponse s m+data PostResponse m     = PostCreate [Text] -- ^ Treat this request as a PUT.     | PostCreateRedirect [Text] -- ^ Treat this request as a PUT, then redirect.-    | PostProcess (Handler s m ()) -- ^ Process as a POST, but don't redirect.-    | PostProcessRedirect (Handler s m ByteString) -- ^ Process and redirect.+    | PostProcess (Webmachine m ()) -- ^ Process as a POST, but don't redirect.+    | PostProcessRedirect (Webmachine m ByteString) -- ^ Process and redirect. -data Resource s m =+data Resource m =     Resource { -- | Whether to allow HTTP POSTs to a missing resource. Default: false.-               allowMissingPost         :: Handler s m Bool+               allowMissingPost         :: Webmachine m Bool                -- | The set of HTTP methods that this resource allows. Default: @GET@ and @HEAD@.                -- If a request arrives with an HTTP method not included herein, @501 Not Implemented@ is returned.-             , allowedMethods           :: Handler s m [Method]-               -- | An association list of 'MediaType's and 'Handler' actions that correspond to the accepted+             , allowedMethods           :: Webmachine m [Method]+               -- | An association list of 'MediaType's and 'Webmachine' actions that correspond to the accepted                -- @Content-Type@ values that this resource can accept in a request body. If a @Content-Type@ header                -- is present but not accounted for in 'contentTypesAccepted', processing will halt with @415 Unsupported Media Type@.-               -- Otherwise, the corresponding 'Handler' action will be executed and processing will continue.-             , contentTypesAccepted     :: Handler s m [(MediaType, Handler s m ())]+               -- Otherwise, the corresponding 'Webmachine' action will be executed and processing will continue.+             , contentTypesAccepted     :: Webmachine m [(MediaType, Webmachine m ())]                -- | An association list of 'MediaType' values and 'ResponseBody' values. The response will be chosen                -- by looking up the 'MediaType' that most closely matches the @Content-Type@ header. Should there be no match,                -- processing will halt with @406 Not Acceptable@.-             , contentTypesProvided     :: Handler s m [(MediaType, Webmachine s m (ResponseBody m))]+             , contentTypesProvided     :: Webmachine m [(MediaType, Webmachine m ResponseBody)]                -- | When a @DELETE@ request is enacted (via a @True@ value returned from 'deleteResource'), a                -- @False@ value returns a @202 Accepted@ response. Returning @True@ will continue processing,                -- usually ending up with a @204 No Content@ response. Default: False.-             , deleteCompleted          :: Handler s m Bool+             , deleteCompleted          :: Webmachine m Bool                -- | When processing a @DELETE@ request, a @True@ value allows processing to continue.                -- Returns @500 Forbidden@ if False. Default: false.-             , deleteResource           :: Handler s m Bool+             , deleteResource           :: Webmachine m Bool                -- | Returns @413 Request Entity Too Large@ if true. Default: false.-             , entityTooLarge           :: Handler s m Bool+             , entityTooLarge           :: Webmachine m Bool                -- | Checks if the given request is allowed to access this resource.                -- Returns @403 Forbidden@ if true. Default: false.-             , forbidden                :: Handler s m Bool+             , forbidden                :: Webmachine m Bool                -- | If this returns a non-'Nothing' 'ETag', its value will be added to every HTTP response                -- in the @ETag:@ field.-             , generateETag             :: Handler s m (Maybe ETag)+             , generateETag             :: Webmachine m (Maybe ETag)                -- | Checks if this resource has actually implemented a handler for a given HTTP method.                -- Returns @501 Not Implemented@ if false. Default: true.-             , implemented              :: Handler s m Bool+             , implemented              :: Webmachine m Bool                -- | Returns @401 Unauthorized@ if false. Default: true.-             , isAuthorized             :: Handler s m Bool+             , isAuthorized             :: Webmachine m Bool                -- | When processing @PUT@ requests, a @True@ value returned here will halt processing with a @409 Created@.-             , isConflict               :: Handler s m Bool+             , isConflict               :: Webmachine m Bool                -- | Returns @415 Unsupported Media Type@ if false. We recommend you use the 'contentTypeMatches' helper function, which accepts a list of                -- 'MediaType' values, so as to simplify proper MIME type handling. Default: true.-             , knownContentType         :: Handler s m Bool+             , knownContentType         :: Webmachine m Bool                -- | In the presence of an @If-Modified-Since@ header, returning a @Just@ value from 'lastModifed' allows                -- the server to halt with @304 Not Modified@ if appropriate.-             , lastModified             :: Handler s m (Maybe UTCTime)+             , lastModified             :: Webmachine m (Maybe UTCTime)                -- | If an @Accept-Language@ value is present in the HTTP request, and this function returns @False@,                -- processing will halt with @406 Not Acceptable@.-             , languageAvailable        :: Handler s m Bool+             , languageAvailable        :: Webmachine m Bool                -- | Returns @400 Bad Request@ if true. Default: false.-             , malformedRequest         :: Handler s m Bool+             , malformedRequest         :: Webmachine m Bool                                         -- wondering if this should be text,                                         -- or some 'path' type                -- | When processing a resource for which 'resourceExists' returned @False@, returning a @Just@ value                -- halts with a @301 Moved Permanently@ response. The contained 'ByteString' will be added to the                -- HTTP response under the @Location:@ header.-             , movedPermanently         :: Handler s m (Maybe ByteString)+             , movedPermanently         :: Webmachine m (Maybe ByteString)                -- | Like 'movedPermanently', except with a @307 Moved Temporarily@ response.-             , movedTemporarily         :: Handler s m (Maybe ByteString)+             , movedTemporarily         :: Webmachine m (Maybe ByteString)                -- | When handling a @PUT@ request, returning @True@ here halts processing with @300 Multiple Choices@. Default: False.-             , multipleChoices          :: Handler s m Bool+             , multipleChoices          :: Webmachine m Bool                -- | When processing a request for which 'resourceExists' returned @False@, returning @True@ here                -- allows the 'movedPermanently' and 'movedTemporarily' functions to process the request.-             , previouslyExisted        :: Handler s m Bool+             , previouslyExisted        :: Webmachine m Bool                -- | When handling @POST@ requests, the value returned determines whether to treat the request as a @PUT@,                -- a @PUT@ and a redirect, or a plain @POST@. See the documentation for 'PostResponse' for more information.                -- The default implemetation returns a 'PostProcess' with an empty handler.-             , processPost              :: Handler s m (PostResponse s m)+             , processPost              :: Webmachine m (PostResponse m)                -- | Does the resource at this path exist?                -- Returning false from this usually entails a @404 Not Found@ response.                -- (If 'allowMissingPost' returns @True@ or an @If-Match: *@ header is present, it may not).-             , resourceExists           :: Handler s m Bool+             , resourceExists           :: Webmachine m Bool                -- | Returns @503 Service Unavailable@ if false. Default: true.-             , serviceAvailable         :: Handler s m Bool+             , serviceAvailable         :: Webmachine m Bool                -- | Returns @414 Request URI Too Long@ if true. Default: false.-             , uriTooLong               :: Handler s m Bool+             , uriTooLong               :: Webmachine m Bool                -- | Returns @501 Not Implemented@ if false. Default: true.-             , validContentHeaders      :: Handler s m Bool+             , validContentHeaders      :: Webmachine m Bool              }  -- | A helper function that terminates execution with @500 Internal Server Error@.-serverError :: Handler m s a+serverError :: Monad m => Webmachine m a serverError = finishWith (Response status500 [] Empty)  -- | The default Airship resource, with "sensible" values filled in for each entry. -- You construct new resources by extending the default resource with your own handlers.-defaultResource :: Resource s m+defaultResource :: Monad m => Resource m defaultResource = Resource { allowMissingPost       = return False                            , allowedMethods         = return [methodGet, methodHead]                            , contentTypesAccepted   = return []

@@ -19,7 +19,7 @@ import           Airship.Headers (addResponseHeader) import           Airship.Types ( ETag(Strong)                                , ResponseBody(ResponseFile)-                               , Handler+                               , Webmachine                                , dispatchPath                                , halt                                )@@ -113,10 +113,10 @@     let infos = fileInfos (zipWith (\(a,b) c -> (a,b,c)) regularFiles etags)     return (FileTree (Trie.fromList infos) (T.pack f)) -staticResource :: StaticOptions -> FilePath -> IO (Resource s m)+staticResource :: Monad m => StaticOptions -> FilePath -> IO (Resource m) staticResource options p = staticResource' options <$> directoryTree p -staticResource' :: StaticOptions -> FileTree -> Resource s m+staticResource' :: Monad m => StaticOptions -> FileTree -> Resource m staticResource' options FileTree{..} = defaultResource     { allowedMethods = return [ HTTP.methodGet, HTTP.methodHead ]     , resourceExists = getFileInfo >> return True@@ -137,7 +137,7 @@         return [ (mediaType, response)                , ("application/octet-stream", response)]     }-    where getFileInfo :: Handler s m FileInfo+    where getFileInfo :: Monad m => Webmachine m FileInfo           getFileInfo = do             dispath <- dispatchPath             let key = encodeUtf8 (T.intercalate "/" (root:dispath))@@ -146,7 +146,7 @@                 (Just r) -> return r                 Nothing -> halt HTTP.status404 -addNoCacheHeaders :: Handler s m ()+addNoCacheHeaders :: Monad m => Webmachine m () addNoCacheHeaders = do     addResponseHeader (HTTP.hCacheControl, "no-cache, no-store, must-revalidate")     addResponseHeader ("Pragma", "no-cache")

@@ -12,7 +12,6 @@ module Airship.Types     ( ETag(..)     , Webmachine-    , Handler     , Request(..)     , Response(..)     , ResponseState(..)@@ -25,9 +24,6 @@     , runWebmachine     , request     , requestTime-    , getState-    , putState-    , modifyState     , getResponseHeaders     , getResponseBody     , params@@ -49,10 +45,10 @@ #endif import Control.Monad (liftM) import Control.Monad.Base (MonadBase)-import Control.Monad.IO.Class (MonadIO)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Morph import Control.Monad.Reader.Class (MonadReader, ask) import Control.Monad.State.Class (MonadState, get, modify)-import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Control (MonadBaseControl(..)) import Control.Monad.Trans.Either (EitherT(..), runEitherT, left) import Control.Monad.Trans.RWS.Strict (RWST(..), runRWST)@@ -63,62 +59,25 @@ import Data.Text (Text) import Data.Time.Clock (UTCTime) -import Network.Socket (SockAddr(..))-import qualified Network.HTTP.Types as HTTP import Network.HTTP.Types ( ResponseHeaders-                          , RequestHeaders-                          , Query                           , Status-                          , Method-                          , HttpVersion )+                          )  import qualified Network.Wai as Wai+import           Network.Wai (Request (..), defaultRequest) --- | Very similar to WAI's @Request@ type, except generalized to an arbitrary monad @m@.-data Request m =-    Request { requestMethod :: Method -- ^ The request method -- @GET@, @POST@, @DELETE@, et cetera.-            , httpVersion :: HttpVersion -- ^ The HTTP version (usually 1.1; hopefully someday 2.0).-            , rawPathInfo :: ByteString -- ^ The unparsed path information yielded from the WAI server. You probably want 'pathInfo'.-            , rawQueryString :: ByteString -- ^ The query string, if any, yielded from the WAI server. You probably want 'queryString'.-            , requestHeaders :: RequestHeaders -- ^ An association list of (headername, value) pairs. See "Network.HTTP.Types.Header" for the possible values.-            , isSecure :: Bool -- ^ Was this request made over SSL/TLS?-            , remoteHost :: SockAddr -- ^ The address information of the client.-            , pathInfo :: [Text] -- ^ The URL, stripped of hostname and port, split on forward-slashes-            , queryString :: Query -- ^ Parsed query string information.-            , requestBody :: m ByteString -- ^ A monadic action that extracts a (possibly-empty) chunk of the request body.-            , requestBodyLength :: Wai.RequestBodyLength -- ^ Either @ChunkedBody@ or a @KnownLength 'Word64'@.-            , requestHeaderHost :: Maybe ByteString -- ^ Contains the Host header.-            , requestHeaderRange :: Maybe ByteString -- ^ Contains the Range header.-            } -defaultRequest :: Monad m => Request m-defaultRequest = Request-    { requestMethod = HTTP.methodGet-    , httpVersion = HTTP.http10-    , rawPathInfo = BS.empty-    , rawQueryString = BS.empty-    , requestHeaders = []-    , isSecure = False-    , remoteHost = SockAddrInet 0 0-    , pathInfo = []-    , queryString = []-    , requestBody = return BS.empty-    , requestBodyLength = Wai.KnownLength 0-    , requestHeaderHost = Nothing-    , requestHeaderRange = Nothing-    }- -- | Reads the entirety of the request body in a single string. -- This turns the chunks obtained from repeated invocations of 'requestBody' into a lazy 'ByteString'.-entireRequestBody :: Monad m => Request m -> m LB.ByteString-entireRequestBody req = requestBody req >>= strictRequestBody' LB.empty+entireRequestBody :: MonadIO m => Request -> m LB.ByteString+entireRequestBody req = liftIO (requestBody req) >>= strictRequestBody' LB.empty     where strictRequestBody' acc prev             | BS.null prev = return acc-            | otherwise = requestBody req >>= strictRequestBody' (acc <> LB.fromStrict prev)+            | otherwise = liftIO (requestBody req) >>= strictRequestBody' (acc <> LB.fromStrict prev) -data RequestReader m = RequestReader { _now :: UTCTime-                                     , _request :: Request m-                                     }+data RequestReader = RequestReader { _now :: UTCTime+                                   , _request :: Request+                                   }  data ETag = Strong ByteString           | Weak ByteString@@ -130,51 +89,47 @@ etagToByteString (Strong bs) = "\"" <> bs <> "\"" etagToByteString (Weak bs) = "W/\"" <> bs <> "\"" -type StreamingBody m = (Builder -> m ()) -> m () -> m ()---- | Basically Wai's unexported 'Response' type, but generalized to any monad,--- 'm'.-data ResponseBody m+-- | Basically Wai's unexported 'Response' type.+data ResponseBody     = ResponseFile FilePath (Maybe Wai.FilePart)     | ResponseBuilder Builder-    | ResponseStream (StreamingBody m)+    | ResponseStream Wai.StreamingBody     | Empty     -- ResponseRaw ... (not implemented yet, but useful for websocket upgrades)  -- | Helper function for building a `ResponseBuilder` out of HTML-escaped text.-escapedResponse :: Text -> ResponseBody m+escapedResponse :: Text -> ResponseBody escapedResponse = ResponseBuilder . fromHtmlEscapedText -data Response m = Response { _responseStatus     :: Status-                           , _responseHeaders    :: ResponseHeaders-                           , _responseBody       :: ResponseBody m-                           }+data Response = Response { _responseStatus     :: Status+                         , _responseHeaders    :: ResponseHeaders+                         , _responseBody       :: ResponseBody+                         } -data ResponseState s m = ResponseState { stateUser      :: s-                                       , stateHeaders   :: ResponseHeaders-                                       , stateBody      :: ResponseBody m-                                       , _params        :: HashMap Text Text-                                       , _dispatchPath   :: [Text]-                                       }+data ResponseState = ResponseState { stateHeaders   :: ResponseHeaders+                                   , stateBody      :: ResponseBody+                                   , _params        :: HashMap Text Text+                                   , _dispatchPath  :: [Text]+                                   }  type Trace = [Text] -newtype Webmachine s m a =-    Webmachine { getWebmachine :: EitherT (Response m) (RWST (RequestReader m) Trace (ResponseState s m) m) a }+newtype Webmachine m a =+    Webmachine { getWebmachine :: EitherT Response (RWST RequestReader Trace ResponseState m) a }         deriving (Functor, Applicative, Monad, MonadIO, MonadBase b,-                  MonadReader (RequestReader m),+                  MonadReader RequestReader,                   MonadWriter Trace,-                  MonadState (ResponseState s m))+                  MonadState ResponseState) -instance MonadTrans (Webmachine s) where+instance MonadTrans Webmachine where     lift = Webmachine . EitherT . (>>= return . Right) . lift -newtype StMWebmachine s m a = StMWebmachine {-      unStMWebmachine :: StM (EitherT (Response m) (RWST (RequestReader m) Trace (ResponseState s m) m)) a+newtype StMWebmachine m a = StMWebmachine {+      unStMWebmachine :: StM (EitherT Response (RWST RequestReader Trace ResponseState m)) a     } -instance MonadBaseControl b m => MonadBaseControl b (Webmachine s m) where-  type StM (Webmachine s m) a = StMWebmachine s m a+instance MonadBaseControl b m => MonadBaseControl b (Webmachine m) where+  type StM (Webmachine m) a = StMWebmachine m a   liftBaseWith f = Webmachine                      $ liftBaseWith                      $ \g' -> f@@ -183,68 +138,53 @@   restoreM = Webmachine . restoreM . unStMWebmachine  -- | A convenience synonym that writes the @Monad@ type constraint for you.-type Handler s m a = Monad m => Webmachine s m a+type Handler m a = Monad m => Webmachine m a  -- Functions inside the Webmachine Monad ------------------------------------- ------------------------------------------------------------------------------  -- | Returns the 'Request' that this 'Handler' is currently processing.-request :: Handler s m (Request m)+request :: Handler m Request request = _request <$> ask  -- | Returns the bound routing parameters extracted from the routing system (see "Airship.Route").-params :: Handler s m (HashMap Text Text)+params :: Handler m (HashMap Text Text) params = _params <$> get -dispatchPath :: Handler s m [Text]+dispatchPath :: Handler m [Text] dispatchPath = _dispatchPath <$> get  -- | Returns the time at which this request began processing.-requestTime :: Handler s m UTCTime+requestTime :: Handler m UTCTime requestTime = _now <$> ask --- | Returns the user state (of type @s@) in the provided @'Handler' s m@.-getState :: Handler s m s-getState = stateUser <$> get---- | Sets the user state.-putState :: s -> Handler s m ()-putState s = modify updateState-    where updateState rs = rs {stateUser = s}---- | Applies the provided function to the user state.-modifyState :: (s -> s) -> Handler s m ()-modifyState f = modify modifyState'-    where modifyState' rs@ResponseState{stateUser=uState} =-                                        rs {stateUser = f uState}- -- | Returns the 'ResponseHeaders' stored in the current 'Handler'.-getResponseHeaders :: Handler s m ResponseHeaders+getResponseHeaders :: Handler m ResponseHeaders getResponseHeaders = stateHeaders <$> get  -- | Returns the current 'ResponseBody' that this 'Handler' is storing.-getResponseBody :: Handler s m (ResponseBody m)+getResponseBody :: Handler m ResponseBody getResponseBody = stateBody <$> get  -- | Given a new 'ResponseBody', replaces the stored body with the new one.-putResponseBody :: ResponseBody m -> Handler s m ()+putResponseBody :: ResponseBody -> Handler m () putResponseBody b = modify updateState     where updateState rs = rs {stateBody = b}  -- | Stores the provided 'ByteString' as the responseBody. This is a shortcut for -- creating a response body with a 'ResponseBuilder' and a bytestring 'Builder'.-putResponseBS :: ByteString -> Handler s m ()+putResponseBS :: Monad m => ByteString -> Webmachine m () putResponseBS bs = putResponseBody $ ResponseBuilder $ fromByteString bs  -- | Immediately halts processing with the provided 'Status' code.--- The contents of the 'Handler''s response body will be streamed back to the client.+-- The contents of the 'Webmachine''s response body will be streamed back to the client. -- This is a shortcut for constructing a 'Response' with 'getResponseHeaders' and 'getResponseBody' -- and passing that response to 'finishWith'.-halt :: Status -> Handler m s a-halt status = finishWith =<< Response <$> pure status <*> getResponseHeaders <*> getResponseBody+halt :: Monad m => Status -> Webmachine m a+halt status = finishWith =<< Response <$> return status <*> getResponseHeaders <*> getResponseBody  -- | Immediately halts processing and writes the provided 'Response' back to the client.-finishWith :: Response m -> Handler s m a+finishWith :: Monad m => Response -> Webmachine m a finishWith = Webmachine . left  -- | The @#>@ operator provides syntactic sugar for the construction of association lists.@@ -272,14 +212,14 @@ both :: Either a a -> a both = either id id -eitherResponse :: Monad m => UTCTime -> HashMap Text Text -> [Text] -> Request m -> s -> Handler s m (Response m) -> m (Response m, Trace)-eitherResponse reqDate reqParams dispatched req s resource = do-    (e, trace) <- runWebmachine reqDate reqParams dispatched req s resource+eitherResponse :: Monad m => UTCTime -> HashMap Text Text -> [Text] -> Request -> Webmachine m Response -> m (Response, Trace)+eitherResponse reqDate reqParams dispatched req resource = do+    (e, trace) <- runWebmachine reqDate reqParams dispatched req resource     return (both e, trace) -runWebmachine :: Monad m => UTCTime -> HashMap Text Text -> [Text] -> Request m -> s -> Handler s m a -> m (Either (Response m) a, Trace)-runWebmachine reqDate reqParams dispatched req s w = do-    let startingState = ResponseState s [] Empty reqParams dispatched+runWebmachine :: Monad m => UTCTime -> HashMap Text Text -> [Text] -> Request -> Webmachine m a -> m (Either (Response) a, Trace)+runWebmachine reqDate reqParams dispatched req w = do+    let startingState = ResponseState [] Empty reqParams dispatched         requestReader = RequestReader reqDate req     (e, _, t) <- runRWST (runEitherT (getWebmachine w)) requestReader startingState     return (e, t)

@@ -3,9 +3,7 @@ module Main where  import Airship-import Control.Monad.Trans.State.Strict (State, evalState, get, put)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as LB+import Control.Concurrent import Data.ByteString (ByteString)  import Test.Tasty@@ -24,27 +22,16 @@ exampleTests = testGroup "ExampleTests"   [ bodyTest ] -type RequestState = State [ByteString]- bodyChunks :: [ByteString] bodyChunks = ["one", "two", "three", "four", "five"] -nextBody :: RequestState ByteString-nextBody = do-    s <- get-    if null s-        then return BS.empty-        else do-            let (h:tl) = s-            put tl-            return h+bodyChunksIO :: IO (IO ByteString)+bodyChunksIO = do+    v <- newMVar bodyChunks+    return $ modifyMVar v (\l -> return $ case l of { [] -> ([], ""); h : t -> (t, h) })  bodyTest :: TestTree-bodyTest = testCase "entireRequestBody returns the body in the correct order" bodyTest'-    where bodyTest' = evalState state bodyChunks @?= "onetwothreefourfive"-          state :: RequestState LB.ByteString-          state = entireRequestBody req-          req = defRequest { requestBody = nextBody }-          -- for some reason this type signature seems to be necessary-          defRequest :: Request RequestState-          defRequest = defaultRequest+bodyTest = testCase "entireRequestBody returns the body in the correct order" $ do+    nextBody <- bodyChunksIO+    b <- entireRequestBody defaultRequest { requestBody = nextBody }+    b @?= "onetwothreefourfive"