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