Resource.hs

{-# 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
                           }