module Web.Scotty.Rest
(
RestT
, rest
, Authorized(..)
, DeleteResult(..)
, ETag(..)
, Moved(..)
, ProcessingResult(..)
, Representation(..)
, EndpointConfig(..)
, defaultConfig
, RestException(..)
, MediaType
, StdMethod(..)
, UTCTime
, toHttpDateHeader
, requestMethod
) where
import BasePrelude hiding (Handler)
import Web.Scotty.Rest.Types
import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
import Data.Convertible (convert)
import Data.String.Conversions (cs)
import qualified Data.Text.Lazy as TL
import Data.Time.Calendar (fromGregorian)
import Data.Time.Clock (UTCTime (..), secondsToDiffTime)
import Network.HTTP.Date
import Network.HTTP.Media (mapAccept, mapContent, matchAccept, matches,
parseAccept, renderHeader)
import Network.HTTP.Types (parseMethod)
import Network.HTTP.Types.Status
import qualified Network.Wai as Wai
import Web.Scotty.Trans
type Config m = EndpointConfig (RestT m)
rest :: (MonadIO m) => RoutePattern -> Config m -> ScottyT RestException m ()
rest route config = matchAny route (restHandlerStart config `rescue` handleExcept)
defaultConfig :: (Monad m) => Config m
defaultConfig = EndpointConfig {
allowedMethods = return [GET, HEAD, OPTIONS]
, resourceExists = return True
, previouslyExisted = return False
, isConflict = return False
, contentTypesAccepted = return []
, contentTypesProvided = return []
, languagesProvided = return Nothing
, charsetsProvided = return Nothing
, deleteResource = return NotDeleted
, optionsHandler = return Nothing
, generateEtag = return Nothing
, expires = return Nothing
, lastModified = return Nothing
, malformedRequest = return False
, isAuthorized = return Authorized
, forbidden = return False
, serviceAvailable = return True
, allowMissingPost = return True
, multipleChoices = return UniqueRepresentation
, resourceMoved = return NotMoved
, variances = return []
}
preferred :: (Monad m) => Config m -> RestT m (MediaType, RestT m ())
preferred config = do
accept <- (cs . fromMaybe "*/*") <$> header "accept"
provided <- contentTypesProvided config
contentType <- maybe (raise NotAcceptable406) return (matchAccept (map fst provided) accept)
bestHandler <- maybe (raise NotAcceptable406) return (mapAccept provided accept)
return (contentType, bestHandler)
language :: (Monad m) => Config m -> RestT m (Maybe Language)
language config = findPreferred config "accept-language" parse languagesProvided match
where parse = parseAccept . cs
match = flip matches
charset :: (Monad m) => Config m -> RestT m (Maybe TL.Text)
charset config = findPreferred config "accept-charset" parse charsetsProvided match
where parse = Just
match a b = TL.toCaseFold a == TL.toCaseFold b
findPreferred :: (Monad m) => Config m
-> TL.Text
-> (TL.Text -> Maybe a)
-> (Config m -> RestT m (Maybe [a]))
-> (a -> a -> Bool)
-> RestT m (Maybe a)
findPreferred config headerName parse provided match = do
headerAndConfig <- runMaybeT $ do
accept <- MaybeT (header headerName)
provide <- MaybeT (provided config)
return (accept, provide)
case headerAndConfig of
Nothing -> return Nothing
Just (a, p) -> do
best <- runMaybeT $ do
requested <- MaybeT ((return . parse) a)
MaybeT ((return . head' . filter (match requested)) p)
when (isNothing best) (raise NotAcceptable406)
return best
where head' [] = Nothing
head' (x:_) = Just x
checkRequestMethod :: (Monad m) => RestT m ()
checkRequestMethod = do
method <- requestMethod
unless (method `elem` [GET, HEAD, POST, PUT, PATCH, DELETE, OPTIONS]) (raise NotImplemented501)
restHandlerStart :: (Monad m) => Config m -> RestT m ()
restHandlerStart config = do
available <- serviceAvailable config
unless available (raise ServiceUnavailable503)
checkRequestMethod
method <- requestMethod
allowed <- allowedMethods config
when (method `notElem` allowed) $ do
setAllowHeader config
raise MethodNotAllowed405
isMalformed <- malformedRequest config
when isMalformed (raise BadRequest400)
isAuthorized config >>= \case
Authorized -> return ()
(NotAuthorized challenge) -> do setHeader "WWW-Authenticate" challenge
raise Unauthorized401
isForbidden <- forbidden config
when isForbidden (raise Forbidden403)
if method == OPTIONS
then handleOptions config
else contentNegotiationStart config
setAllowHeader :: (Monad m) => Config m -> RestT m ()
setAllowHeader config= do
allowed <- allowedMethods config
setHeader "Allow" . TL.intercalate ", " . map (cs . show) $ allowed
handleOptions :: (Monad m) => Config m -> RestT m ()
handleOptions config = optionsHandler config >>= \case
Nothing -> setAllowHeader config
(Just (contentType, handler)) -> handler >> setContentTypeHeader contentType
contentNegotiationStart :: (Monad m) => Config m -> RestT m ()
contentNegotiationStart = contentNegotiationAccept
contentNegotiationAccept :: (Monad m) => Config m -> RestT m ()
contentNegotiationAccept config = do
accept <- header "accept"
when (isJust accept) $ void (preferred config)
contentNegotiationAcceptLanguage config
contentNegotiationAcceptLanguage :: (Monad m) => Config m -> RestT m ()
contentNegotiationAcceptLanguage config = do
acceptLanguage <- header "accept-language"
when (isJust acceptLanguage) $ void (language config)
contentNegotiationAcceptCharSet config
contentNegotiationAcceptCharSet :: (Monad m) => Config m -> RestT m ()
contentNegotiationAcceptCharSet config = do
acceptCharset <- header "accept-charset"
when (isJust acceptCharset) $ void (charset config)
contentNegotiationVariances config
contentNegotiationVariances :: (Monad m) => Config m -> RestT m ()
contentNegotiationVariances config = do
ctp <- contentTypesProvided config
lp <- languagesProvided config
cp <- charsetsProvided config
varyHeader <- variances config
let varyHeader' = if length ctp > 1 then "Accept":varyHeader else varyHeader
let varyHeader'' = if isJust lp then "Accept-Language":varyHeader' else varyHeader'
let varyHeader''' = if isJust cp then "Accept-Charset":varyHeader'' else varyHeader''
unless (null varyHeader''') $ setHeader "Vary" . TL.intercalate ", " $ varyHeader'''
checkResourceExists config
checkResourceExists :: (Monad m) => Config m -> RestT m ()
checkResourceExists config = do
exists <- resourceExists config
method <- requestMethod
if | method `elem` [GET, HEAD] -> if exists
then handleGetHeadExisting config
else handleGetHeadNonExisting config
| method `elem` [PUT, POST, PATCH] -> if exists
then handlePutPostPatchExisting config
else handlePutPostPatchNonExisting config
| method `elem` [DELETE] -> if exists
then handleDeleteExisting config
else handleDeleteNonExisting config
handleGetHeadExisting :: (Monad m) => Config m -> RestT m ()
handleGetHeadExisting config = do
cond config
addCacheHeaders config
method <- requestMethod
(contentType, handler) <- preferred config
multipleChoices config >>= \case
MultipleRepresentations t' c' -> do writeContent t' c'
status multipleChoices300
MultipleWithPreferred t' c' u -> do writeContent t' c'
setHeader "Location" u
status multipleChoices300
UniqueRepresentation -> do when (method == GET) handler
setContentTypeHeader contentType
status ok200
handleGetHeadNonExisting :: (Monad m) => Config m -> RestT m ()
handleGetHeadNonExisting = handleNonExisting
checkMoved :: (Monad m) => Config m -> RestT m ()
checkMoved config = resourceMoved config >>= \case
NotMoved -> return ()
(MovedPermanently url) -> setHeader "Location" url >> raise MovedPermanently301
(MovedTemporarily url) -> setHeader "Location" url >> raise MovedTemporarily307
handlePutPostPatchNonExisting :: (Monad m) => Config m -> RestT m ()
handlePutPostPatchNonExisting config = do
hasIfMatchHeader <- isJust <$> header "if-match"
when hasIfMatchHeader (raise PreconditionFailed412)
ifMethodIn [POST, PATCH]
(ppppreviouslyExisted config)
(pppmethodIsPut config)
ppppreviouslyExisted :: (Monad m) => Config m -> RestT m ()
ppppreviouslyExisted config = do
existed <- previouslyExisted config
if existed
then pppmovedPermanentlyOrTemporarily config
else pppmethodIsPost config
pppmovedPermanentlyOrTemporarily :: (Monad m) => Config m -> RestT m ()
pppmovedPermanentlyOrTemporarily config = do
checkMoved config
ifMethodIn [POST]
(allowsMissingPost config (acceptResource config) (raise Gone410))
(pppmethodIsPut config)
pppmethodIsPost :: (Monad m) => Config m -> RestT m ()
pppmethodIsPost config =
ifMethodIn [POST]
(allowsMissingPost config (pppmethodIsPut config) (raise NotFound404))
(raise NotFound404)
pppmethodIsPut :: (Monad m) => Config m -> RestT m ()
pppmethodIsPut config = do
method <- requestMethod
when (method == PUT || method == PATCH) $ do
conflict <- isConflict config
when conflict (raise Conflict409)
acceptResource config
handlePutPostPatchExisting :: (Monad m) => Config m -> RestT m ()
handlePutPostPatchExisting config = do
cond config
pppmethodIsPut config
acceptResource :: (Monad m) => Config m -> RestT m ()
acceptResource config = do
contentTypeHeader <- header "Content-Type"
contentType <- maybe (raise UnsupportedMediaType415) (return . cs) contentTypeHeader
handlers <- contentTypesAccepted config
result <- fromMaybe (raise UnsupportedMediaType415) (mapContent handlers contentType)
exists <- resourceExists config
case (result, exists) of
(Failed, _) -> status badRequest400
(Succeeded, True) -> status noContent204
(Succeeded, False) -> status created201
(SucceededWithContent t c, True) -> resourceWithContent config t c
(SucceededWithContent t c, False) -> writeContent t c >> status created201
(SucceededWithLocation url, True) -> locationAndResponseCode url noContent204
(SucceededWithLocation url, False) -> locationAndResponseCode url created201
(Redirect url, _) -> locationAndResponseCode url seeOther303
where locationAndResponseCode url response = setHeader "Location" url >> status response
writeContent :: (Monad m) => MediaType -> TL.Text -> RestT m ()
writeContent t c = do
method <- requestMethod
setContentTypeHeader t
when (method /= HEAD) ((raw . cs) c)
resourceWithContent :: (Monad m) => Config m -> MediaType -> TL.Text -> RestT m ()
resourceWithContent config t c = multipleChoices config >>= \case
UniqueRepresentation -> do setContentTypeHeader t
(raw . cs) c
status ok200
MultipleRepresentations t' c' -> do writeContent t' c'
status multipleChoices300
MultipleWithPreferred t' c' u -> do writeContent t' c'
setHeader "Location" u
status multipleChoices300
handleDeleteExisting :: (Monad m) => Config m -> RestT m ()
handleDeleteExisting config = do
cond config
result <- deleteResource config
case result of
DeleteEnacted -> status accepted202
Deleted -> status noContent204
(DeletedWithResponse t c) -> resourceWithContent config t c
NotDeleted -> raise (InternalServerError "Deleting existing resource failed")
handleDeleteNonExisting :: (Monad m) => Config m -> RestT m ()
handleDeleteNonExisting = handleNonExisting
cond :: (Monad m) => Config m -> RestT m ()
cond = condIfMatch
condIfMatch :: (Monad m) => Config m -> RestT m ()
condIfMatch config = header "if-match" >>= \case
Nothing -> condIfUnmodifiedSince config
Just hdr -> ifEtagMatches config hdr
(condIfUnmodifiedSince config)
(addEtagHeader config >> raise PreconditionFailed412)
condIfUnmodifiedSince :: (Monad m) => Config m -> RestT m ()
condIfUnmodifiedSince config = modifiedSinceHeaderDate config "if-unmodified-since" >>= \case
Nothing -> condIfNoneMatch config
Just False -> condIfNoneMatch config
Just True -> addLastModifiedHeader config >> raise PreconditionFailed412
condIfNoneMatch :: (Monad m) => Config m -> RestT m ()
condIfNoneMatch config = header "if-none-match" >>= \case
Nothing -> condIfModifiedSince config
Just hdr -> ifEtagMatches config hdr
match
(condIfModifiedSince config)
where match = ifMethodIn [GET, HEAD]
(notModified config)
(addEtagHeader config >> raise PreconditionFailed412)
condIfModifiedSince :: (Monad m) => Config m -> RestT m ()
condIfModifiedSince config = modifiedSinceHeaderDate config "if-modified-since" >>= \case
Nothing -> return ()
Just False -> notModified config
Just True -> return ()
addCacheHeaders :: (Monad m) => Config m -> RestT m ()
addCacheHeaders config = do
addEtagHeader config
addLastModifiedHeader config
addExpiresHeader config
notModified :: (Monad m) => Config m -> RestT m ()
notModified config = do
addCacheHeaders config
raise NotModified304
addEtagHeader :: (Monad m) => Config m -> RestT m ()
addEtagHeader config = generateEtag config >>= \case
Nothing -> return ()
Just (Weak t) -> setHeader "Etag" ("W/\"" <> t <> "\"")
Just (Strong t) -> setHeader "Etag" ("\"" <> t <> "\"")
addLastModifiedHeader :: (Monad m) => Config m -> RestT m ()
addLastModifiedHeader config = lastModified config >>= \case
Nothing -> return ()
Just t -> setHeader "Last-Modified" (toHttpDateHeader t)
addExpiresHeader :: (Monad m) => Config m -> RestT m ()
addExpiresHeader config = expires config >>= \case
Nothing -> return ()
Just t -> setHeader "Expires" (toHttpDateHeader t)
modifiedSinceHeaderDate :: (Monad m) => Config m -> TL.Text -> RestT m (Maybe Bool)
modifiedSinceHeaderDate config hdr = runMaybeT $ do
modDate <- MaybeT (lastModified config)
headerText <- MaybeT (header hdr)
headerDate <- MaybeT (return (parseHeaderDate headerText))
return (modDate > headerDate)
handleNonExisting :: (Monad m) => Config m -> RestT m ()
handleNonExisting config = do
hasIfMatchHeader <- isJust <$> header "if-match"
when hasIfMatchHeader (raise PreconditionFailed412)
existed <- previouslyExisted config
unless existed (raise NotFound404)
checkMoved config
raise Gone410
setContentTypeHeader :: (Monad m) => MediaType -> RestT m ()
setContentTypeHeader = setHeader "Content-Type" . cs . renderHeader
ifMethodIn :: (Monad m) => [StdMethod] -> RestT m () -> RestT m () -> RestT m ()
ifMethodIn ms onTrue onFalse = do
method <- requestMethod
if method `elem` ms
then onTrue
else onFalse
allowsMissingPost :: (Monad m) => Config m -> RestT m () -> RestT m () -> RestT m ()
allowsMissingPost config onTrue onFalse = do
allowed <- allowMissingPost config
if allowed
then onTrue
else onFalse
ifEtagMatches :: (Monad m) => Config m -> TL.Text -> RestT m () -> RestT m () -> RestT m ()
ifEtagMatches _ "*" onTrue _ = onTrue
ifEtagMatches config given onTrue onFalse = do
tag <- generateEtag config
case tag of
Nothing -> onFalse
Just e -> if eTagMatch e given
then onTrue
else onFalse
where eTagMatch :: ETag -> TL.Text -> Bool
eTagMatch t g = (any (equalTo t) . map TL.strip . TL.splitOn ",") g
equalTo (Strong t) g = ("\"" <> t <> "\"") == g
equalTo (Weak t) g = ("\"" <> t <> "\"") == g
parseHeaderDate :: TL.Text -> Maybe UTCTime
parseHeaderDate hdr = do
headerDate <- (parseHTTPDate . cs) hdr
let year = (fromIntegral . hdYear) headerDate
mon = hdMonth headerDate
day = hdDay headerDate
h = hdHour headerDate
m = hdMinute headerDate
s = hdSecond headerDate
date = fromGregorian year mon day
time = secondsToDiffTime . fromIntegral $ h*60*60 + m*60 + s
return $ UTCTime date time
toHttpDateHeader :: UTCTime -> TL.Text
toHttpDateHeader = cs . formatHTTPDate . epochTimeToHTTPDate . convert
requestMethod :: (Monad m) => RestT m StdMethod
requestMethod = do
req <- request
case (parseMethod . Wai.requestMethod) req of
Right method -> return method
Left method -> raise (InternalServerError ("Parsing method " <> cs method <> " failed"))
handleExcept :: (Monad m) => RestException -> RestT m ()
handleExcept MovedPermanently301 = status movedPermanently301
handleExcept NotModified304 = status notModified304
handleExcept MovedTemporarily307 = status temporaryRedirect307
handleExcept BadRequest400 = status badRequest400
handleExcept Unauthorized401 = status unauthorized401
handleExcept Forbidden403 = status forbidden403
handleExcept NotFound404 = status notFound404
handleExcept MethodNotAllowed405 = status methodNotAllowed405
handleExcept NotAcceptable406 = status notAcceptable406
handleExcept Conflict409 = status conflict409
handleExcept UnsupportedMediaType415 = status unsupportedMediaType415
handleExcept Gone410 = status gone410
handleExcept PreconditionFailed412 = status preconditionFailed412
handleExcept ServiceUnavailable503 = status serviceUnavailable503
handleExcept NotImplemented501 = status notImplemented501
handleExcept (InternalServerError s) = text s >> status internalServerError500