airship 0.4.3.0 → 0.5.0
raw patch · 4 files changed
+123/−111 lines, 4 filesdep ~cryptohash
Dependency ranges changed: cryptohash
Files
- airship.cabal +2/−2
- src/Airship/Internal/Decision.hs +49/−45
- src/Airship/Internal/Helpers.hs +1/−1
- src/Airship/Resource.hs +71/−63
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.4.3.0+version: 0.5.0 license: MIT license-file: LICENSE author: Reid Draper and Patrick Thomson@@ -42,7 +42,7 @@ , bytestring , bytestring-trie == 0.2.4.* , case-insensitive- , cryptohash == 0.11.6.*+ , cryptohash == 0.11.* , directory , either >= 4.3 && < 4.6 , filepath >= 1.3 && < 1.5
src/Airship/Internal/Decision.hs view
@@ -1,49 +1,46 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE ImpredicativeTypes #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-} module Airship.Internal.Decision ( flow , appendRequestPath ) where -import Airship.Internal.Date (parseRfc1123Date, utcTimeToRfc1123)-import Airship.Headers (addResponseHeader)-import Airship.Types ( Response(..)- , ResponseBody(..)- , Webmachine- , etagToByteString- , getResponseBody- , getResponseHeaders- , halt- , pathInfo- , putResponseBody- , request- , requestHeaders- , requestMethod- , requestTime )+import Airship.Headers (addResponseHeader)+import Airship.Internal.Date (parseRfc1123Date,+ utcTimeToRfc1123)+import Airship.Types (Response (..),+ ResponseBody (..),+ Webmachine, etagToByteString,+ getResponseBody,+ getResponseHeaders, halt,+ pathInfo, putResponseBody,+ request, requestHeaders,+ requestMethod, requestTime) -import Airship.Resource(Resource(..), PostResponse(..))-import Airship.Internal.Parsers (parseEtagList)+import Airship.Internal.Parsers (parseEtagList)+import Airship.Resource (PostResponse (..),+ Resource (..)) #if __GLASGOW_HASKELL__ < 710-import Control.Applicative ((<$>))+import Control.Applicative ((<$>)) #endif-import Control.Monad (when)-import Control.Monad.Trans (lift)-import Control.Monad.Trans.State.Strict (StateT(..), evalStateT,- get, modify)-import Control.Monad.Writer.Class (tell)+import Control.Monad (when)+import Control.Monad.Trans (lift)+import Control.Monad.Trans.State.Strict (StateT (..), evalStateT, get,+ modify)+import Control.Monad.Writer.Class (tell) -import Blaze.ByteString.Builder (toByteString)-import Data.Maybe (isJust)-import Data.Text (Text)-import Data.Time.Clock (UTCTime)+import Blaze.ByteString.Builder (toByteString) import Data.ByteString (ByteString, intercalate)+import Data.Maybe (isJust)+import Data.Text (Text)+import Data.Time.Clock (UTCTime) import Network.HTTP.Media-import qualified Network.HTTP.Types as HTTP+import qualified Network.HTTP.Types as HTTP ------------------------------------------------------------------------------ -- HTTP Headers@@ -98,10 +95,9 @@ -- Decision Helpers ------------------------------------------------------------------------------ -negotiateContentTypesAccepted :: Monad m => Resource m -> FlowStateT m ()-negotiateContentTypesAccepted Resource{..} = do+negotiateContentTypesAccepted :: Monad m => [(MediaType, Webmachine m a)] -> FlowStateT m a+negotiateContentTypesAccepted accepted = do req <- lift request- accepted <- lift contentTypesAccepted let reqHeaders = requestHeaders req result = do cType <- lookup HTTP.hContentType reqHeaders@@ -155,7 +151,7 @@ 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+o20, o18, o17, o16, o14 :: Monad m => Flow m p11, p03 :: Monad m => Flow m ------------------------------------------------------------------------------@@ -627,10 +623,10 @@ n11 r@Resource{..} = trace "n11" >> lift processPost >>= flip processPostAction r create :: Monad m => [Text] -> Resource m -> FlowStateT m ()-create ts r = do+create ts Resource{..} = do loc <- lift (appendRequestPath ts) lift (addResponseHeader ("Location", loc))- negotiateContentTypesAccepted r+ lift contentTypesAccepted >>= negotiateContentTypesAccepted processPostAction :: Monad m => PostResponse m -> Flow m processPostAction (PostCreate ts) r = do@@ -639,10 +635,10 @@ processPostAction (PostCreateRedirect ts) r = do create ts r lift $ halt HTTP.status303-processPostAction (PostProcess p) r =- lift p >> p11 r-processPostAction (PostProcessRedirect ts) _r = do- locBs <- lift ts+processPostAction (PostProcess accepted) r = do+ negotiateContentTypesAccepted accepted >> p11 r+processPostAction (PostProcessRedirect accepted) _r = do+ locBs <- negotiateContentTypesAccepted accepted lift $ addResponseHeader ("Location", locBs) lift $ halt HTTP.status303 @@ -696,14 +692,22 @@ req <- lift request if requestMethod req == HTTP.methodPut then o14 r- else o18 r+ else o17 r +o17 r@Resource{..} = do+ trace "o17"+ req <- lift request+ if requestMethod req /= HTTP.methodPatch+ then o18 r+ else lift patchContentTypesAccepted >>= negotiateContentTypesAccepted >> o20 r++ o14 r@Resource{..} = do trace "o14" conflict <- lift isConflict if conflict then lift $ halt HTTP.status409- else negotiateContentTypesAccepted r >> p11 r+ else lift contentTypesAccepted >>= negotiateContentTypesAccepted >> p11 r ------------------------------------------------------------------------------ -- P column@@ -723,4 +727,4 @@ conflict <- lift isConflict if conflict then lift $ halt HTTP.status409- else negotiateContentTypesAccepted r >> p11 r+ else lift contentTypesAccepted >>= negotiateContentTypesAccepted >> p11 r
src/Airship/Internal/Helpers.hs view
@@ -59,7 +59,7 @@ let cType = lookup HTTP.hContentType headers return $ case cType of Nothing -> True- Just t -> isJust $ matchAccept validTypes t+ Just t -> isJust $ matchContent validTypes t -- | Issue an HTTP 302 (Found) response, with `location' as the destination. redirectTemporarily :: Monad m => ByteString -> Webmachine m a
src/Airship/Resource.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ImpredicativeTypes #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Airship.Resource@@ -11,99 +11,106 @@ , defaultResource ) where -import Airship.Types+import Airship.Types -import Data.Text (Text)-import Data.Time.Clock (UTCTime)-import Data.ByteString (ByteString)+import Data.ByteString (ByteString)+import Data.Text (Text)+import Data.Time.Clock (UTCTime) -import Network.HTTP.Types-import Network.HTTP.Media (MediaType)+import Network.HTTP.Media (MediaType)+import Network.HTTP.Types -- | 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.+--+-- For processing the POST, an association list of 'MediaType's and 'Webmachine' actions are required+-- 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, processing will halt with+-- @415 Unsupported Media Type@. data PostResponse m = PostCreate [Text] -- ^ Treat this request as a PUT. | PostCreateRedirect [Text] -- ^ Treat this request as a PUT, then redirect.- | PostProcess (Webmachine m ()) -- ^ Process as a POST, but don't redirect.- | PostProcessRedirect (Webmachine m ByteString) -- ^ Process and redirect.+ | PostProcess [(MediaType, Webmachine m ())] -- ^ Process as a POST, but don't redirect.+ | PostProcessRedirect [(MediaType, Webmachine m ByteString)] -- ^ Process and redirect. data Resource m = Resource { -- | Whether to allow HTTP POSTs to a missing resource. Default: false.- allowMissingPost :: Webmachine 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 :: Webmachine m [Method]+ , 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 'Webmachine' action will be executed and processing will continue.- , contentTypesAccepted :: Webmachine m [(MediaType, Webmachine m ())]+ , 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,+ -- by looking up the 'MediaType' that most closely matches the @Accept@ header. Should there be no match, -- processing will halt with @406 Not Acceptable@.- , contentTypesProvided :: Webmachine m [(MediaType, Webmachine m ResponseBody)]+ , 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 :: Webmachine 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 :: Webmachine m Bool+ , deleteResource :: Webmachine m Bool -- | Returns @413 Request Entity Too Large@ if true. Default: false.- , entityTooLarge :: Webmachine 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 :: Webmachine 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 :: Webmachine 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 :: Webmachine m Bool+ , implemented :: Webmachine m Bool -- | Returns @401 Unauthorized@ if false. Default: true.- , isAuthorized :: Webmachine m Bool+ , isAuthorized :: Webmachine m Bool -- | When processing @PUT@ requests, a @True@ value returned here will halt processing with a @409 Conflict@.- , isConflict :: Webmachine 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 :: Webmachine 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 :: Webmachine 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 :: Webmachine m Bool+ , languageAvailable :: Webmachine m Bool -- | Returns @400 Bad Request@ if true. Default: false.- , malformedRequest :: Webmachine 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 :: Webmachine m (Maybe ByteString)+ , movedPermanently :: Webmachine m (Maybe ByteString) -- | Like 'movedPermanently', except with a @307 Moved Temporarily@ response.- , movedTemporarily :: Webmachine 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 :: Webmachine m Bool+ , multipleChoices :: Webmachine m Bool+ -- | As 'contentTypesAccepted', but checked and executed specifically in the case of a PATCH request.+ , patchContentTypesAccepted :: Webmachine m [(MediaType, Webmachine m ())] -- | When processing a request for which 'resourceExists' returned @False@, returning @True@ here -- allows the 'movedPermanently' and 'movedTemporarily' functions to process the request.- , previouslyExisted :: Webmachine 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 :: Webmachine m (PostResponse 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 :: Webmachine m Bool+ , resourceExists :: Webmachine m Bool -- | Returns @503 Service Unavailable@ if false. Default: true.- , serviceAvailable :: Webmachine m Bool+ , serviceAvailable :: Webmachine m Bool -- | Returns @414 Request URI Too Long@ if true. Default: false.- , uriTooLong :: Webmachine m Bool+ , uriTooLong :: Webmachine m Bool -- | Returns @501 Not Implemented@ if false. Default: true.- , validContentHeaders :: Webmachine m Bool+ , validContentHeaders :: Webmachine m Bool } -- | A helper function that terminates execution with @500 Internal Server Error@.@@ -113,29 +120,30 @@ -- | 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 :: Monad m => Resource m-defaultResource = Resource { allowMissingPost = return False- , allowedMethods = return [methodGet, methodHead]- , contentTypesAccepted = return []- , contentTypesProvided = return []- , deleteCompleted = return False- , deleteResource = return False- , entityTooLarge = return False- , forbidden = return False- , generateETag = return Nothing- , implemented = return True- , isAuthorized = return True- , isConflict = return False- , knownContentType = return True- , lastModified = return Nothing- , languageAvailable = return True- , malformedRequest = return False- , movedPermanently = return Nothing- , movedTemporarily = return Nothing- , multipleChoices = return False- , previouslyExisted = return False- , processPost = return (PostProcess (return ()))- , resourceExists = return True- , serviceAvailable = return True- , uriTooLong = return False- , validContentHeaders = return True+defaultResource = Resource { allowMissingPost = return False+ , allowedMethods = return [methodOptions, methodGet, methodHead]+ , contentTypesAccepted = return []+ , contentTypesProvided = return [("text/html", halt status405)]+ , deleteCompleted = return False+ , deleteResource = return False+ , entityTooLarge = return False+ , forbidden = return False+ , generateETag = return Nothing+ , implemented = return True+ , isAuthorized = return True+ , isConflict = return False+ , knownContentType = return True+ , lastModified = return Nothing+ , languageAvailable = return True+ , malformedRequest = return False+ , movedPermanently = return Nothing+ , movedTemporarily = return Nothing+ , multipleChoices = return False+ , patchContentTypesAccepted = return []+ , previouslyExisted = return False+ , processPost = return (PostProcess [])+ , resourceExists = return True+ , serviceAvailable = return True+ , uriTooLong = return False+ , validContentHeaders = return True }