airship 0.5.0 → 0.6.0
raw patch · 6 files changed
+165/−92 lines, 6 filesdep +containersdep ~base
Dependencies added: containers
Dependency ranges changed: base
Files
- airship.cabal +2/−1
- src/Airship/Internal/Decision.hs +4/−4
- src/Airship/Internal/Helpers.hs +63/−13
- src/Airship/Internal/Route.hs +23/−17
- src/Airship/Resource.hs +6/−2
- src/Airship/Types.hs +67/−55
airship.cabal view
@@ -3,7 +3,7 @@ description: A Webmachine-inspired HTTP library homepage: https://github.com/helium/airship/ Bug-reports: https://github.com/helium/airship/issues-version: 0.5.0+version: 0.6.0 license: MIT license-file: LICENSE author: Reid Draper and Patrick Thomson@@ -42,6 +42,7 @@ , bytestring , bytestring-trie == 0.2.4.* , case-insensitive+ , containers , cryptohash == 0.11.* , directory , either >= 4.3 && < 4.6
src/Airship/Internal/Decision.hs view
@@ -12,6 +12,9 @@ import Airship.Headers (addResponseHeader) import Airship.Internal.Date (parseRfc1123Date, utcTimeToRfc1123)+import Airship.Internal.Parsers (parseEtagList)+import Airship.Resource (PostResponse (..),+ Resource (..)) import Airship.Types (Response (..), ResponseBody (..), Webmachine, etagToByteString,@@ -20,10 +23,6 @@ pathInfo, putResponseBody, request, requestHeaders, requestMethod, requestTime)--import Airship.Internal.Parsers (parseEtagList)-import Airship.Resource (PostResponse (..),- Resource (..)) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif@@ -32,6 +31,7 @@ import Control.Monad.Trans.State.Strict (StateT (..), evalStateT, get, modify) import Control.Monad.Writer.Class (tell)+ import Blaze.ByteString.Builder (toByteString) import Data.ByteString (ByteString, intercalate)
src/Airship/Internal/Helpers.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}@@ -18,13 +19,16 @@ #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif+import Control.Monad (join) import Data.ByteString (ByteString)-import qualified Data.ByteString.Lazy as LazyBS+import qualified Data.ByteString.Lazy as LB import Data.Maybe #if __GLASGOW_HASKELL__ < 710 import Data.Monoid #endif+import Data.Foldable (forM_) import qualified Data.HashMap.Strict as HM+import qualified Data.Map.Strict as M import Data.Text (Text, intercalate) import Data.Text.Encoding import Data.Time (getCurrentTime)@@ -47,7 +51,7 @@ -- @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 :: Request -> IO ([Param], [File LB.ByteString]) parseFormData r = parseRequestBody lbsBackEnd r -- | Returns @True@ if the request's @Content-Type@ header is one of the@@ -94,21 +98,67 @@ else [] -- | Given a 'RoutingSpec', a 404 resource, and a user state @s@, construct a WAI 'Application'.-resourceToWai :: AirshipConfig -> RoutingSpec IO () -> Resource IO -> Wai.Application-resourceToWai cfg routes resource404 =- resourceToWaiT cfg (const id) routes resource404+resourceToWai :: AirshipConfig+ -> RoutingSpec IO ()+ -> ErrorResponses IO+ -> Wai.Application+resourceToWai cfg routes errors =+ resourceToWaiT cfg (const id) routes errors --- | 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+-- | Given a 'RoutingSpec', an 'ErrorResponses', and a user state @s@, construct a WAI 'Application'.+resourceToWaiT :: Monad m =>+ AirshipConfig+ -> (Request -> m Wai.Response -> IO Wai.Response)+ -> RoutingSpec m ()+ -> ErrorResponses m+ -> Wai.Application+resourceToWaiT cfg run routes errors req respond = do let routeMapping = runRouter routes pInfo = Wai.pathInfo req- (resource, (params', matched)) = route routeMapping pInfo resource404- nowTime <- getCurrentTime quip <- getQuip- (=<<) respond . run req $ do- (response, trace) <- eitherResponse nowTime params' matched req (flow resource)- return $ toWaiResponse response cfg (traceHeader trace) quip+ nowTime <- getCurrentTime+ let (er, (ps, matched), r) =+ case route routeMapping pInfo of+ Nothing ->+ (errors, (mempty, []), return $ Response HTTP.status404 [(HTTP.hContentType, "text/plain")] Empty)+ Just (resource, pm) ->+ (M.union (errorResponses resource) errors, pm, flow resource)+ respond =<< run req (do+ (response, trace) <- eitherResponse nowTime ps matched req (r >>= errorResponse er)+ return $ toWaiResponse response cfg (traceHeader trace) quip)+++-- | If the Response body is Empty the response body is set based on the error responses+-- provided by the application and resource. If the response body is not Empty or+-- there are no error response configured for the status code in the Response then no+-- action is taken. The contents of the 'Webmachine'' response body will be streamed+-- back to the client.+errorResponse :: Monad m =>+ ErrorResponses m+ -> Response+ -> Webmachine m Response+errorResponse errResps r@Response{..}+ | (HTTP.statusIsClientError _responseStatus ||+ HTTP.statusIsServerError _responseStatus) &&+ isResponseBodyEmpty _responseBody = do+ req <- request+ let reqHeaders = requestHeaders req+ acceptStr = lookup HTTP.hAccept reqHeaders+ errBodies = map dupContentType <$> M.lookup _responseStatus errResps+ mResp = join $ mapAcceptMedia <$> errBodies <*> acceptStr+ forM_ mResp $ \(ct, body) -> do+ putResponseBody =<< body+ addResponseHeader ("Content-Type", renderHeader ct)+ Response+ <$> return _responseStatus+ <*> getResponseHeaders+ <*> getResponseBody+ | otherwise = return r+ where+ isResponseBodyEmpty Empty = True+ isResponseBodyEmpty _ = False+ dupContentType (a, b) = (a, (a, b))+ getQuip :: IO ByteString getQuip = do
src/Airship/Internal/Route.hs view
@@ -1,25 +1,24 @@ {-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-} module Airship.Internal.Route where -import Airship.Resource+import Airship.Resource -import Data.Monoid-import Data.Foldable (foldr')-import Data.Text (Text)-import Data.HashMap.Strict (HashMap, insert)+import Data.Foldable (foldr')+import Data.HashMap.Strict (HashMap, insert)+import Data.Monoid+import Data.Text (Text) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif-import Control.Monad.Identity-import Control.Monad.Writer (Writer, WriterT (..), execWriter)-import Control.Monad.Writer.Class (MonadWriter)+import Control.Monad.Writer (Writer, WriterT (..), execWriter)+import Control.Monad.Writer.Class (MonadWriter) -import Data.String (IsString, fromString)+import Data.String (IsString, fromString) -- | 'Route's represent chunks of text used to match over URLs. -- You match hardcoded paths with string literals (and the @-XOverloadedStrings@ extension),@@ -80,14 +79,21 @@ 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+type MatchedRoute a = (a, (HashMap Text Text, [Text])) -matchRoute :: [Text] -> (Route, a) -> (a, (HashMap Text Text, [Text])) -> (a, (HashMap Text Text, [Text]))-matchRoute paths (rSpec, resource) (previousMatch, previousMap) =+route :: [(Route, a)]+ -> [Text]+ -> Maybe (MatchedRoute a)+route routes pInfo = foldr' (matchRoute pInfo) Nothing routes++matchRoute :: [Text]+ -> (Route, a)+ -> Maybe (MatchedRoute a)+ -> Maybe (MatchedRoute a)+matchRoute paths (rSpec, resource) previousMatch = case matchesRoute paths rSpec of- Nothing -> (previousMatch, previousMap)- Just m -> (resource, m)+ Nothing -> previousMatch+ Just m -> Just (resource, m) matchesRoute :: [Text] -> Route -> Maybe (HashMap Text Text, [Text]) matchesRoute paths spec = matchesRoute' paths (getRoute spec) (mempty, mempty) False where
src/Airship/Resource.hs view
@@ -1,5 +1,5 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -14,9 +14,11 @@ import Airship.Types import Data.ByteString (ByteString)+#if __GLASGOW_HASKELL__ < 710+import Data.Monoid (mempty)+#endif import Data.Text (Text) import Data.Time.Clock (UTCTime)- import Network.HTTP.Media (MediaType) import Network.HTTP.Types @@ -111,6 +113,7 @@ , uriTooLong :: Webmachine m Bool -- | Returns @501 Not Implemented@ if false. Default: true. , validContentHeaders :: Webmachine m Bool+ , errorResponses :: ErrorResponses m } -- | A helper function that terminates execution with @500 Internal Server Error@.@@ -146,4 +149,5 @@ , serviceAvailable = return True , uriTooLong = return False , validContentHeaders = return True+ , errorResponses = mempty }
src/Airship/Types.hs view
@@ -1,13 +1,14 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} module Airship.Types ( ETag(..)@@ -16,11 +17,13 @@ , Response(..) , ResponseState(..) , ResponseBody(..)+ , ErrorResponses , defaultRequest , entireRequestBody , etagToByteString , eitherResponse , escapedResponse+ , mapWebmachine , runWebmachine , request , requestTime@@ -35,36 +38,40 @@ , (#>) ) where -import Blaze.ByteString.Builder (Builder)-import Blaze.ByteString.Builder.ByteString (fromByteString)-import Blaze.ByteString.Builder.Html.Utf8 (fromHtmlEscapedText)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as LB+import Blaze.ByteString.Builder (Builder)+import Blaze.ByteString.Builder.ByteString (fromByteString)+import Blaze.ByteString.Builder.Html.Utf8 (fromHtmlEscapedText)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LB #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif-import Control.Monad (liftM)-import Control.Monad.Base (MonadBase)-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.Control (MonadBaseControl(..))-import Control.Monad.Trans.Either (EitherT(..), runEitherT, left)-import Control.Monad.Trans.RWS.Strict (RWST(..), runRWST)-import Control.Monad.Writer.Class (MonadWriter, tell)-import Data.ByteString.Char8-import Data.HashMap.Strict (HashMap)-import Data.Monoid ((<>))-import Data.Text (Text)-import Data.Time.Clock (UTCTime)+import Control.Monad (liftM)+import Control.Monad.Base (MonadBase)+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.Control (MonadBaseControl (..))+import Control.Monad.Trans.Either (EitherT (..), left,+ mapEitherT, runEitherT)+import Control.Monad.Trans.RWS.Strict (RWST (..), mapRWST,+ runRWST)+import Control.Monad.Writer.Class (MonadWriter, tell)+import Data.ByteString.Char8+import Data.HashMap.Strict (HashMap)+import Data.Map.Strict (Map)+import Data.Monoid ((<>))+import Data.Text (Text)+import Data.Time.Clock (UTCTime)+import Network.HTTP.Media+import qualified Network.HTTP.Types as HTTP -import Network.HTTP.Types ( ResponseHeaders- , Status- )+import Network.HTTP.Types (ResponseHeaders, Status) -import qualified Network.Wai as Wai-import Network.Wai (Request (..), defaultRequest)+import Network.Wai (Request (..),+ defaultRequest)+import qualified Network.Wai as Wai -- | Reads the entirety of the request body in a single string.@@ -75,7 +82,7 @@ | BS.null prev = return acc | otherwise = liftIO (requestBody req) >>= strictRequestBody' (acc <> LB.fromStrict prev) -data RequestReader = RequestReader { _now :: UTCTime+data RequestReader = RequestReader { _now :: UTCTime , _request :: Request } @@ -101,19 +108,21 @@ escapedResponse :: Text -> ResponseBody escapedResponse = ResponseBuilder . fromHtmlEscapedText -data Response = Response { _responseStatus :: Status- , _responseHeaders :: ResponseHeaders- , _responseBody :: ResponseBody+data Response = Response { _responseStatus :: Status+ , _responseHeaders :: ResponseHeaders+ , _responseBody :: ResponseBody } -data ResponseState = ResponseState { stateHeaders :: ResponseHeaders- , stateBody :: ResponseBody- , _params :: HashMap Text Text- , _dispatchPath :: [Text]+data ResponseState = ResponseState { stateHeaders :: ResponseHeaders+ , stateBody :: ResponseBody+ , _params :: HashMap Text Text+ , _dispatchPath :: [Text] } type Trace = [Text] +type ErrorResponses m = Monad m => Map HTTP.Status [(MediaType, Webmachine m ResponseBody)]+ newtype Webmachine m a = Webmachine { getWebmachine :: EitherT Response (RWST RequestReader Trace ResponseState m) a } deriving (Functor, Applicative, Monad, MonadIO, MonadBase b,@@ -137,37 +146,34 @@ $ g' $ getWebmachine m restoreM = Webmachine . restoreM . unStMWebmachine --- | A convenience synonym that writes the @Monad@ type constraint for you.-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 m Request+-- | Returns the 'Request' that is currently being processed.+request :: Monad m => Webmachine m Request request = _request <$> ask -- | Returns the bound routing parameters extracted from the routing system (see "Airship.Route").-params :: Handler m (HashMap Text Text)+params :: Monad m => Webmachine m (HashMap Text Text) params = _params <$> get -dispatchPath :: Handler m [Text]+dispatchPath :: Monad m => Webmachine m [Text] dispatchPath = _dispatchPath <$> get -- | Returns the time at which this request began processing.-requestTime :: Handler m UTCTime+requestTime :: Monad m => Webmachine m UTCTime requestTime = _now <$> ask --- | Returns the 'ResponseHeaders' stored in the current 'Handler'.-getResponseHeaders :: Handler m ResponseHeaders+-- | Returns the current 'ResponseHeaders'.+getResponseHeaders :: Monad m => Webmachine m ResponseHeaders getResponseHeaders = stateHeaders <$> get --- | Returns the current 'ResponseBody' that this 'Handler' is storing.-getResponseBody :: Handler m ResponseBody+-- | Returns the current 'ResponseBody'.+getResponseBody :: Monad m => Webmachine m ResponseBody getResponseBody = stateBody <$> get -- | Given a new 'ResponseBody', replaces the stored body with the new one.-putResponseBody :: ResponseBody -> Handler m ()+putResponseBody :: Monad m => ResponseBody -> Webmachine m () putResponseBody b = modify updateState where updateState rs = rs {stateBody = b} @@ -216,6 +222,12 @@ eitherResponse reqDate reqParams dispatched req resource = do (e, trace) <- runWebmachine reqDate reqParams dispatched req resource return (both e, trace)++-- | Map both the return value and wrapped computation @m@.+mapWebmachine :: ( m1 (Either Response a1, ResponseState, Trace)+ -> m2 (Either Response a2, ResponseState, Trace) )+ -> Webmachine m1 a1 -> Webmachine m2 a2+mapWebmachine f = Webmachine . (mapEitherT $ mapRWST f) . getWebmachine runWebmachine :: Monad m => UTCTime -> HashMap Text Text -> [Text] -> Request -> Webmachine m a -> m (Either (Response) a, Trace) runWebmachine reqDate reqParams dispatched req w = do