Skip to content

Commit

Permalink
Correctly check content-types and proceed onto o18 in o17.
Browse files Browse the repository at this point in the history
  • Loading branch information
Patrick Thomson committed Jan 27, 2016
1 parent d84b96e commit 783bfe3
Show file tree
Hide file tree
Showing 2 changed files with 58 additions and 57 deletions.
9 changes: 5 additions & 4 deletions src/Airship/Internal/Decision.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -98,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
Expand Down Expand Up @@ -700,9 +702,8 @@ o17 r@Resource{..} = do
req <- lift request
if requestMethod req /= HTTP.methodPatch
then o18 r
else lift $ do
changed <- processPatch
halt (if changed then HTTP.status200 else HTTP.status304)
else negotiateContentTypesAccepted r >> o18 r


o14 r@Resource{..} = do
trace "o14"
Expand Down
106 changes: 53 additions & 53 deletions src/Airship/Resource.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -31,81 +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)
-- | As with 'processPost', but called on PATCH requests.
, processPatch :: Webmachine m Bool
, 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@.
Expand All @@ -115,30 +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 ()))
, processPatch = return False
, 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
}

0 comments on commit 783bfe3

Please sign in to comment.