diff --git a/airship.cabal b/airship.cabal --- a/airship.cabal +++ b/airship.cabal @@ -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 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 @@ -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) 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,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 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 @@ -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 diff --git a/src/Airship/Resource.hs b/src/Airship/Resource.hs --- a/src/Airship/Resource.hs +++ b/src/Airship/Resource.hs @@ -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 } diff --git a/src/Airship/Types.hs b/src/Airship/Types.hs --- a/src/Airship/Types.hs +++ b/src/Airship/Types.hs @@ -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