From 7157703c582c63e97a9b3c396cc6986817c8fd0c Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 26 Jan 2016 19:06:45 -0500 Subject: [PATCH] Add PATCH-processing functionality to Resource. This extends the decision tree with actions to take in case of a PATCH request. If one is encountered, the processPatch member is invoked: if its operation effected no change, it returns a 304 Not Modified; if it did, return a 202 Accepted. Also updates to 0.4.4.0. --- airship.cabal | 2 +- src/Airship/Internal/Decision.hs | 81 ++++++++++---------- src/Airship/Resource.hs | 123 ++++++++++++++++--------------- 3 files changed, 108 insertions(+), 98 deletions(-) diff --git a/airship.cabal b/airship.cabal index 616b09a..46b0ab2 100644 --- a/airship.cabal +++ b/airship.cabal @@ -3,7 +3,7 @@ synopsis: A Webmachine-inspired HTTP library 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.4.4.0 license: MIT license-file: LICENSE author: Reid Draper and Patrick Thomson diff --git a/src/Airship/Internal/Decision.hs b/src/Airship/Internal/Decision.hs index b2e0665..927f8a6 100644 --- 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.Resource(Resource(..), PostResponse(..)) -import Airship.Internal.Parsers (parseEtagList) +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.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 Blaze.ByteString.Builder (toByteString) -import Data.Maybe (isJust) -import Data.Text (Text) -import Data.Time.Clock (UTCTime) +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.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 @@ -101,7 +98,9 @@ newtype IfNoneMatch = IfNoneMatch ByteString negotiateContentTypesAccepted :: Monad m => Resource m -> FlowStateT m () negotiateContentTypesAccepted Resource{..} = do req <- lift request - accepted <- lift contentTypesAccepted + accepted <- lift $ if requestMethod req == HTTP.methodPatch + then patchContentTypesAccepted + else contentTypesAccepted let reqHeaders = requestHeaders req result = do cType <- lookup HTTP.hContentType reqHeaders @@ -155,7 +154,7 @@ 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 +o20, o18, o17, o16, o14 :: Monad m => Flow m p11, p03 :: Monad m => Flow m ------------------------------------------------------------------------------ @@ -696,7 +695,15 @@ o16 r = do 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 negotiateContentTypesAccepted r >> o20 r + o14 r@Resource{..} = do trace "o14" diff --git a/src/Airship/Resource.hs b/src/Airship/Resource.hs index 3314d8d..910fe9b 100644 --- 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,14 +11,14 @@ module Airship.Resource , 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. @@ -31,79 +31,81 @@ data PostResponse m 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 @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 +115,30 @@ 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 :: Monad m => Resource m -defaultResource = Resource { allowMissingPost = return False - , allowedMethods = return [methodOptions, 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 [] + , 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 (return ())) + , resourceExists = return True + , serviceAvailable = return True + , uriTooLong = return False + , validContentHeaders = return True }