scotty-rest (empty) → 0.1.0.0
raw patch · 10 files changed
+1545/−0 lines, 10 filesdep +QuickCheckdep +basedep +base-preludesetup-changed
Dependencies added: QuickCheck, base, base-prelude, bytestring, convertible, data-default-class, hspec, hspec-wai, http-date, http-media, http-types, mtl, scotty, scotty-rest, string-conversions, text, time, transformers, wai, wai-extra
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- examples/Database.hs +67/−0
- examples/HelloWorld.hs +14/−0
- examples/Parameters.hs +15/−0
- scotty-rest.cabal +67/−0
- src/Web/Scotty/Rest.hs +524/−0
- src/Web/Scotty/Rest/Types.hs +234/−0
- test/Spec.hs +1/−0
- test/Web/ScottyRestSpec.hs +591/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/Database.hs view
@@ -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
+ examples/HelloWorld.hs view
@@ -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!")]+ }
+ examples/Parameters.hs view
@@ -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, ")]+ }
+ scotty-rest.cabal view
@@ -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
+ src/Web/Scotty/Rest.hs view
@@ -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
+ src/Web/Scotty/Rest/Types.hs view
@@ -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
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Web/ScottyRestSpec.hs view
@@ -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"]}