{-# 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.
               Resource m -> 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.
             , Resource m -> 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.
             , Resource m -> 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@.
             , Resource m -> 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.
             , Resource m -> 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.
             , Resource m -> Webmachine m Bool
deleteResource            :: Webmachine m Bool
               -- | Returns @413 Request Entity Too Large@ if true. Default: false.
             , Resource m -> 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.
             , Resource m -> 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.
             , Resource m -> 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.
             , Resource m -> Webmachine m Bool
implemented               :: Webmachine m Bool
               -- | Returns @401 Unauthorized@ if false. Default: true.
             , Resource m -> Webmachine m Bool
isAuthorized              :: Webmachine m Bool
               -- | When processing @PUT@ requests, a @True@ value returned here will halt processing with a @409 Conflict@.
             , Resource m -> 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.
             , Resource m -> 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.
             , Resource m -> 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@.
             , Resource m -> Webmachine m Bool
languageAvailable         :: Webmachine m Bool
               -- | Returns @400 Bad Request@ if true. Default: false.
             , Resource m -> 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.
             , Resource m -> Webmachine m (Maybe Method)
movedPermanently          :: Webmachine m (Maybe ByteString)
               -- | Like 'movedPermanently', except with a @307 Moved Temporarily@ response.
             , Resource m -> Webmachine m (Maybe Method)
movedTemporarily          :: Webmachine m (Maybe ByteString)
               -- | When handling a @PUT@ request, returning @True@ here halts processing with @300 Multiple Choices@. Default: False.
             , Resource m -> Webmachine m Bool
multipleChoices           :: Webmachine m Bool
               -- | As 'contentTypesAccepted', but checked and executed specifically in the case of a PATCH request.
             , Resource m -> Webmachine m [(MediaType, Webmachine m ())]
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.
             , Resource m -> 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.
             , Resource m -> 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).
             , Resource m -> Webmachine m Bool
resourceExists            :: Webmachine m Bool
               -- | Returns @503 Service Unavailable@ if false. Default: true.
             , Resource m -> Webmachine m Bool
serviceAvailable          :: Webmachine m Bool
               -- | Returns @414 Request URI Too Long@ if true. Default: false.
             , Resource m -> Webmachine m Bool
uriTooLong                :: Webmachine m Bool
               -- | Returns @501 Not Implemented@ if false. Default: true.
             , Resource m -> Webmachine m Bool
validContentHeaders       :: Webmachine m Bool
             , Resource m
-> Monad m => Map Status [(MediaType, Webmachine m ResponseBody)]
errorResponses            :: ErrorResponses m
             }


