Permalink
Fetching contributors…
Cannot retrieve contributors at this time
155 lines (146 sloc) 10.4 KB
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Airship.Resource
( Resource(..)
, PostResponse(..)
, serverError
, defaultResource
) where
import Airship.Types
import Data.ByteString (ByteString)
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (mappend, mempty)
#endif
import Data.Text (Text)
import Data.Time.Clock (UTCTime)
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 [(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
-- | 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]
-- | 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 ())]
-- | 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)]
-- | 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
-- | When processing a @DELETE@ request, a @True@ value allows processing to continue.
-- Returns @500 Forbidden@ if False. Default: false.
, deleteResource :: Webmachine m Bool
-- | Returns @413 Request Entity Too Large@ if true. Default: false.
, 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
-- | 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)
-- | 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
-- | Returns @401 Unauthorized@ if false. Default: true.
, isAuthorized :: Webmachine m Bool
-- | When processing @PUT@ requests, a @True@ value returned here will halt processing with a @409 Conflict@.
, 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
-- | 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)
-- | 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
-- | Returns @400 Bad Request@ if true. Default: false.
, 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)
-- | Like 'movedPermanently', except with a @307 Moved Temporarily@ response.
, 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
-- | 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
-- | 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)
-- | 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
-- | Returns @503 Service Unavailable@ if false. Default: true.
, serviceAvailable :: Webmachine m Bool
-- | Returns @414 Request URI Too Long@ if true. Default: false.
, uriTooLong :: Webmachine m Bool
-- | Returns @501 Not Implemented@ if false. Default: true.
, validContentHeaders :: Webmachine m Bool
, errorResponses :: ErrorResponses m
}
-- | A helper function that terminates execution with @500 Internal Server Error@.
serverError :: Monad m => Webmachine m a
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 [("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
, errorResponses = mempty
}