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.

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
@@ -155,7 +152,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 +693,16 @@ 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 lift $ do
+         changed <- processPatch
+         halt (if changed then HTTP.status202 else HTTP.status304)
 
 o14 r@Resource{..} = do
     trace "o14"

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
                -- | 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)
+               -- | As with 'processPost', but called on PATCH requests.
+             , processPatch         :: Webmachine m Bool
                -- | 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@.