-- | A helper function that terminates execution with @500 Internal Server Error@.
serverError :: Monad m => Webmachine m a
serverError :: Webmachine m a
serverError = Response -> Webmachine m a
forall (m :: * -> *) a. Monad m => Response -> Webmachine m a
finishWith (Status -> ResponseHeaders -> ResponseBody -> Response
Response Status
status500 [] ResponseBody
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 m
defaultResource = Resource :: forall (m :: * -> *).
Webmachine m Bool
-> Webmachine m [Method]
-> Webmachine m [(MediaType, Webmachine m ())]
-> Webmachine m [(MediaType, Webmachine m ResponseBody)]
-> Webmachine m Bool
-> Webmachine m Bool
-> Webmachine m Bool
-> Webmachine m Bool
-> Webmachine m (Maybe ETag)
-> Webmachine m Bool
-> Webmachine m Bool
-> Webmachine m Bool
-> Webmachine m Bool
-> Webmachine m (Maybe UTCTime)
-> Webmachine m Bool
-> Webmachine m Bool
-> Webmachine m (Maybe Method)
-> Webmachine m (Maybe Method)
-> Webmachine m Bool
-> Webmachine m [(MediaType, Webmachine m ())]
-> Webmachine m Bool
-> Webmachine m (PostResponse m)
-> Webmachine m Bool
-> Webmachine m Bool
-> Webmachine m Bool
-> Webmachine m Bool
-> ErrorResponses m
-> Resource m
Resource { allowMissingPost :: Webmachine m Bool
allowMissingPost          = Bool -> Webmachine m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                           , allowedMethods :: Webmachine m [Method]
allowedMethods            = [Method] -> Webmachine m [Method]
forall (m :: * -> *) a. Monad m => a -> m a
return [Method
methodOptions, Method
methodGet, Method
methodHead]
                           , contentTypesAccepted :: Webmachine m [(MediaType, Webmachine m ())]
contentTypesAccepted      = [(MediaType, Webmachine m ())]
-> Webmachine m [(MediaType, Webmachine m ())]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                           , contentTypesProvided :: Webmachine m [(MediaType, Webmachine m ResponseBody)]
contentTypesProvided      = [(MediaType, Webmachine m ResponseBody)]
-> Webmachine m [(MediaType, Webmachine m ResponseBody)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(MediaType
"text/html", Status -> Webmachine m ResponseBody
forall (m :: * -> *) a. Monad m => Status -> Webmachine m a
halt Status
status405)]
                           , deleteCompleted :: Webmachine m Bool
deleteCompleted           = Bool -> Webmachine m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                           , deleteResource :: Webmachine m Bool
deleteResource            = Bool -> Webmachine m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                           , entityTooLarge :: Webmachine m Bool
entityTooLarge            = Bool -> Webmachine m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                           , forbidden :: Webmachine m Bool
forbidden                 = Bool -> Webmachine m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                           , generateETag :: Webmachine m (Maybe ETag)
generateETag              = Maybe ETag -> Webmachine m (Maybe ETag)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ETag
forall a. Maybe a
Nothing
                           , implemented :: Webmachine m Bool
implemented               = Bool -> Webmachine m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                           , isAuthorized :: Webmachine m Bool
isAuthorized              = Bool -> Webmachine m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                           , isConflict :: Webmachine m Bool
isConflict                = Bool -> Webmachine m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                           , knownContentType :: Webmachine m Bool
knownContentType          = Bool -> Webmachine m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                           , lastModified :: Webmachine m (Maybe UTCTime)
lastModified              = Maybe UTCTime -> Webmachine m (Maybe UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UTCTime
forall a. Maybe a
Nothing
                           , languageAvailable :: Webmachine m Bool
languageAvailable         = Bool -> Webmachine m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                           , malformedRequest :: Webmachine m Bool
malformedRequest          = Bool -> Webmachine m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                           , movedPermanently :: Webmachine m (Maybe Method)
movedPermanently          = Maybe Method -> Webmachine m (Maybe Method)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Method
forall a. Maybe a
Nothing
                           , movedTemporarily :: Webmachine m (Maybe Method)
movedTemporarily          = Maybe Method -> Webmachine m (Maybe Method)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Method
forall a. Maybe a
Nothing
                           , multipleChoices :: Webmachine m Bool
multipleChoices           = Bool -> Webmachine m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                           , patchContentTypesAccepted :: Webmachine m [(MediaType, Webmachine m ())]
patchContentTypesAccepted = [(MediaType, Webmachine m ())]
-> Webmachine m [(MediaType, Webmachine m ())]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                           , previouslyExisted :: Webmachine m Bool
previouslyExisted         = Bool -> Webmachine m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                           , processPost :: Webmachine m (PostResponse m)
processPost               = PostResponse m -> Webmachine m (PostResponse m)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(MediaType, Webmachine m ())] -> PostResponse m
forall (m :: * -> *).
[(MediaType, Webmachine m ())] -> PostResponse m
PostProcess [])
                           , resourceExists :: Webmachine m Bool
resourceExists            = Bool -> Webmachine m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                           , serviceAvailable :: Webmachine m Bool
serviceAvailable          = Bool -> Webmachine m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                           , uriTooLong :: Webmachine m Bool
uriTooLong                = Bool -> Webmachine m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                           , validContentHeaders :: Webmachine m Bool
validContentHeaders       = Bool -> Webmachine m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                           , errorResponses :: ErrorResponses m
errorResponses            = ErrorResponses m
forall a. Monoid a => a
mempty
                           }