Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Add PATCH-processing functionality to Resource. #91

Merged
merged 1 commit into from
Feb 2, 2016
Merged

Add PATCH-processing functionality to Resource. #91

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion airship.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
81 changes: 44 additions & 37 deletions src/Airship/Internal/Decision.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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

------------------------------------------------------------------------------
Expand Down Expand Up @@ -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"
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

We need an updated graph now :)

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

@charleso Sure thing; anyone have an OmniGraffle doc for it? 😄

Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Curious that web machine doesn't appear to support PATCH right now.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

@tmcgilchrist Apparently webmachine is implemented based strictly on RFC 2616, which does not discuss HTTP PATCH

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Might be nice at some point to tweak for-GET and have the (slightly augmented) airship flow graph.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Hmm… though for-GET is gorgeous, it departs pretty significantly from the Airship graph, AFAICT.

req <- lift request
if requestMethod req /= HTTP.methodPatch
then o18 r
else negotiateContentTypesAccepted r >> o20 r


o14 r@Resource{..} = do
trace "o14"
Expand Down
123 changes: 63 additions & 60 deletions src/Airship/Resource.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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
Expand All @@ -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.
Expand All @@ -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@.
Expand All @@ -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
}