diff --git a/airship.cabal b/airship.cabal --- a/airship.cabal +++ b/airship.cabal @@ -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.* diff --git a/bin/Main.hs b/bin/Main.hs deleted file mode 100644 --- a/bin/Main.hs +++ /dev/null @@ -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 "

404 Not Found

" - 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) diff --git a/src/Airship.hs b/src/Airship.hs --- a/src/Airship.hs +++ b/src/Airship.hs @@ -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 diff --git a/src/Airship/Config.hs b/src/Airship/Config.hs new file mode 100644 --- /dev/null +++ b/src/Airship/Config.hs @@ -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 diff --git a/src/Airship/Headers.hs b/src/Airship/Headers.hs --- a/src/Airship/Headers.hs +++ b/src/Airship/Headers.hs @@ -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 :) diff --git a/src/Airship/Helpers.hs b/src/Airship/Helpers.hs --- a/src/Airship/Helpers.hs +++ b/src/Airship/Helpers.hs @@ -1,7 +1,10 @@ module Airship.Helpers - ( contentTypeMatches - , fromWaiRequest + ( parseFormData + , contentTypeMatches + , redirectTemporarily + , redirectPermanently , resourceToWai + , resourceToWaiT ) where import Airship.Internal.Helpers diff --git a/src/Airship/Internal/Decision.hs b/src/Airship/Internal/Decision.hs --- a/src/Airship/Internal/Decision.hs +++ b/src/Airship/Internal/Decision.hs @@ -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 diff --git a/src/Airship/Internal/Helpers.hs b/src/Airship/Internal/Helpers.hs --- a/src/Airship/Internal/Helpers.hs +++ b/src/Airship/Internal/Helpers.hs @@ -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 diff --git a/src/Airship/Internal/Route.hs b/src/Airship/Internal/Route.hs --- a/src/Airship/Internal/Route.hs +++ b/src/Airship/Internal/Route.hs @@ -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 diff --git a/src/Airship/Resource.hs b/src/Airship/Resource.hs --- a/src/Airship/Resource.hs +++ b/src/Airship/Resource.hs @@ -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 [] diff --git a/src/Airship/Resource/Static.hs b/src/Airship/Resource/Static.hs --- a/src/Airship/Resource/Static.hs +++ b/src/Airship/Resource/Static.hs @@ -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") diff --git a/src/Airship/Types.hs b/src/Airship/Types.hs --- a/src/Airship/Types.hs +++ b/src/Airship/Types.hs @@ -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) diff --git a/test/unit/test.hs b/test/unit/test.hs --- a/test/unit/test.hs +++ b/test/unit/test.hs @@ -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"