diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Erlend Hamberg + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Erlend Hamberg nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/Database.hs b/examples/Database.hs new file mode 100644 --- /dev/null +++ b/examples/Database.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Database where + +import Control.Exception (SomeException, try) +import Control.Monad.State +import Data.Aeson +import Data.Foldable +import Data.Text.Lazy hiding (map) +import Database.SQLite.Simple hiding (fold) +import GHC.Generics +import Network.Wai.Middleware.RequestLogger +import Web.Scotty.Rest +import Web.Scotty.Trans hiding (get, put) + + +data Message = Message { + message :: Text +} deriving Generic + +instance FromJSON Message + +app :: IO () +app = scottyT 3000 (`evalStateT` Nothing) $ do + middleware logStdoutDev + rest "/messages" defaultConfig { allowedMethods = allowed + , serviceAvailable = available + , contentTypesProvided = provided + , contentTypesAccepted = accepted + } + where + available = do + -- Try to open the database, if we fail, the service is not available, so + -- we return False. + connection <- liftIO (try (open "test.db") :: IO (Either SomeException Connection)) + case connection of + Left ex -> (html . pack . show) ex >> return False + Right conn -> do + liftIO $ execute_ conn "CREATE TABLE IF NOT EXISTS messages (message varchar)" + lift (put (Just conn)) -- store the database connection handle in the state + return True + allowed = return [GET, HEAD, POST, OPTIONS] + provided = return [ + ("text/html", do + Just conn <- lift get + messages <- liftIO $ query_ conn "SELECT message FROM messages LIMIT 10" + text $ fold $ map (\(Only m) -> pack m `snoc` '\n') messages + ), + ("application/json", do + Just conn <- lift get + messages <- liftIO $ query_ conn "SELECT message FROM messages LIMIT 10" + text $ fold $ map (\(Only m) -> pack m `snoc` '\n') messages + ) + ] + accepted = return [ + ("application/json", do + Just conn <- lift get + Message msg <- jsonData + liftIO $ execute conn "INSERT INTO messages(message) VALUES (?)" (Only msg) + return Succeeded + ) + ] + +main :: IO () +main = app diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs new file mode 100644 --- /dev/null +++ b/examples/HelloWorld.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HelloWorld where + +import Network.Wai.Middleware.RequestLogger +import Web.Scotty.Rest +import Web.Scotty.Trans + +main :: IO () +main = scottyT 3000 id $ do + middleware logStdoutDev + rest "/" defaultConfig { + contentTypesProvided = return [("text/html",html "Hello, World!")] + } diff --git a/examples/Parameters.hs b/examples/Parameters.hs new file mode 100644 --- /dev/null +++ b/examples/Parameters.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Parameters where + +import Data.Text.Lazy +import Network.Wai.Middleware.RequestLogger +import Web.Scotty.Rest +import Web.Scotty.Trans + +main :: IO () +main = scottyT 3000 id $ do + middleware logStdoutDev + rest "/:name" defaultConfig { + contentTypesProvided = return [("text/html",param "name" >>= html . append "Hello, ")] + } diff --git a/scotty-rest.cabal b/scotty-rest.cabal new file mode 100644 --- /dev/null +++ b/scotty-rest.cabal @@ -0,0 +1,67 @@ +name: scotty-rest +version: 0.1.0.0 +synopsis: Webmachine-style REST library for scotty +homepage: http://github.com/ehamberg/scotty-rest +license: BSD3 +license-file: LICENSE +author: Erlend Hamberg +maintainer: erlend@hamberg.no +copyright: 2015, Erlend Hamberg +category: Web +build-type: Simple +cabal-version: >=1.10 +description: + Webmachine-like REST library for Scotty. + +extra-source-files: + examples/HelloWorld.hs + examples/Parameters.hs + examples/Database.hs + +library + exposed-modules: Web.Scotty.Rest + other-modules: Web.Scotty.Rest.Types + default-language: Haskell2010 + hs-source-dirs: src + + build-depends: base >= 4.7 && < 5 + , base-prelude + , bytestring >= 0.10 && < 0.11 + , convertible >= 1.1 && < 1.2 + , data-default-class >= 0.0.1 && < 0.1 + , http-date >= 0.0.1 && < 0.1 + , http-media >= 0.6 && < 0.7 + , http-types >= 0.8 && < 0.9 + , mtl >= 2.1 && < 2.3 + , scotty >= 0.10 && < 0.11 + , string-conversions >= 0.4 && < 0.5 + , text >= 1.2 && < 1.3 + , time >= 1.4 && < 1.6 + , transformers >= 0.3 && < 0.5 + , wai >= 3.0 && < 3.1 + , wai-extra >= 3.0 && < 3.1 + default-language: Haskell2010 + GHC-options: -Wall + +test-suite spec + main-is: Spec.hs + type: exitcode-stdio-1.0 + other-modules: Web.ScottyRestSpec + default-language: Haskell2010 + hs-source-dirs: test + build-depends: base + , bytestring + , hspec + , hspec-wai >= 0.6 + , mtl + , QuickCheck + , scotty + , scotty-rest + , string-conversions + , text + , wai + GHC-options: -Wall -threaded -fno-warn-orphans + +source-repository head + type: git + location: git://github.com/ehamberg/scotty-rest.git diff --git a/src/Web/Scotty/Rest.hs b/src/Web/Scotty/Rest.hs new file mode 100644 --- /dev/null +++ b/src/Web/Scotty/Rest.hs @@ -0,0 +1,524 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Web.Scotty.Rest + ( + -- * REST handler to Scotty + rest + -- * Callback result types + , Authorized(..) + , DeleteResult(..) + , ETag(..) + , Moved(..) + , ProcessingResult(..) + , Representation(..) + -- * Config + , RestConfig(..) + , defaultConfig + -- * Rest Exceptions + , RestException(..) + -- * Re-exports + , MediaType + , StdMethod(..) + , UTCTime + -- * Utilities + , toHttpDateHeader + ) where + +import BasePrelude hiding (Handler) + +import Web.Scotty.Rest.Types + +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) +import Data.Convertible (convert) +import Data.Default.Class (Default (..), def) +import Data.String.Conversions (convertString) +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 = RestConfig (RestM m) + +-- | /rest/ is used where you would use e.g. 'get' in your Scotty app, and +-- will match any method: +-- +-- > main = scotty 3000 $ do +-- > get "/foo" (text "Hello!") +-- > rest "/bar" defaultConfig { +-- > contentTypesProvided = return [("text/html",html "Hello, World!")] +-- > } +rest :: (MonadIO m) => RoutePattern -> Config m -> ScottyT RestException m () +rest pattern config = matchAny pattern (restHandlerStart config `rescue` handleExcept) + +-- | A 'RestConfig' with default values. To override one or more fields, use +-- record syntax: +-- +-- > defaultConfig { +-- > contentTypesProvided = return [("text/html",html "Hello, World!")] +-- > } +defaultConfig :: (MonadIO m) => Config m +defaultConfig = def + +preferred :: (MonadIO m) => Config m -> RestM m (MediaType, RestM m ()) +preferred config = do + -- If there is an `Accept` header -- look at the content types we provide and + -- find and store the best handler together with the content type. If we + -- cannot provide that type, stop processing here and return a + -- NotAcceptable406: + accept <- return . convertString . 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 :: (MonadIO m) => Config m -> RestM m (Maybe Language) +language config = findPreferred config "accept-language" parse languagesProvided match + where parse = parseAccept . convertString + match = flip matches + +charset :: (MonadIO m) => Config m -> RestM 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 :: (MonadIO m) => Config m + -> TL.Text + -> (TL.Text -> Maybe a) + -> (Config m -> RestM m (Maybe [a])) + -> (a -> a -> Bool) + -> RestM m (Maybe a) +findPreferred config headerName parse provided match = do + -- If there is an `Accept-{Charsets,Languages}` header and + -- `{Charsets,Languages}Provided` is defined, look at what we provide and + -- find and store the first acceptable one (languages and charsets are in + -- order of preference). If we cannot provide the requested one, stop + -- processing here and return a NotAcceptable406. + headerAndConfig <- runMaybeT $ do + accept <- MaybeT (header headerName) + provide <- MaybeT (provided config) + return (accept,provide) + case headerAndConfig of + Nothing -> return Nothing + Just (a,p) -> do + -- We now have a new failure mode: Since there is a header, and a list + -- of languages/charsets, failing to parse the header, or failing to + -- find a match, will now lead to a 406 Not Acceptable: + 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 + +requestMethod :: (MonadIO m) => RestM m StdMethod +requestMethod = do + req <- request + case (parseMethod . Wai.requestMethod) req of + Left _ -> raise NotImplemented501 + Right method -> if method `elem` [GET, HEAD, POST, PUT, PATCH, DELETE, OPTIONS] + then return method + else raise NotImplemented501 + +restHandlerStart :: (MonadIO m) => Config m -> RestM m () +restHandlerStart config = do + -- Is our service available? + available <- serviceAvailable config + unless available (raise ServiceUnavailable503) + + -- Is the method known? + method <- requestMethod + + -- TODO: Is the URI too long? + + -- Is the method allowed? + allowed <- allowedMethods config + when (method `notElem` allowed) $ do + setAllowHeader config + raise MethodNotAllowed405 + + -- Is the request malformed? + isMalformed <- malformedRequest config + when isMalformed (raise BadRequest400) + + -- Is the client authorized? + isAuthorized config >>= \case + Authorized -> return () + (NotAuthorized challenge) -> setHeader "WWW-Authenticate" challenge >> raise Unauthorized401 + + -- Is the client forbidden to access this resource? + isForbidden <- forbidden config + when isForbidden (raise Forbidden403) + + -- TODO: Are the content headers valid? + -- TODO: Is the entity length valid? + + if method == OPTIONS + then handleOptions config + else contentNegotiationStart config + +setAllowHeader :: (MonadIO m) => Config m -> RestM m () +setAllowHeader config= do + allowed <- allowedMethods config + setHeader "allow" . TL.intercalate ", " . map (convertString . show) $ allowed + +---------------------------------------------------------------------------------------------------- +-- OPTIONS +---------------------------------------------------------------------------------------------------- + +handleOptions :: (MonadIO m) => Config m -> RestM m () +handleOptions config = optionsHandler config >>= \case + Nothing -> setAllowHeader config + (Just (contentType,handler)) -> handler >> setContentTypeHeader contentType + +---------------------------------------------------------------------------------------------------- +-- Content negotiation +---------------------------------------------------------------------------------------------------- + +contentNegotiationStart :: (MonadIO m) => Config m -> RestM m () +contentNegotiationStart = contentNegotiationAccept + +contentNegotiationAccept :: (MonadIO m) => Config m -> RestM m () +contentNegotiationAccept config = do + accept <- header "accept" + -- evalute `preferred` to force early 406 (Not acceptable): + when (isJust accept) (preferred config >> return ()) + contentNegotiationAcceptLanguage config + +-- If there is an `Accept-Language` header, check that we provide that +-- language. If not → 406. +contentNegotiationAcceptLanguage :: (MonadIO m) => Config m -> RestM m () +contentNegotiationAcceptLanguage config = do + acceptLanguage <- header "accept-language" + -- evalute `language` to force early 406 (Not acceptable): + when (isJust acceptLanguage) (language config >> return ()) + contentNegotiationAcceptCharSet config + +-- -- If there is an `Accept-Charset` header, check that we provide that +-- -- char set. If not → 406. +contentNegotiationAcceptCharSet :: (MonadIO m) => Config m -> RestM m () +contentNegotiationAcceptCharSet config = do + acceptCharset <- header "accept-charset" + -- evalute `charset` to force early 406 (Not acceptable): + when (isJust acceptCharset) (charset config >> return ()) + contentNegotiationVariances config + +-- If we provide more than one content type, add `Accept` to `Vary` header. If +-- we provide a set of languages and/or charsets, add `Accept-Language` and +-- `Accept-Charset`, respectively, to the `Vary` header too. +contentNegotiationVariances :: (MonadIO m) => Config m -> RestM 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'' + setHeader "vary" . TL.intercalate ", " $ varyHeader''' + checkResourceExists config + +checkResourceExists :: (MonadIO m) => Config m -> RestM m () +checkResourceExists config = do + method <- requestMethod + exists <- resourceExists config + 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 + +---------------------------------------------------------------------------------------------------- +-- GET/HEAD +---------------------------------------------------------------------------------------------------- + +handleGetHeadExisting :: (MonadIO m) => Config m -> RestM m () +handleGetHeadExisting config = do + cond config + addCacheHeaders config + method <- requestMethod + (contentType,handler) <- preferred config + multipleChoices config >>= \case + MultipleRepresentations t' c' -> writeContent t' c' >> status multipleChoices300 + MultipleWithPreferred t' c' u -> writeContent t' c' >> setHeader "location" u >> status multipleChoices300 + UniqueRepresentation -> do when (method == GET) handler + setContentTypeHeader contentType + status ok200 + +handleGetHeadNonExisting :: (MonadIO m) => Config m -> RestM m () +handleGetHeadNonExisting = handleNonExisting + +checkMoved :: (MonadIO m) => Config m -> RestM m () +checkMoved config = resourceMoved config >>= \case + NotMoved -> return () + (MovedPermanently url) -> setHeader "location" url >> raise MovedPermanently301 + (MovedTemporarily url) -> setHeader "location" url >> raise MovedTemporarily307 + +---------------------------------------------------------------------------------------------------- +-- PUT/POST/PATCH +---------------------------------------------------------------------------------------------------- + +handlePutPostPatchNonExisting :: (MonadIO m) => Config m -> RestM m () +handlePutPostPatchNonExisting config = do + -- If there is an if-match header, the precondition failed since the resource doesn't exist + liftM isJust (header "if-match") >>= (`when` raise PreconditionFailed412) + ifMethodIs [POST, PATCH] + (ppppreviouslyExisted config) + (pppmethodIsPut config) + +ppppreviouslyExisted :: (MonadIO m) => Config m -> RestM m () +ppppreviouslyExisted config = do + existed <- previouslyExisted config + if existed + then pppmovedPermanentlyOrTemporarily config + else pppmethodIsPost config + +pppmovedPermanentlyOrTemporarily :: (MonadIO m) => Config m -> RestM m () +pppmovedPermanentlyOrTemporarily config = do + checkMoved config + ifMethodIs [POST] + (allowsMissingPost config (acceptResource config) (raise Gone410)) + (pppmethodIsPut config) + +pppmethodIsPost :: (MonadIO m) => Config m -> RestM m () +pppmethodIsPost config = + ifMethodIs [POST] + (allowsMissingPost config (pppmethodIsPut config) (raise NotFound404)) + (raise NotFound404) + +pppmethodIsPut :: (MonadIO m) => Config m -> RestM m () +pppmethodIsPut config = do + method <- requestMethod + when (method == PUT) $ do + conflict <- isConflict config + when conflict (raise Conflict409) + + acceptResource config + +handlePutPostPatchExisting :: (MonadIO m) => Config m -> RestM m () +handlePutPostPatchExisting config = do + cond config + pppmethodIsPut config + +---------------------------------------------------------------------------------------------------- +-- POST/PUT/PATCH, part 2: content-types accepted +---------------------------------------------------------------------------------------------------- + +acceptResource :: (MonadIO m) => Config m -> RestM m () +acceptResource config = do + -- Is there a Content-Type header? + contentTypeHeader <- header "content-type" + contentType <- maybe (raise UnsupportedMediaType415) (return . convertString) contentTypeHeader + + -- Do we have a handler for this content type? If so, run it. Alternatively, return 415. + 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 :: (MonadIO m) => MediaType -> TL.Text -> RestM m () +writeContent t c = do + method <- requestMethod + setContentTypeHeader t + when (method /= HEAD) ((raw . convertString) c) + +resourceWithContent :: (MonadIO m) => Config m -> MediaType -> TL.Text -> RestM m () +resourceWithContent config t c = multipleChoices config >>= \case + UniqueRepresentation -> setContentTypeHeader t >> (raw . convertString) c >> status ok200 + MultipleRepresentations t' c' -> writeContent t' c' >> status multipleChoices300 + MultipleWithPreferred t' c' u -> writeContent t' c' >> setHeader "location" u >> status multipleChoices300 + +---------------------------------------------------------------------------------------------------- +-- DELETE +---------------------------------------------------------------------------------------------------- + +handleDeleteExisting :: (MonadIO m) => Config m -> RestM 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 :: (MonadIO m) => Config m -> RestM m () +handleDeleteNonExisting = handleNonExisting + +---------------------------------------------------------------------------------------------------- +-- Conditional requests +---------------------------------------------------------------------------------------------------- + +cond :: (MonadIO m) => Config m -> RestM m () +cond = condIfMatch + +condIfMatch :: (MonadIO m) => Config m -> RestM m () +condIfMatch config = header "if-match" >>= \case + Nothing -> condIfUnmodifiedSince config + Just hdr -> ifEtagMatches config hdr + (condIfUnmodifiedSince config) + (addEtagHeader config >> raise PreconditionFailed412) + +condIfUnmodifiedSince :: (MonadIO m) => Config m -> RestM m () +condIfUnmodifiedSince config = modifiedSinceHeaderDate config "if-unmodified-since" >>= \case + Nothing -> condIfNoneMatch config -- If there are any errors: continue + Just False -> condIfNoneMatch config + Just True -> addLastModifiedHeader config >> raise PreconditionFailed412 + +condIfNoneMatch :: (MonadIO m) => Config m -> RestM m () +condIfNoneMatch config = header "if-none-match" >>= \case + Nothing -> condIfModifiedSince config + Just hdr -> ifEtagMatches config hdr + match + (condIfModifiedSince config) + where match = ifMethodIs [GET, HEAD] + (notModified config) + (addEtagHeader config >> raise PreconditionFailed412) + +condIfModifiedSince :: (MonadIO m) => Config m -> RestM m () +condIfModifiedSince config = modifiedSinceHeaderDate config "if-modified-since" >>= \case + Nothing -> return () + Just False -> notModified config + Just True -> return () + +---------------------------------------------------------------------------------------------------- +-- Helpers +---------------------------------------------------------------------------------------------------- + +addCacheHeaders :: (MonadIO m) => Config m -> RestM m () +addCacheHeaders config = do + addEtagHeader config + addLastModifiedHeader config + addExpiresHeader config + +notModified :: (MonadIO m) => Config m -> RestM m () +notModified config = do + addCacheHeaders config + raise NotModified304 + +addEtagHeader :: (MonadIO m) => Config m -> RestM m () +addEtagHeader config = generateEtag config >>= \case + Nothing -> return () + Just (Weak t) -> setHeader "etag" ("W/\"" <> t <> "\"") + Just (Strong t) -> setHeader "etag" ("\"" <> t <> "\"") + +addLastModifiedHeader :: (MonadIO m) => Config m -> RestM m () +addLastModifiedHeader config = lastModified config >>= \case + Nothing -> return () + Just t -> setHeader "last-modified" (toHttpDateHeader t) + +addExpiresHeader :: (MonadIO m) => Config m -> RestM m () +addExpiresHeader config = expires config >>= \case + Nothing -> return () + Just t -> setHeader "expires" (toHttpDateHeader t) + +modifiedSinceHeaderDate :: (MonadIO m) => Config m -> TL.Text -> RestM 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 :: (MonadIO m) => Config m -> RestM m () +handleNonExisting config = do + -- If there is an if-match header, the precondition failed since the resource doesn't exist + liftM isJust (header "if-match") >>= (`when` raise PreconditionFailed412) + + -- Did this resource exist before? + existed <- previouslyExisted config + unless existed (raise NotFound404) + + checkMoved config + raise Gone410 + +setContentTypeHeader :: (MonadIO m) => MediaType -> RestM m () +setContentTypeHeader = setHeader "content-type" . convertString . renderHeader + +ifMethodIs :: (MonadIO m) => [StdMethod] -> RestM m () -> RestM m () -> RestM m () +ifMethodIs ms onTrue onFalse = do + method <- requestMethod + if method `elem` ms + then onTrue + else onFalse + +allowsMissingPost :: (MonadIO m) => Config m -> RestM m () -> RestM m () -> RestM m () +allowsMissingPost config onTrue onFalse = do + allowed <- allowMissingPost config + if allowed + then onTrue + else onFalse + +ifEtagMatches :: (MonadIO m) => Config m -> TL.Text -> RestM m () -> RestM m () -> RestM 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 . convertString) 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 + +-- | Formats a 'UTCTime' as a HTTP date, e.g. /Sun, 06 Nov 1994 08:49:37 GMT/. +toHttpDateHeader :: UTCTime -> TL.Text +toHttpDateHeader = convertString . formatHTTPDate . epochTimeToHTTPDate . convert + +handleExcept :: (Monad m) => RestException -> RestM 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 diff --git a/src/Web/Scotty/Rest/Types.hs b/src/Web/Scotty/Rest/Types.hs new file mode 100644 --- /dev/null +++ b/src/Web/Scotty/Rest/Types.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RankNTypes #-} + +module Web.Scotty.Rest.Types + ( + RestM + -- * Callbacks result types + , Authorized(..) + , DeleteResult(..) + , ETag(..) + , Moved(..) + , ProcessingResult(..) + , Representation (..) + , RestConfig(..) + , RestException(..) + , Url + -- * Re-exports + , MediaType + , Language + , StdMethod(..) + ) where + +import BasePrelude + +import Control.Monad.IO.Class (MonadIO) +import Data.Default.Class (Default (..), def) +import qualified Data.Text.Lazy as TL +import Data.Time.Clock (UTCTime) +import Network.HTTP.Media (Language, MediaType) +import Network.HTTP.Types (StdMethod (..)) +import Web.Scotty.Trans hiding (get) + +type RestM m = ActionT RestException m + +-- | A URL. +type Url = TL.Text + +-- | Result of the 'resourceMoved' callback. +data Moved = NotMoved -- ^ Resource has not moved. + | MovedTemporarily !Url -- ^ Resource has been temporarily moved to the given URL. + | MovedPermanently !Url -- ^ Resource has been permanently moved to the given URL. + +-- | An ETag validator generated by the 'generateEtag' callback. +data ETag = Strong TL.Text -- ^ A strong ETag validator + | Weak TL.Text -- ^ A weak ETag validator + +-- | Result of a Processing request (e.g. `POST`, `PUT`, `PATCH`) +data ProcessingResult = Succeeded + -- ^ Processing succeeded. Returns __204 No Content__ or __201 Created__ based + -- on whether the resource existed previously or not. + | SucceededWithContent !MediaType !TL.Text + -- ^ Processing succeeded with the given content. Returns __201 Created__ or + -- __200 OK/300 Multiple Representations__ based on whether the resource + -- existed previously or not. + | SucceededWithLocation !Url + -- ^ Processing succeeded with the given content. Returns __201 Created__ or + -- __200 OK/300 Multiple Representations__ based on whether the resource + -- existed previously or not. + | Redirect !Url + -- ^ Redirects (with __303 See Other__) to the given URL. + | Failed + -- ^ Processing failed. Returns __400 Bad Request__. + +-- | Response to 'multipleChoices' callback. +data Representation = UniqueRepresentation + -- ^ The resource has a unique representation. + | MultipleRepresentations !MediaType !TL.Text + -- ^ There are multiple representations of this resource. Respond with the + -- given body. + | MultipleWithPreferred !MediaType !TL.Text !Url + -- ^ There are multiple representations of this resource, but one is preferred. + -- Respond with the given body, and 'Url' (in the `Location` header). + +-- | Response to 'deleteResource' callback. +data DeleteResult = NotDeleted + -- ^ The resource could not be deleted. + | Deleted + -- ^ The deletion operation has been fully completed. + | DeletedWithResponse !MediaType !TL.Text + -- ^ The deletion operation has been fully completed. Respond with the given body. + | DeleteEnacted + -- ^ Accepted for processing, but the processing has not been completed (and may never be). + +-- | Response to 'isAuthorized' callback. +data Authorized = Authorized -- ^ User is authenticated and authorized. + | NotAuthorized !TL.Text -- ^ User is not authorized. The given challenge will be + -- sent as part of the /WWW-Authenticate/ header. + +-- | The callbacks that control a handler's behaviour. 'Scotty.Rest.defaultConfig' returns a config +-- with default values. For typical handlers, you only need to override a few of these callbacks. +data RestConfig m = RestConfig + { allowedMethods :: m [StdMethod] + -- ^ List of allowed methos. + -- + -- Default: @[GET, HEAD, OPTIONS]@ + , resourceExists :: m Bool + -- ^ Does this resource exist? + -- + -- Default: 'True' + , previouslyExisted :: m Bool + -- ^ Did this resource exist previously? + -- + -- Default: 'False' + , isConflict :: m Bool + -- ^ Only for `PUT` requests. Does this request result in a conflict? + -- + -- Default: 'False' + , contentTypesAccepted :: m [(MediaType, m ProcessingResult)] + -- ^ A list of the content types /accepted/, together with handlers producing a 'ProcessingResult' + -- for that 'MediaType'. + -- + -- Default: @[]@ + , contentTypesProvided :: m [(MediaType, m ())] + -- ^ A list of the content types /provided/, together with handlers producing a response body for + -- that 'MediaType'. + -- + -- Default: @[]@ + , languagesProvided :: m (Maybe [Language]) + -- ^ A list of the languages provided in order of preference. If the `Accept-Language` header was + -- not sent, the first charset is selected. If 'Nothing', the `Accept-Language` header is ignored. + -- + -- Default: 'Nothing' + , charsetsProvided :: m (Maybe [TL.Text]) + -- ^ A list of the character sets provided in order of preference. If the `Accept-Charset` header + -- was not sent, the first charset is selected. If 'Nothing', the `Accept-Charset` header is + -- ignored. + -- + -- Default: 'Nothing' + , deleteResource :: m DeleteResult + -- ^ A handler for `DELETE` requests. The handler is responsible for deleting the resource and + -- returning a 'DeleteResult'. + -- + -- Default: 'NotDeleted' + , optionsHandler :: m (Maybe (MediaType, m ())) + -- ^ A handler for `OPTIONS` requests. If implemented, the handler will be run (possibly producing + -- a body), and the given media type will be sent in the `Content-Type` header. When 'Nothing', + -- the `Allow` header will be sent with the allowed methods (from 'allowedMethods'). + -- + -- Default: 'Nothing' + , generateEtag :: m (Maybe ETag) + -- ^ An ETag for the resource. + -- + -- Default: 'Nothing' + , expires :: m (Maybe UTCTime) + -- ^ When the resource expires (if ever). This will be sent in the `expires` header. + -- + -- Default: 'Nothing' + , lastModified :: m (Maybe UTCTime) + -- ^ When the resource was last modified. + -- + -- Default: 'Nothing' + , malformedRequest :: m Bool + -- ^ If 'True', the request is considered malformed and a __400 Bad Request__ is returned. + -- + -- Default: 'False' + , isAuthorized :: m Authorized + -- ^ Is authentication is required, and has it failed or has not been provided? + -- + -- Default: 'Authorized' + , forbidden :: m Bool + -- ^ If 'True', access to this resource is forbidden, and __403 Forbidden__ is returned. + -- + -- Default: 'False'. + , serviceAvailable :: m Bool + -- ^ Is the service available? + -- + -- Default 'True' + , allowMissingPost :: m Bool + -- ^ Do we allow `POST`ing to this resource if it does not exist? + -- + -- Default 'True' + , multipleChoices :: m Representation + -- ^ Are there multiple representations for this resource? + -- + -- Default: 'UniqueRepresentation' + , resourceMoved :: m Moved + -- ^ Has this resource moved? + -- + -- Default: 'NotMoved' + , variances :: m [TL.Text] + -- ^ Returns a list of header names that should be included in a given response's /Vary/ header. + -- The standard content negotiation headers (/Accept/, /Accept-Encoding/, /Accept-Charset/, + -- /Accept-Language/) do not need to be specified here as they will be added automatically when + -- e.g. several content types are provided. + -- + -- Default: @[]@ + } + +instance (MonadIO m) => Default (RestConfig m) where + def = RestConfig { 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 [] + } + +data RestException = MovedPermanently301 + | NotModified304 + | MovedTemporarily307 + | BadRequest400 + | Unauthorized401 + | Forbidden403 + | NotFound404 + | NotAcceptable406 + | Conflict409 + | Gone410 + | PreconditionFailed412 + | UnsupportedMediaType415 + | NotImplemented501 + | ServiceUnavailable503 + | MethodNotAllowed405 + | InternalServerError TL.Text + deriving (Show, Eq) + +instance ScottyError RestException where + stringError = InternalServerError . TL.pack + showError = fromString . show diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Web/ScottyRestSpec.hs b/test/Web/ScottyRestSpec.hs new file mode 100644 --- /dev/null +++ b/test/Web/ScottyRestSpec.hs @@ -0,0 +1,591 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Web.ScottyRestSpec (main, spec) where + +import Test.Hspec +import Test.Hspec.Wai +import Test.Hspec.Wai.Internal +import Test.QuickCheck (Arbitrary, arbitrary, elements, property) + +import Web.Scotty.Rest (RestConfig (..), StdMethod (..)) +import qualified Web.Scotty.Rest as Rest +import Web.Scotty.Trans hiding (delete, get, patch, post, put, request) + +import Control.Monad (liftM) +import Control.Monad.State (evalStateT) +import Data.ByteString.Char8 (pack) +import Data.String.Conversions (cs) +import Data.Text.Lazy (intercalate) + +instance Arbitrary Rest.StdMethod where + arbitrary = elements (enumFromTo minBound maxBound) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + let withApp = with . scottyAppT id + + describe "Conditional requests" $ do + describe "If-Match" $ + withApp (Rest.rest "/" Rest.defaultConfig { + allowedMethods = return [DELETE] + }) $ + it "makes sure we get a 412 Precondition Failed when e-tag does not match" $ + request "DELETE" "/" [("if-match","")] "" `shouldRespondWith` 412 + + describe "If-None-Match" $ do + withApp (Rest.rest "/" Rest.defaultConfig { + allowedMethods = return [DELETE], + generateEtag = return (Just (Rest.Strong "foo")) + }) $ + it "makes sure we get a 412 Precondition Failed for DELETE when e-tag matches" $ do + let expectedHeaders = ["Etag" <:> "\"foo\""] + request "DELETE" "/" [("if-none-match","\"foo\"")] "" + `shouldRespondWith` 412 {matchHeaders = expectedHeaders} + + withApp (Rest.rest "/" Rest.defaultConfig { + allowedMethods = return [DELETE], + generateEtag = return (Just (Rest.Strong "foo")) + }) $ + it "makes sure we get a 412 Precondition Failed for DELETE when e-tag matches" $ do + let expectedHeaders = ["Etag" <:> "\"foo\""] + request "DELETE" "/" [("if-none-match","\"foo\", \"bar\"")] "" + `shouldRespondWith` 412 {matchHeaders = expectedHeaders} + + withApp (Rest.rest "/" Rest.defaultConfig { + contentTypesProvided = return [("text/html",text "foo")], + generateEtag = return (Just (Rest.Strong "foo")) + }) $ + it "makes sure we don't get a 304 Not Changed for GET when e-tag doesn't match" $ do + let expectedHeaders = ["Etag" <:> "\"foo\""] + request "GET" "/" [("if-none-match","\"bar\"")] "" + `shouldRespondWith` 200 {matchHeaders = expectedHeaders} + + withApp (Rest.rest "/" Rest.defaultConfig { + contentTypesProvided = return [("text/html",undefined)], + generateEtag = return (Just (Rest.Strong "foo")) + }) $ + it "makes sure we get a 304 Not Changed for GET when e-tag matches" $ do + let expectedHeaders = ["Etag" <:> "\"foo\""] + request "GET" "/" [("if-none-match","\"foo\"")] "" + `shouldRespondWith` 304 {matchHeaders = expectedHeaders} + + withApp (Rest.rest "/" Rest.defaultConfig { + contentTypesProvided = return [("text/html",undefined)], + generateEtag = return (Just (Rest.Strong "bar")) + }) $ + it "makes sure we get a 304 Not Changed for GET when e-tag matches" $ do + let expectedHeaders = ["Etag" <:> "\"bar\""] + request "GET" "/" [("if-none-match","\"foo\", \"bar\"")] "" + `shouldRespondWith` 304 {matchHeaders = expectedHeaders} + + withApp (Rest.rest "/" Rest.defaultConfig { + contentTypesProvided = return [("text/html",text "foo")], + generateEtag = return (Just (Rest.Strong "foo")) + }) $ + it "makes sure we get a 304 Not Changed for if-none-match *" $ do + let expectedHeaders = ["Etag" <:> "\"foo\""] + request "GET" "/" [("if-none-match","*")] "" + `shouldRespondWith` 304 {matchHeaders = expectedHeaders} + + withApp (Rest.rest "/" Rest.defaultConfig { + allowedMethods = return [DELETE] + }) $ + it "makes sure we get a 412 Precondition Failed for if-none-match * for non-GET/HEAD" $ do + request "DELETE" "/" [("if-none-match","*")] "" + `shouldRespondWith` 412 + + describe "If-Unmodified-Since" $ do + let time = read" 2015-01-01 12:00:00.000000 UTC" + withApp (Rest.rest "/" Rest.defaultConfig { + contentTypesProvided = return [("text/html",undefined)], + lastModified = return (Just time) + }) $ + it "makes sure we get a 412 Not Changed when not modified since given date" $ do + let expectedHeaders = ["Last-Modified" <:> "Thu, 01 Jan 2015 12:00:00 GMT"] + request "GET" "/" [("if-unmodified-since","Thu, 31 May 2014 20:00:00 GMT")] "" + `shouldRespondWith` 412 {matchHeaders = expectedHeaders} + + describe "If-Modified-Since" $ do + let time = read" 2015-01-01 12:00:00.000000 UTC" + withApp (Rest.rest "/" Rest.defaultConfig { + contentTypesProvided = return [("text/html",undefined)], + lastModified = return (Just time) + }) $ + it "makes sure we get a 304 Not Changed when not modified since given date" $ do + let expectedHeaders = ["Last-Modified" <:> "Thu, 01 Jan 2015 12:00:00 GMT"] + request "GET" "/" [("if-modified-since","Thu, 31 May 2015 20:00:00 GMT")] "" + `shouldRespondWith` 304 {matchHeaders = expectedHeaders} + + + describe "ETag/Expires/Last-Modified headers" $ do + describe "ETag" $ do + withApp (Rest.rest "/" Rest.defaultConfig { + contentTypesProvided = return [("text/html",text "hello")] + , generateEtag = return (Just (Rest.Strong "foo")) + }) $ + it "makes sure we get an ETag header" $ + request "GET" "/" [] "" `shouldRespondWith` "hello" {matchHeaders = ["ETag" <:> "\"foo\""]} + + withApp (Rest.rest "/" Rest.defaultConfig { + contentTypesProvided = return [("text/html",text "hello")] + , generateEtag = return (Just (Rest.Weak "foo")) + }) $ + it "makes sure we get a (weak) ETag header" $ + request "GET" "/" [] "" `shouldRespondWith` "hello" {matchHeaders = ["ETag" <:> "W/\"foo\""]} + + describe "Expires" $ do + let now = read "2015-02-16 13:11:11.753542 UTC" + withApp (Rest.rest "/" Rest.defaultConfig { + contentTypesProvided = return [("text/html",text "hello")] + , expires = return (Just now) + }) $ + it "makes sure we get an Expires header" $ do + let expectedHeaders = ["Expires" <:> (cs . Rest.toHttpDateHeader) now] + request "GET" "/" [] "" `shouldRespondWith` "hello" {matchHeaders = expectedHeaders} + + describe "Last-Modified" $ do + let time = read" 2015-01-01 12:00:00.000000 UTC" + withApp (Rest.rest "/" Rest.defaultConfig { + contentTypesProvided = return [("text/html",text "hello")] + , lastModified = return (Just time) + }) $ + it "makes sure we get a Last-Modified header" $ do + let expectedHeaders = ["Last-Modified" <:> (cs . Rest.toHttpDateHeader) time] + request "GET" "/" [] "" `shouldRespondWith` "hello" {matchHeaders = expectedHeaders} + + describe "HTTP (OPTIONS)" $ do + describe "Allow header" $ do + withApp (Rest.rest "/" Rest.defaultConfig) $ + it "makes sure we get a list of allowed methods for OPTIONS" $ do + let expectedHeaders = ["Allow" <:> "GET, HEAD, OPTIONS"] + request "OPTIONS" "/" [] "" `shouldRespondWith` "" {matchHeaders = expectedHeaders} + + withApp (Rest.rest "/" Rest.defaultConfig {allowedMethods = return [GET, OPTIONS, POST, PATCH]}) $ + it "makes sure we get a list of allowed methods for OPTIONS" $ do + let expectedHeaders = ["Allow" <:> "GET, OPTIONS, POST, PATCH"] + request "OPTIONS" "/" [] "" `shouldRespondWith` "" {matchHeaders = expectedHeaders} + + describe "Custom OPTIONS handler" $ + withApp (Rest.rest "/" Rest.defaultConfig {optionsHandler = return (Just ("text/plain",text "xyz"))}) $ + it "makes sure a custom OPTIONS handler is run" $ + request "OPTIONS" "/" [] "" + `shouldRespondWith` "xyz" {matchHeaders = ["Content-Type" <:> "text/plain"]} + + describe "HTTP (DELETE)" $ do + describe "DELETE existing: Fail" $ + withApp (Rest.rest "/" Rest.defaultConfig {allowedMethods = return [DELETE]}) $ + it "makes sure we get a 500 if deleteResource fails" $ + request "DELETE" "/" [] "" `shouldRespondWith` 500 + + describe "DELETE existing: Enacted" $ + withApp (Rest.rest "/" Rest.defaultConfig { + deleteResource = return Rest.DeleteEnacted + , allowedMethods = return [DELETE] + }) $ + it "makes sure we get a 202 if delete is enacted" $ + request "DELETE" "/" [] "" `shouldRespondWith` 202 + + describe "DELETE existing: Completed" $ + withApp (Rest.rest "/" Rest.defaultConfig { + deleteResource = return Rest.Deleted + , allowedMethods = return [DELETE] + }) $ + it "makes sure we get a 204 if delete is completed" $ + request "DELETE" "/" [] "" `shouldRespondWith` 204 + + describe "HTTP (POST)" $ do + describe "200: Created with content" $ + withApp (Rest.rest "/" Rest.defaultConfig { + allowedMethods = return [POST], + contentTypesProvided = return [("text/html",undefined)], + contentTypesAccepted = return [ + ("text/plain", return (Rest.SucceededWithContent "text/html" "hi")) + ] + }) $ + it "makes sure we get a 200 when handler returns SucceededWithContent" $ do + let expectedHeaders = ["Content-Type" <:> "text/html"] + request "POST" "/" [("Content-Type","text/plain")] "" + `shouldRespondWith` "hi" {matchStatus = 200, matchHeaders = expectedHeaders} + + describe "201: Created" $ do + withApp (Rest.rest "/" Rest.defaultConfig { + allowedMethods = return [POST], + resourceExists = return False, + contentTypesProvided = return [("text/html",undefined)], + contentTypesAccepted = return [ + ("text/plain",return (Rest.SucceededWithLocation "foo.bar")) + ] + }) $ + it "makes sure we get a 201 when handler returns SucceededWithLocation" $ do + let expectedHeaders = ["Location" <:> "foo.bar"] + request "POST" "/" [("Content-Type","text/plain")] "" + `shouldRespondWith` "" {matchStatus = 201, matchHeaders = expectedHeaders} + + withApp (Rest.rest "/" Rest.defaultConfig { + allowedMethods = return [POST], + resourceExists = return False, + contentTypesProvided = return [("text/html",undefined)], + contentTypesAccepted = return [ + ("text/plain",return (Rest.SucceededWithContent "text/plain" "foo")) + ] + }) $ + it "makes sure we get a 201 when handler returns SucceededWithLocation" $ do + let expectedHeaders = ["Content-Type" <:> "text/plain"] + request "POST" "/" [("Content-Type","text/plain")] "" + `shouldRespondWith` "foo" {matchStatus = 201, matchHeaders = expectedHeaders} + + describe "204: No Content" $ + withApp (Rest.rest "/" Rest.defaultConfig { + allowedMethods = return [POST], + contentTypesProvided = return [("text/html",undefined)], + contentTypesAccepted = return [("text/plain",return Rest.Succeeded)] + }) $ + it "makes sure we get a 204 when handler returns Succeeded" $ + request "POST" "/" [("Content-Type","text/plain")] "" + `shouldRespondWith` "" {matchStatus = 204} + + describe "204: No Content" $ + withApp (Rest.rest "/" Rest.defaultConfig { + allowedMethods = return [PUT], + resourceExists = return True, + contentTypesProvided = return [("text/html",undefined)], + contentTypesAccepted = return [("text/plain",return Rest.Succeeded)] + }) $ + it "makes sure we get a 204 when handler returns Succeeded" $ + request "PUT" "/" [("Content-Type","text/plain")] "" + `shouldRespondWith` "" {matchStatus = 204} + + describe "204: POSTing to missing resource that existed previously" $ + withApp (Rest.rest "/" Rest.defaultConfig { + allowedMethods = return [POST], + contentTypesProvided = return [("text/html",undefined)], + contentTypesAccepted = return [("application/json",return Rest.Succeeded)] + }) $ + it "makes sure we get a 204 when POSTing to resource that existed, when allowing POSTing to missing resource" $ + request "POST" "/" [("Content-Type","application/json")] "" `shouldRespondWith` "" {matchStatus = 204} + + describe "404: POSTint to never-existed" $ + withApp (Rest.rest "/" Rest.defaultConfig { + allowedMethods = return [POST], + resourceExists = return False, + previouslyExisted = return False, + allowMissingPost = return False, + contentTypesProvided = return [("text/html",undefined)], + contentTypesAccepted = return [("application/json",return Rest.Succeeded)] + }) $ + it "makes sure we get a 404 when POSTing to a never-existed resource when not allowing missing POSTs" $ + request "POST" "/" [("Content-Type","application/json")] "" `shouldRespondWith` "" {matchStatus = 404} + + describe "HTTP (PATCH)" $ + describe "404: PATCHing a never-existed" $ + withApp (Rest.rest "/" Rest.defaultConfig { + allowedMethods = return [PATCH], + resourceExists = return False, + previouslyExisted = return False, + contentTypesProvided = return [("text/html",undefined)], + contentTypesAccepted = return [("application/json",return Rest.Succeeded)] + }) $ + it "makes sure we get a 404 when PATCHing a never-existed resource" $ + request "PATCH" "/" [("Content-Type","application/json")] "" `shouldRespondWith` "" {matchStatus = 404} + + describe "HTTP (Vary)" $ do + describe "Multiple content types provided" $ + withApp (Rest.rest "/" Rest.defaultConfig { + contentTypesProvided = return [("text/plain",text "foo"),("text/html",undefined)] + }) $ + it "makes sure we get a Vary header with `Accept` when offering several content types" $ do + let expectedHeaders = ["Vary" <:> "Accept"] + request "GET" "/" [] "" `shouldRespondWith` "foo" {matchStatus = 200, matchHeaders = expectedHeaders} + + describe "Multiple languages provided" $ + withApp (Rest.rest "/" Rest.defaultConfig { + contentTypesProvided = return [("text/plain",text "foo")], + languagesProvided = return (Just ["en-gb", "de"]) + }) $ + it "makes sure we get a Vary header with `Accept` when offering several languages" $ do + let expectedHeaders = ["Vary" <:> "Accept-Language"] + request "GET" "/" [] "" `shouldRespondWith` "foo" {matchStatus = 200, matchHeaders = expectedHeaders} + + describe "Multiple charsets provided" $ + withApp (Rest.rest "/" Rest.defaultConfig { + contentTypesProvided = return [("text/plain",text "foo")], + charsetsProvided = return (Just ["ascii", "utf-8"]) + }) $ + it "makes sure we get a Vary header with `Accept` when offering several languages" $ do + let expectedHeaders = ["Vary" <:> "Accept-Charset"] + request "GET" "/" [] "" `shouldRespondWith` "foo" {matchStatus = 200, matchHeaders = expectedHeaders} + + describe "HTTP (General)" $ do + describe "300: Multiple Representations" $ do + withApp (Rest.rest "/" Rest.defaultConfig { + contentTypesProvided = return [("text/html",text "xxx")], + multipleChoices = return (Rest.MultipleRepresentations "text/plain" "foo") + }) $ + it "makes sure we get a 300 with a body when there are multiple representations" $ do + let expectedHeaders = ["Content-Type" <:> "text/plain"] + request "GET" "/" [] "" + `shouldRespondWith` "foo" {matchStatus = 300, matchHeaders = expectedHeaders} + + withApp (Rest.rest "/" Rest.defaultConfig { + contentTypesProvided = return [("text/html",text "xxx")], + multipleChoices = return (Rest.MultipleRepresentations "text/plain" "foo") + }) $ + it "makes sure we get a 300 without a body for HEAD when there are multiple representations" $ do + let expectedHeaders = ["Content-Type" <:> "text/plain"] + request "HEAD" "/" [] "" + `shouldRespondWith` "" {matchStatus = 300, matchHeaders = expectedHeaders} + + withApp (Rest.rest "/" Rest.defaultConfig { + allowedMethods = return [PUT], + contentTypesProvided = return [("text/html",undefined)], + contentTypesAccepted = return [("application/json",return (Rest.SucceededWithContent "text/plain" "xxx"))], + multipleChoices = return (Rest.MultipleRepresentations "text/plain" "foo") + }) $ + it "makes sure we get a 300 with a body when there are multiple representations" $ do + let expectedHeaders = ["Content-Type" <:> "text/plain"] + request "PUT" "/" [("Content-Type","application/json")] "" + `shouldRespondWith` "foo" {matchStatus = 300, matchHeaders = expectedHeaders} + + withApp (Rest.rest "/" Rest.defaultConfig { + allowedMethods = return [POST], + contentTypesProvided = return [("text/html",undefined)], + contentTypesAccepted = return [("application/json",return (Rest.SucceededWithContent "text/plain" "xxx"))], + multipleChoices = return (Rest.MultipleWithPreferred "text/plain" "foo" "foo.bar") + }) $ + it "makes sure we get a 300 with a location body when there are multiple representations, where one is preferred" $ do + let expectedHeaders = ["Location" <:> "foo.bar", "Content-Type" <:> "text/plain"] + request "POST" "/" [("Content-Type","application/json")] "" + `shouldRespondWith` "foo" {matchStatus = 300, matchHeaders = expectedHeaders} + + describe "301 Moved Permanently" $ + withApp (Rest.rest "/" Rest.defaultConfig { + resourceExists = return False, + previouslyExisted = return True, + resourceMoved = return (Rest.MovedPermanently "xxx"), + contentTypesProvided = return [("text/html",undefined)] + }) $ + it "makes sure we get a 301 when a resource existed before and is moved permanently" $ + request "GET" "/" [] "" `shouldRespondWith` "" {matchStatus = 301, matchHeaders = ["Location" <:> "xxx"]} + + describe "307 Moved Temporarily" $ + withApp (Rest.rest "/" Rest.defaultConfig { + resourceExists = return False, + previouslyExisted = return True, + resourceMoved = return (Rest.MovedTemporarily "xxx"), + contentTypesProvided = return [("text/html",undefined)] + }) $ + it "makes sure we get a 307 when a resource existed before and is moved temporarily" $ + request "GET" "/" [] "" `shouldRespondWith` "" {matchStatus = 307, matchHeaders = ["Location" <:> "xxx"]} + + describe "405 Method not allowed" $ + it "makes sure we get a 405 and an Allow header when method is not allowed" $ + property $ \m ms -> do + app <- scottyAppT id (Rest.rest "/" Rest.defaultConfig {allowedMethods = return ms}) + let known = [GET, HEAD, POST, PUT, PATCH, DELETE, OPTIONS] + let check = if | m `notElem` known -> (`shouldRespondWith` 501) + | m `notElem` ms -> (`shouldRespondWith` 405 {matchHeaders = ["allow" <:> (cs . intercalate ", " . map (cs . show)) ms]}) + | otherwise -> \_ -> return () + let waiSession = check (request ((pack . show) m) "/" [] "") + runWaiSession waiSession app + + describe "400 Bad Request" $ + withApp (Rest.rest "/" Rest.defaultConfig {malformedRequest = return True}) $ + it "makes sure we get a 400 when request is considered malformed" $ + request "GET" "/" [] "" `shouldRespondWith` "" {matchStatus = 400} + + describe "401 Unauthorized" $ + withApp (Rest.rest "/" Rest.defaultConfig {isAuthorized = return (Rest.NotAuthorized "Basic")}) $ + it "makes sure we get a 401 when access is not authorized" $ + request "GET" "/" [] "" `shouldRespondWith` "" {matchStatus = 401, matchHeaders = ["WWW-Authenticate" <:> "Basic"]} + + describe "403 Forbidden" $ + withApp (Rest.rest "/" Rest.defaultConfig {forbidden = return True}) $ + it "makes sure we get a 403 when access is forbidden" $ + request "GET" "/" [] "" `shouldRespondWith` "" {matchStatus = 403} + + describe "404 Not Found" $ + withApp (Rest.rest "/" Rest.defaultConfig { + resourceExists = return False, + contentTypesProvided = return [("text/html",undefined)] + }) $ + it "makes sure we get a 404 when resource does not exist and did not exist previously" $ + request "GET" "/" [] "" `shouldRespondWith` "" {matchStatus = 404} + + describe "406 Not Acceptable" $ do + withApp (Rest.rest "/" Rest.defaultConfig) $ + it "makes sure we get a 406 when we don't provided any types" $ + request "GET" "/" [("Accept","text/html")] "" + `shouldRespondWith` "" {matchStatus = 406} + + withApp (Rest.rest "/" Rest.defaultConfig { + contentTypesProvided = return [("text/html",text "")] + }) $ + it "makes sure we get a 406 when we don't provided the requested type" $ do + request "GET" "/" [("Accept","text/html; charset=utf-8")] "" + `shouldRespondWith` "" {matchStatus = 406} + request "GET" "/" [("Accept","text/plain")] "" + `shouldRespondWith` "" {matchStatus = 406} + + withApp (Rest.rest "/" Rest.defaultConfig { + contentTypesProvided = return [("text/html; charset=utf-8",text "")] + }) $ + it "makes sure we get a 406 when we don't provided the requested type" $ do + request "GET" "/" [("Accept","*/*")] "" + `shouldRespondWith` "" {matchStatus = 200} + request "GET" "/" [("Accept","text/html; charset=utf-8")] "" + `shouldRespondWith` "" {matchStatus = 200} + request "GET" "/" [("Accept","text/html; charset=latin1")] "" + `shouldRespondWith` "" {matchStatus = 406} + request "GET" "/" [("Accept","text/*; charset=utf-8")] "" + `shouldRespondWith` "" {matchStatus = 200} + + withApp (Rest.rest "/" Rest.defaultConfig { + contentTypesProvided = return [("text/html",text "")], + languagesProvided = return (Just ["en-gb", "de"]) + }) $ + it "makes sure we get a 406 when we don't provided the requested language" $ do + request "GET" "/" [] "" + `shouldRespondWith` "" {matchStatus = 200} + request "GET" "/" [("Accept-Language","en-gb")] "" + `shouldRespondWith` "" {matchStatus = 200} + request "GET" "/" [("Accept-Language","en-GB")] "" + `shouldRespondWith` "" {matchStatus = 200} + request "GET" "/" [("Accept-Language","en")] "" + `shouldRespondWith` "" {matchStatus = 200} + request "GET" "/" [("Accept-Language","en-US")] "" + `shouldRespondWith` "" {matchStatus = 406} + request "GET" "/" [("Accept-Language","de")] "" + `shouldRespondWith` "" {matchStatus = 200} + request "GET" "/" [("Accept-Language","de-DE")] "" + `shouldRespondWith` "" {matchStatus = 406} + request "GET" "/" [("Accept-Language","no")] "" + `shouldRespondWith` "" {matchStatus = 406} + request "GET" "/" [("Accept-Language","no-NB")] "" + `shouldRespondWith` "" {matchStatus = 406} + request "GET" "/" [("Accept-Language","*")] "" + `shouldRespondWith` "" {matchStatus = 200} + + withApp (Rest.rest "/" Rest.defaultConfig { + contentTypesProvided = return [("text/html",text "")], + charsetsProvided = return (Just ["utf-8"]) + }) $ + it "makes sure we get a 406 when we don't provided the requested charset" $ do + request "GET" "/" [] "" + `shouldRespondWith` "" {matchStatus = 200} + request "GET" "/" [("Accept-Charset","UTF-8")] "" + `shouldRespondWith` "" {matchStatus = 200} + request "GET" "/" [("Accept-Charset","utf-8")] "" + `shouldRespondWith` "" {matchStatus = 200} + request "GET" "/" [("Accept-Charset","ISO-8859-15")] "" + `shouldRespondWith` "" {matchStatus = 406} + + describe "409 Conflict" $ + withApp (Rest.rest "/" Rest.defaultConfig { + allowedMethods = return [PUT], + isConflict = return True, + contentTypesProvided = return [("text/plain",undefined)], + contentTypesAccepted = return [("text/plain",undefined)] + }) $ + it "makes sure we get a 409 when there is a conflict" $ + request "PUT" "/" [("Content-Type","text/plain"), ("Accept","text/plain")] "" + `shouldRespondWith` "" {matchStatus = 409} + + describe "410 Gone" $ + withApp (Rest.rest "/" Rest.defaultConfig { + resourceExists = return False, + previouslyExisted = return True, + allowedMethods = return [GET, POST, DELETE], + allowMissingPost = return False, + contentTypesProvided = return [("text/html",undefined)], + contentTypesAccepted = return [("application/json",undefined)] + }) $ + it "makes sure we get a 410 when resource does not exist, but did exist previously" $ do + request "GET" "/" [] "" `shouldRespondWith` "" {matchStatus = 410} + request "POST" "/" [("Content-Type","application/json")] "" `shouldRespondWith` "" {matchStatus = 410} + request "DELETE" "/" [] "" `shouldRespondWith` "" {matchStatus = 410} + + describe "415: Unsupported Media Type" $ do + withApp (Rest.rest "/" Rest.defaultConfig { + allowedMethods = return [POST] + }) $ + it "makes sure we get a 415 when POSTing to server that accepts nothing" $ + request "POST" "/" [("Content-Type","application/json")] "" `shouldRespondWith` "" {matchStatus = 415} + + withApp (Rest.rest "/" Rest.defaultConfig { + allowedMethods = return [POST], + contentTypesProvided = return [("text/html",undefined)], + contentTypesAccepted = return [("application/json",return Rest.Succeeded)] + }) $ + it "makes sure we get a 415 when POSTing with invalid content-type" $ + request "POST" "/" [("Content-Type","--")] "" `shouldRespondWith` "" {matchStatus = 415} + + describe "500 Internal Server Error" $ + withApp (Rest.rest "/" Rest.defaultConfig {serviceAvailable = raise $ stringError "XXX"}) $ + it "makes sure we get a 500 when throwing a string error" $ + request "GET" "/" [] "" `shouldRespondWith` 500 + + describe "501 Not Implemented" $ + withApp (Rest.rest "/" Rest.defaultConfig) $ + it "makes sure we get a 501 when using an unimplemented method" $ + request "CONNECT" "/" [] "" `shouldRespondWith` 501 + + describe "503 Not available" $ + withApp (Rest.rest "/" Rest.defaultConfig {serviceAvailable = return False}) $ + it "makes sure we get a 503 when serviceAvailable returns False" $ + request "GET" "/" [] "" `shouldRespondWith` 503 + + describe "Content negotiation" $ + withApp (Rest.rest "/" Rest.defaultConfig { + contentTypesProvided = return [("text/html",text "html"), ("application/json",json ("json" :: String))] + }) $ + it "makes sure we get the appropriate content" $ do + request "GET" "/" [] "" + `shouldRespondWith` "html" {matchStatus = 200} + request "GET" "/" [("Accept","*/*")] "" + `shouldRespondWith` "html" {matchStatus = 200} + request "GET" "/" [("Accept","application/*")] "" + `shouldRespondWith` "\"json\"" {matchStatus = 200} + request "GET" "/" [("Accept","application/json")] "" + `shouldRespondWith` "\"json\"" {matchStatus = 200} + request "GET" "/" [("Accept","text/plain")] "" + `shouldRespondWith` "" {matchStatus = 406} + request "GET" "/" [("Accept","text/html;q=0.5, application/json")] "" + `shouldRespondWith` "\"json\"" {matchStatus = 200} + request "GET" "/" [("Accept","text/html;q=0.5, application/json;q=0.4")] "" + `shouldRespondWith` "html" {matchStatus = 200} + + describe "Exceptions" $ + describe "Recovering from exceptions" $ + withApp (Rest.rest "/" Rest.defaultConfig { + contentTypesProvided = return [("text/html", raise (stringError "XXX") `rescue` (text . showError))] + }) $ + it "makes sure we can recover from a `raise`" $ + request "GET" "/" [] "" + `shouldRespondWith` "InternalServerError \"XXX\"" {matchStatus = 200} + + describe "Test servers" $ + describe "Echo server" $ + withApp (Rest.rest "/" Rest.defaultConfig { + contentTypesProvided = return [("text/plain",text "wtf")], + contentTypesAccepted = return [("text/plain",liftM (Rest.SucceededWithContent "text/plain" . cs) body)], + allowedMethods = return [POST] + }) $ + it "makes sure we can POST a text/plain body and get it back" $ + request "POST" "/" [("Content-Type","text/plain"), ("Accept","text/plain")] "hello" + `shouldRespondWith` "hello" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain"]} + + describe "Custom monad" $ + describe "Server using a custom monad" $ + (with . scottyAppT (`evalStateT` Nothing)) (Rest.rest "/" Rest.defaultConfig { + contentTypesProvided = return [("text/plain",text "wtf")], + contentTypesAccepted = return [("text/plain",liftM (Rest.SucceededWithContent "text/plain" . cs) body)], + allowedMethods = return [POST] + }) $ + it "makes sure we can POST a text/plain body and get it back" $ + request "POST" "/" [("Content-Type","text/plain"), ("Accept","text/plain")] "hello" + `shouldRespondWith` "hello" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain"]}