scotty-rest 0.1.0.0 → 0.2.0.0

raw patch · 8 files changed

+441/−272 lines, 8 filesdep +aesondep +sqlite-simpledep −data-default-classdep ~basedep ~http-mediadep ~http-typesnew-component:exe:database-examplenew-component:exe:hello-world-examplenew-component:exe:mutable-state-examplenew-component:exe:parameters-examplePVP ok

version bump matches the API change (PVP)

Dependencies added: aeson, sqlite-simple

Dependencies removed: data-default-class

Dependency ranges changed: base, http-media, http-types, mtl, scotty, text, time, transformers, wai, wai-extra

API changes (from Hackage documentation)

Files

• examples/Database.hs +3/−4
• examples/HelloWorld.hs +2/−2
• examples/MutableState.hs +23/−0
• examples/Parameters.hs +2/−2
• scotty-rest.cabal +72/−12
• src/Web/Scotty/Rest.hs +150/−106
• src/Web/Scotty/Rest/Types.hs +12/−35
• test/Web/ScottyRestSpec.hs +177/−111

@@ -1,12 +1,11 @@ {-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-} -module Database where+module Main where  import Control.Exception                    (SomeException, try) import Control.Monad.State-import Data.Aeson+import Data.Aeson                           hiding (json) import Data.Foldable import Data.Text.Lazy                       hiding (map) import Database.SQLite.Simple               hiding (fold)@@ -51,7 +50,7 @@         ("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+          json $ map (\(Only m) -> pack m `snoc` '\n') messages         )       ]     accepted = return [

@@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module HelloWorld where+module Main where  import Network.Wai.Middleware.RequestLogger import Web.Scotty.Rest@@ -10,5 +10,5 @@ main = scottyT 3000 id $ do   middleware logStdoutDev   rest "/" defaultConfig {-    contentTypesProvided = return [("text/html",html "Hello, World!")]+    contentTypesProvided = return [("text/html", html "Hello, World!")]   }

@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Monad.IO.Class (liftIO)+import Data.IORef+import Data.Text.Lazy (pack)+import Web.Scotty.Trans (scottyT, html)+import Web.Scotty.Rest++main :: IO ()+main = do+  ref <- newIORef (0 :: Int)+  scottyT 3000 id $ do+    rest "/" defaultConfig {+      contentTypesProvided = return [+        ("text/html", do liftIO (modifyIORef ref (+1))+                         count <- liftIO (readIORef ref)+                         let text = pack ("You are visitor number " ++ show count)+                         html text+        )+      ]+    }

@@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Parameters where+module Main where  import Data.Text.Lazy import Network.Wai.Middleware.RequestLogger@@ -11,5 +11,5 @@ main = scottyT 3000 id $ do   middleware logStdoutDev   rest "/:name" defaultConfig {-    contentTypesProvided = return [("text/html",param "name" >>= html . append "Hello, ")]+    contentTypesProvided = return [("text/html", param "name" >>= html . append "Hello, ")]   }

@@ -1,5 +1,5 @@ name:                scotty-rest-version:             0.1.0.0+version:             0.2.0.0 synopsis:            Webmachine-style REST library for scotty homepage:            http://github.com/ehamberg/scotty-rest license:             BSD3@@ -13,10 +13,9 @@ description:   Webmachine-like REST library for Scotty. -extra-source-files:-    examples/HelloWorld.hs-    examples/Parameters.hs-    examples/Database.hs+flag build-examples+  Description: Build the example servers+  Default:     False  library   exposed-modules:  Web.Scotty.Rest@@ -28,20 +27,81 @@                , 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+               , http-media         >= 0.6   && < 0.8+               , http-types         >= 0.9   && < 0.10                , mtl                >= 2.1   && < 2.3-               , scotty             >= 0.10  && < 0.11+               , scotty             >= 0.11  && < 0.12                , 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+               , time               >= 1.6   && < 1.9+               , transformers       >= 0.5   && < 0.6+               , wai                >= 3.2   && < 3.3                , wai-extra          >= 3.0   && < 3.1   default-language:    Haskell2010   GHC-options: -Wall++executable database-example+  main-is:          Database.hs+  hs-source-dirs:   examples+  default-language: Haskell2010+  GHC-options: -Wall+  if flag(build-examples)+    Buildable: True+  else+    Buildable: False+  build-depends: base+               , scotty-rest+               , aeson+               , mtl+               , sqlite-simple+               , scotty+               , text+               , wai-extra++executable hello-world-example+  main-is:          HelloWorld.hs+  hs-source-dirs:   examples+  default-language: Haskell2010+  GHC-options: -Wall+  if flag(build-examples)+    Buildable: True+  else+    Buildable: False+  build-depends: base+               , scotty-rest+               , scotty+               , wai-extra++executable parameters-example+  main-is:          Parameters.hs+  hs-source-dirs:   examples+  default-language: Haskell2010+  GHC-options: -Wall+  if flag(build-examples)+    Buildable: True+  else+    Buildable: False+  build-depends: base+               , scotty-rest+               , scotty+               , text+               , wai-extra++executable mutable-state-example+  main-is:          MutableState.hs+  hs-source-dirs:   examples+  default-language: Haskell2010+  GHC-options: -Wall+  if flag(build-examples)+    Buildable: True+  else+    Buildable: False+  build-depends: base+               , scotty-rest+               , scotty+               , text+               , wai-extra  test-suite spec   main-is:          Spec.hs

@@ -5,8 +5,10 @@  module Web.Scotty.Rest   (+  -- * REST monad transformer+    RestT   -- * REST handler to Scotty-    rest+  , rest   -- * Callback result types   , Authorized(..)   , DeleteResult(..)@@ -15,7 +17,7 @@   , ProcessingResult(..)   , Representation(..)   -- * Config-  , RestConfig(..)+  , EndpointConfig(..)   , defaultConfig   -- * Rest Exceptions   , RestException(..)@@ -25,17 +27,18 @@   , UTCTime   -- * Utilities   , toHttpDateHeader+  , requestMethod   ) where  import BasePrelude hiding (Handler)  import Web.Scotty.Rest.Types +import           Control.Monad             (void) import           Control.Monad.IO.Class    (MonadIO) import           Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import           Data.Convertible          (convert)-import           Data.Default.Class        (Default (..), def)-import           Data.String.Conversions   (convertString)+import           Data.String.Conversions   (cs) import qualified Data.Text.Lazy            as TL import           Data.Time.Calendar        (fromGregorian) import           Data.Time.Clock           (UTCTime (..), secondsToDiffTime)@@ -47,7 +50,7 @@ import qualified Network.Wai               as Wai import           Web.Scotty.Trans -type Config m = RestConfig (RestM m)+type Config m = EndpointConfig (RestT m)  -- | /rest/ is used where you would use e.g. 'get' in your Scotty app, and -- will match any method:@@ -55,49 +58,72 @@ -- > main = scotty 3000 $ do -- >   get  "/foo" (text "Hello!") -- >   rest "/bar" defaultConfig {--- >       contentTypesProvided = return [("text/html",html "Hello, World!")]+-- >       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)+rest route config = matchAny route (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!")]+-- >   contentTypesProvided = return [("text/html", html "Hello, World!")] -- > }-defaultConfig :: (MonadIO m) => Config m-defaultConfig = def+defaultConfig :: (Monad m) => Config m+defaultConfig = EndpointConfig {+                    allowedMethods       = return [GET, HEAD, OPTIONS]+                  , resourceExists       = return True+                  , previouslyExisted    = return False+                  , isConflict           = return False+                  , contentTypesAccepted = return []+                  , contentTypesProvided = return []+                  , languagesProvided    = return Nothing+                  , charsetsProvided     = return Nothing+                  , deleteResource       = return NotDeleted+                  , optionsHandler       = return Nothing+                  , generateEtag         = return Nothing+                  , expires              = return Nothing+                  , lastModified         = return Nothing+                  , malformedRequest     = return False+                  , isAuthorized         = return Authorized+                  , forbidden            = return False+                  , serviceAvailable     = return True+                  , allowMissingPost     = return True+                  , multipleChoices      = return UniqueRepresentation+                  , resourceMoved        = return NotMoved+                  , variances            = return []+                  } -preferred :: (MonadIO m) => Config m -> RestM m (MediaType, RestM m ())++preferred :: (Monad m) => Config m -> RestT m (MediaType, RestT 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+  -- 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"+  accept <- (cs . fromMaybe "*/*") <$> header "accept"   provided <- contentTypesProvided config   contentType <- maybe (raise NotAcceptable406) return (matchAccept (map fst provided) accept)   bestHandler <- maybe (raise NotAcceptable406) return (mapAccept provided accept)    return (contentType, bestHandler) -language :: (MonadIO m) => Config m -> RestM m (Maybe Language)+language :: (Monad m) => Config m -> RestT m (Maybe Language) language config = findPreferred config "accept-language" parse languagesProvided match-  where parse = parseAccept . convertString+  where parse = parseAccept . cs         match = flip matches -charset :: (MonadIO m) => Config m -> RestM m (Maybe TL.Text)+charset :: (Monad m) => Config m -> RestT m (Maybe TL.Text) charset config = findPreferred config "accept-charset" parse charsetsProvided match   where parse     = Just         match a b = TL.toCaseFold a == TL.toCaseFold b -findPreferred :: (MonadIO m) => Config m+findPreferred :: (Monad m) => Config m               -> TL.Text               -> (TL.Text -> Maybe a)-              -> (Config m -> RestM m (Maybe [a]))+              -> (Config m -> RestT m (Maybe [a]))               -> (a -> a -> Bool)-              -> RestM m (Maybe a)+              -> RestT 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@@ -107,10 +133,10 @@   headerAndConfig <- runMaybeT $ do       accept  <- MaybeT (header headerName)       provide <- MaybeT (provided config)-      return (accept,provide)+      return (accept, provide)   case headerAndConfig of        Nothing    -> return Nothing-       Just (a,p) -> do+       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:@@ -122,22 +148,20 @@   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+checkRequestMethod :: (Monad m) => RestT m ()+checkRequestMethod = do+  method <- requestMethod+  unless (method `elem` [GET, HEAD, POST, PUT, PATCH, DELETE, OPTIONS]) (raise NotImplemented501) -restHandlerStart :: (MonadIO m) => Config m -> RestM m ()+restHandlerStart :: (Monad m) => Config m -> RestT m () restHandlerStart config = do   -- Is our service available?   available <- serviceAvailable config   unless available (raise ServiceUnavailable503)    -- Is the method known?+  checkRequestMethod+   method <- requestMethod    -- TODO: Is the URI too long?@@ -155,7 +179,8 @@   -- Is the client authorized?   isAuthorized config >>= \case        Authorized                -> return ()-       (NotAuthorized challenge) -> setHeader "WWW-Authenticate" challenge >> raise Unauthorized401+       (NotAuthorized challenge) -> do setHeader "WWW-Authenticate" challenge+                                       raise Unauthorized401    -- Is the client forbidden to access this resource?   isForbidden <- forbidden config@@ -168,56 +193,56 @@      then handleOptions config      else contentNegotiationStart config -setAllowHeader :: (MonadIO m) => Config m -> RestM m ()+setAllowHeader :: (Monad m) => Config m -> RestT m () setAllowHeader config= do   allowed <- allowedMethods config-  setHeader "allow" . TL.intercalate ", " . map (convertString . show) $ allowed+  setHeader "Allow" . TL.intercalate ", " . map (cs . show) $ allowed  ---------------------------------------------------------------------------------------------------- -- OPTIONS ---------------------------------------------------------------------------------------------------- -handleOptions :: (MonadIO m) => Config m -> RestM m ()+handleOptions :: (Monad m) => Config m -> RestT m () handleOptions config = optionsHandler config >>= \case-  Nothing                      -> setAllowHeader config-  (Just (contentType,handler)) -> handler >> setContentTypeHeader contentType+  Nothing                       -> setAllowHeader config+  (Just (contentType, handler)) -> handler >> setContentTypeHeader contentType  ---------------------------------------------------------------------------------------------------- -- Content negotiation ---------------------------------------------------------------------------------------------------- -contentNegotiationStart :: (MonadIO m) => Config m -> RestM m ()+contentNegotiationStart :: (Monad m) => Config m -> RestT m () contentNegotiationStart = contentNegotiationAccept -contentNegotiationAccept :: (MonadIO m) => Config m -> RestM m ()+contentNegotiationAccept :: (Monad m) => Config m -> RestT m () contentNegotiationAccept config = do   accept <- header "accept"   -- evalute `preferred` to force early 406 (Not acceptable):-  when (isJust accept) (preferred config >> return ())+  when (isJust accept) $ void (preferred config)   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 :: (Monad m) => Config m -> RestT m () contentNegotiationAcceptLanguage config = do   acceptLanguage <- header "accept-language"   -- evalute `language` to force early 406 (Not acceptable):-  when (isJust acceptLanguage) (language config >> return ())+  when (isJust acceptLanguage) $ void (language config)   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 :: (Monad m) => Config m -> RestT m () contentNegotiationAcceptCharSet config = do   acceptCharset <- header "accept-charset"   -- evalute `charset` to force early 406 (Not acceptable):-  when (isJust acceptCharset) (charset config >> return ())+  when (isJust acceptCharset) $ void (charset config)   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 :: (Monad m) => Config m -> RestT m () contentNegotiationVariances config = do   ctp <- contentTypesProvided config   lp  <- languagesProvided config@@ -226,13 +251,13 @@   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'''+  unless (null varyHeader''') $ setHeader "Vary" . TL.intercalate ", " $ varyHeader'''   checkResourceExists config -checkResourceExists :: (MonadIO m) => Config m -> RestM m ()+checkResourceExists :: (Monad m) => Config m -> RestT m () checkResourceExists config = do-  method <- requestMethod   exists <- resourceExists config+  method <- requestMethod   if | method `elem` [GET, HEAD]        -> if exists                                               then handleGetHeadExisting config                                               else handleGetHeadNonExisting config@@ -247,70 +272,74 @@ -- GET/HEAD ---------------------------------------------------------------------------------------------------- -handleGetHeadExisting :: (MonadIO m) => Config m -> RestM m ()+handleGetHeadExisting :: (Monad m) => Config m -> RestT m () handleGetHeadExisting config = do   cond config   addCacheHeaders config   method <- requestMethod-  (contentType,handler) <- preferred config+  (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+    MultipleRepresentations t' c' -> do writeContent t' c'+                                        status multipleChoices300+    MultipleWithPreferred t' c' u -> do writeContent t' c'+                                        setHeader "Location" u+                                        status multipleChoices300     UniqueRepresentation          -> do when (method == GET) handler                                         setContentTypeHeader contentType                                         status ok200 -handleGetHeadNonExisting :: (MonadIO m) => Config m -> RestM m ()+handleGetHeadNonExisting :: (Monad m) => Config m -> RestT m () handleGetHeadNonExisting = handleNonExisting -checkMoved :: (MonadIO m) => Config m -> RestM m ()+checkMoved :: (Monad m) => Config m -> RestT m () checkMoved config = resourceMoved config >>= \case   NotMoved               -> return ()-  (MovedPermanently url) -> setHeader "location" url >> raise MovedPermanently301-  (MovedTemporarily url) -> setHeader "location" url >> raise MovedTemporarily307+  (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 :: (Monad m) => Config m -> RestT 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]+  hasIfMatchHeader <- isJust <$> header "if-match"+  when hasIfMatchHeader (raise PreconditionFailed412)+  ifMethodIn [POST, PATCH]     (ppppreviouslyExisted config)     (pppmethodIsPut config) -ppppreviouslyExisted :: (MonadIO m) => Config m -> RestM m ()+ppppreviouslyExisted :: (Monad m) => Config m -> RestT m () ppppreviouslyExisted config = do   existed <- previouslyExisted config   if existed      then pppmovedPermanentlyOrTemporarily config      else pppmethodIsPost config -pppmovedPermanentlyOrTemporarily :: (MonadIO m) => Config m -> RestM m ()+pppmovedPermanentlyOrTemporarily :: (Monad m) => Config m -> RestT m () pppmovedPermanentlyOrTemporarily config = do   checkMoved config-  ifMethodIs [POST]+  ifMethodIn [POST]     (allowsMissingPost config (acceptResource config) (raise Gone410))     (pppmethodIsPut config) -pppmethodIsPost :: (MonadIO m) => Config m -> RestM m ()+pppmethodIsPost :: (Monad m) => Config m -> RestT m () pppmethodIsPost config =-  ifMethodIs [POST]+  ifMethodIn [POST]     (allowsMissingPost config (pppmethodIsPut config) (raise NotFound404))     (raise NotFound404) -pppmethodIsPut :: (MonadIO m) => Config m -> RestM m ()+pppmethodIsPut :: (Monad m) => Config m -> RestT m () pppmethodIsPut config = do   method <- requestMethod-  when (method == PUT) $ do+  when (method == PUT || method == PATCH) $ do     conflict <- isConflict config     when conflict (raise Conflict409)    acceptResource config -handlePutPostPatchExisting :: (MonadIO m) => Config m -> RestM m ()+handlePutPostPatchExisting :: (Monad m) => Config m -> RestT m () handlePutPostPatchExisting config = do   cond config   pppmethodIsPut config@@ -319,11 +348,11 @@ -- POST/PUT/PATCH, part 2: content-types accepted ---------------------------------------------------------------------------------------------------- -acceptResource :: (MonadIO m) => Config m -> RestM m ()+acceptResource :: (Monad m) => Config m -> RestT m () acceptResource config = do   -- Is there a Content-Type header?-  contentTypeHeader <- header "content-type"-  contentType <- maybe (raise UnsupportedMediaType415) (return . convertString) contentTypeHeader+  contentTypeHeader <- header "Content-Type"+  contentType <- maybe (raise UnsupportedMediaType415) (return . cs) contentTypeHeader    -- Do we have a handler for this content type? If so, run it. Alternatively, return 415.   handlers <- contentTypesAccepted config@@ -340,25 +369,30 @@        (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+    where locationAndResponseCode url response = setHeader "Location" url >> status response -writeContent :: (MonadIO m) => MediaType -> TL.Text -> RestM m ()+writeContent :: (Monad m) => MediaType -> TL.Text -> RestT m () writeContent t c = do   method <- requestMethod   setContentTypeHeader t-  when (method /= HEAD) ((raw . convertString) c)+  when (method /= HEAD) ((raw . cs) c) -resourceWithContent :: (MonadIO m) => Config m -> MediaType -> TL.Text -> RestM m ()+resourceWithContent :: (Monad m) => Config m -> MediaType -> TL.Text -> RestT 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+  UniqueRepresentation          -> do setContentTypeHeader t+                                      (raw . cs) c+                                      status ok200+  MultipleRepresentations t' c' -> do writeContent t' c'+                                      status multipleChoices300+  MultipleWithPreferred t' c' u -> do writeContent t' c'+                                      setHeader "Location" u+                                      status multipleChoices300  ---------------------------------------------------------------------------------------------------- -- DELETE ---------------------------------------------------------------------------------------------------- -handleDeleteExisting :: (MonadIO m) => Config m -> RestM m ()+handleDeleteExisting :: (Monad m) => Config m -> RestT m () handleDeleteExisting config = do   cond config   result <- deleteResource config@@ -368,40 +402,40 @@        (DeletedWithResponse t c) -> resourceWithContent config t c        NotDeleted                -> raise (InternalServerError "Deleting existing resource failed") -handleDeleteNonExisting :: (MonadIO m) => Config m -> RestM m ()+handleDeleteNonExisting :: (Monad m) => Config m -> RestT m () handleDeleteNonExisting = handleNonExisting  ---------------------------------------------------------------------------------------------------- -- Conditional requests ---------------------------------------------------------------------------------------------------- -cond :: (MonadIO m) => Config m -> RestM m ()+cond :: (Monad m) => Config m -> RestT m () cond = condIfMatch -condIfMatch :: (MonadIO m) => Config m -> RestM m ()+condIfMatch :: (Monad m) => Config m -> RestT m () condIfMatch config = header "if-match" >>= \case   Nothing  -> condIfUnmodifiedSince config   Just hdr -> ifEtagMatches config hdr                 (condIfUnmodifiedSince config)                 (addEtagHeader config >> raise PreconditionFailed412) -condIfUnmodifiedSince :: (MonadIO m) => Config m -> RestM m ()+condIfUnmodifiedSince :: (Monad m) => Config m -> RestT 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 :: (Monad m) => Config m -> RestT m () condIfNoneMatch config = header "if-none-match" >>= \case   Nothing  -> condIfModifiedSince config   Just hdr -> ifEtagMatches config hdr                 match                 (condIfModifiedSince config)-    where match = ifMethodIs [GET, HEAD]+    where match = ifMethodIn [GET, HEAD]                    (notModified config)                    (addEtagHeader config >> raise PreconditionFailed412) -condIfModifiedSince :: (MonadIO m) => Config m -> RestM m ()+condIfModifiedSince :: (Monad m) => Config m -> RestT m () condIfModifiedSince config = modifiedSinceHeaderDate config "if-modified-since" >>= \case        Nothing    -> return ()        Just False -> notModified config@@ -411,44 +445,45 @@ -- Helpers ---------------------------------------------------------------------------------------------------- -addCacheHeaders :: (MonadIO m) => Config m -> RestM m ()+addCacheHeaders :: (Monad m) => Config m -> RestT m () addCacheHeaders config = do   addEtagHeader config   addLastModifiedHeader config   addExpiresHeader config -notModified :: (MonadIO m) => Config m -> RestM m ()+notModified :: (Monad m) => Config m -> RestT m () notModified config = do   addCacheHeaders config   raise NotModified304 -addEtagHeader :: (MonadIO m) => Config m -> RestM m ()+addEtagHeader :: (Monad m) => Config m -> RestT m () addEtagHeader config = generateEtag config >>= \case     Nothing         -> return ()-    Just (Weak t)   -> setHeader "etag" ("W/\"" <> t <> "\"")-    Just (Strong t) -> setHeader "etag" ("\"" <> t <> "\"")+    Just (Weak t)   -> setHeader "Etag" ("W/\"" <> t <> "\"")+    Just (Strong t) -> setHeader "Etag" ("\"" <> t <> "\"") -addLastModifiedHeader :: (MonadIO m) => Config m -> RestM m ()+addLastModifiedHeader :: (Monad m) => Config m -> RestT m () addLastModifiedHeader config = lastModified config >>= \case     Nothing -> return ()-    Just t  -> setHeader "last-modified" (toHttpDateHeader t)+    Just t  -> setHeader "Last-Modified" (toHttpDateHeader t) -addExpiresHeader :: (MonadIO m) => Config m -> RestM m ()+addExpiresHeader :: (Monad m) => Config m -> RestT m () addExpiresHeader config = expires config >>= \case     Nothing  -> return ()-    Just t   -> setHeader "expires" (toHttpDateHeader t)+    Just t   -> setHeader "Expires" (toHttpDateHeader t) -modifiedSinceHeaderDate :: (MonadIO m) => Config m -> TL.Text -> RestM m (Maybe Bool)+modifiedSinceHeaderDate :: (Monad m) => Config m -> TL.Text -> RestT m (Maybe Bool) modifiedSinceHeaderDate config hdr = runMaybeT $ do     modDate    <- MaybeT (lastModified config)     headerText <- MaybeT (header hdr)     headerDate <- MaybeT (return (parseHeaderDate headerText))     return (modDate > headerDate) -handleNonExisting :: (MonadIO m) => Config m -> RestM m ()+handleNonExisting :: (Monad m) => Config m -> RestT 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)+  hasIfMatchHeader <- isJust <$> header "if-match"+  when hasIfMatchHeader (raise PreconditionFailed412)    -- Did this resource exist before?   existed <- previouslyExisted config@@ -457,24 +492,24 @@   checkMoved config   raise Gone410 -setContentTypeHeader :: (MonadIO m) => MediaType -> RestM m ()-setContentTypeHeader = setHeader "content-type" . convertString . renderHeader+setContentTypeHeader :: (Monad m) => MediaType -> RestT m ()+setContentTypeHeader = setHeader "Content-Type" . cs . renderHeader -ifMethodIs :: (MonadIO m) => [StdMethod] -> RestM m () -> RestM m () -> RestM m ()-ifMethodIs ms onTrue onFalse = do+ifMethodIn :: (Monad m) => [StdMethod] -> RestT m () -> RestT m () -> RestT m ()+ifMethodIn ms onTrue onFalse = do   method <- requestMethod   if method `elem` ms      then onTrue      else onFalse -allowsMissingPost :: (MonadIO m) => Config m -> RestM m () -> RestM m () -> RestM m ()+allowsMissingPost :: (Monad m) => Config m -> RestT m () -> RestT m () -> RestT m () allowsMissingPost config onTrue onFalse = do   allowed <- allowMissingPost config   if allowed      then onTrue      else onFalse -ifEtagMatches :: (MonadIO m) => Config m -> TL.Text -> RestM m () -> RestM m () -> RestM m ()+ifEtagMatches :: (Monad m) => Config m -> TL.Text -> RestT m () -> RestT m () -> RestT m () ifEtagMatches _      "*"   onTrue _       = onTrue ifEtagMatches config given onTrue onFalse = do   tag <- generateEtag config@@ -490,7 +525,7 @@  parseHeaderDate :: TL.Text -> Maybe UTCTime parseHeaderDate hdr = do-  headerDate <- (parseHTTPDate . convertString) hdr+  headerDate <- (parseHTTPDate . cs) hdr   let year = (fromIntegral . hdYear) headerDate       mon  = hdMonth headerDate       day  = hdDay headerDate@@ -503,9 +538,18 @@  -- | 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+toHttpDateHeader = cs . formatHTTPDate . epochTimeToHTTPDate . convert -handleExcept :: (Monad m) => RestException -> RestM m ()+-- | Returns the method used for the current request, e.g. /POST/.+requestMethod :: (Monad m) => RestT m StdMethod+requestMethod = do+  req <- request+  case (parseMethod . Wai.requestMethod) req of+    Right method -> return method+    Left method  -> raise (InternalServerError ("Parsing method " <> cs method <> " failed"))+++handleExcept :: (Monad m) => RestException -> RestT m () handleExcept MovedPermanently301     = status movedPermanently301 handleExcept NotModified304          = status notModified304 handleExcept MovedTemporarily307     = status temporaryRedirect307

@@ -1,10 +1,11 @@ {-# LANGUAGE LambdaCase        #-} {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes        #-}  module Web.Scotty.Rest.Types   (-    RestM+    RestT   -- * Callbacks result types   , Authorized(..)   , DeleteResult(..)@@ -12,7 +13,7 @@   , Moved(..)   , ProcessingResult(..)   , Representation (..)-  , RestConfig(..)+  , EndpointConfig(..)   , RestException(..)   , Url   -- * Re-exports@@ -23,15 +24,13 @@  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+type RestT m = ActionT RestException m  -- | A URL. type Url = TL.Text@@ -89,9 +88,9 @@  -- | 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+data EndpointConfig m = EndpointConfig   { allowedMethods       :: m [StdMethod]-  -- ^ List of allowed methos.+  -- ^ List of allowed methods.   --   -- Default: @[GET, HEAD, OPTIONS]@   , resourceExists       :: m Bool@@ -103,7 +102,7 @@   --   -- Default: 'False'   , isConflict           :: m Bool-  -- ^ Only for `PUT` requests. Does this request result in a conflict?+  -- ^ For `PUT`/`PATCH` requests: Does this request result in a conflict?   --   -- Default: 'False'   , contentTypesAccepted :: m [(MediaType, m ProcessingResult)]@@ -113,7 +112,8 @@   -- Default: @[]@   , contentTypesProvided :: m [(MediaType, m ())]   -- ^ A list of the content types /provided/, together with handlers producing a response body for-  -- that 'MediaType'.+  -- that 'MediaType'. The first one that matches the `Accept` header passed by the client will be+  -- chosen, which could make a difference e.g. with `Accept: */*` or `Accept: audio/*`.   --   -- Default: @[]@   , languagesProvided    :: m (Maybe [Language])@@ -187,30 +187,6 @@   -- 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@@ -227,8 +203,9 @@                    | ServiceUnavailable503                    | MethodNotAllowed405                    | InternalServerError TL.Text-                   deriving (Show, Eq)+                   deriving (Show)  instance ScottyError RestException where   stringError = InternalServerError . TL.pack-  showError = fromString . show+  showError (InternalServerError message) = "Internal server error: " <> message+  showError err = (fromString . show) err

@@ -9,11 +9,10 @@ import Test.Hspec.Wai.Internal import Test.QuickCheck         (Arbitrary, arbitrary, elements, property) -import           Web.Scotty.Rest  (RestConfig (..), StdMethod (..))+import           Web.Scotty.Rest  (EndpointConfig(..), 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)@@ -30,13 +29,21 @@   let withApp = with . scottyAppT id    describe "Conditional requests" $ do-    describe "If-Match" $+    describe "If-Match" $ do       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+          request "DELETE" "/" [("if-match", "")] "" `shouldRespondWith` 412 +      withApp (Rest.rest "/" Rest.defaultConfig {+                allowedMethods = return [POST],+                resourceExists = return False+              }) $+        it "makes sure we get a 412 Precondition Failed for POST to non-existing" $ do+          request "POST" "/" [("if-match", "\"foo\", \"bar\"")] ""+            `shouldRespondWith` 412+     describe "If-None-Match" $ do       withApp (Rest.rest "/" Rest.defaultConfig {                 allowedMethods = return [DELETE],@@ -44,95 +51,104 @@               }) $         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\"")] ""+          request "DELETE" "/" [("if-none-match", "\"foo\"")] ""             `shouldRespondWith` 412 {matchHeaders = expectedHeaders}        withApp (Rest.rest "/" Rest.defaultConfig {                 allowedMethods = return [DELETE],+                generateEtag = return (Just (Rest.Weak "foo"))+              }) $+        it "makes sure we get a 412 Precondition Failed for DELETE when weak e-tag matches" $ do+          let expectedHeaders = ["Etag" <:> "W/\"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\"")] ""+          request "DELETE" "/" [("if-none-match", "\"foo\", \"bar\"")] ""             `shouldRespondWith` 412 {matchHeaders = expectedHeaders}        withApp (Rest.rest "/" Rest.defaultConfig {-                contentTypesProvided = return [("text/html",text "foo")],+                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\"")] ""+          request "GET" "/" [("if-none-match", "\"bar\"")] ""             `shouldRespondWith` 200 {matchHeaders = expectedHeaders}        withApp (Rest.rest "/" Rest.defaultConfig {-                contentTypesProvided = return [("text/html",undefined)],+                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\"")] ""+          request "GET" "/" [("if-none-match", "\"foo\"")] ""             `shouldRespondWith` 304 {matchHeaders = expectedHeaders}        withApp (Rest.rest "/" Rest.defaultConfig {-                contentTypesProvided = return [("text/html",undefined)],+                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\"")] ""+          request "GET" "/" [("if-none-match", "\"foo\", \"bar\"")] ""             `shouldRespondWith` 304 {matchHeaders = expectedHeaders}        withApp (Rest.rest "/" Rest.defaultConfig {-                contentTypesProvided = return [("text/html",text "foo")],+                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","*")] ""+          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","*")] ""+          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)],+                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")] ""+          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)],+                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")] ""+          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")]+                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")]+                contentTypesProvided = return [("text/html", text "hello")]               , generateEtag = return (Just (Rest.Weak "foo"))               }) $         it "makes sure we get a (weak) ETag header" $@@ -141,7 +157,7 @@     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")]+                contentTypesProvided = return [("text/html", text "hello")]               , expires = return (Just now)               }) $         it "makes sure we get an Expires header" $ do@@ -151,7 +167,7 @@     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")]+                contentTypesProvided = return [("text/html", text "hello")]               , lastModified = return (Just time)               }) $         it "makes sure we get a Last-Modified header" $ do@@ -171,7 +187,7 @@           request "OPTIONS" "/" [] "" `shouldRespondWith` "" {matchHeaders = expectedHeaders}      describe "Custom OPTIONS handler" $-      withApp (Rest.rest "/" Rest.defaultConfig {optionsHandler = return (Just ("text/plain",text "xyz"))}) $+      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"]}@@ -202,72 +218,84 @@     describe "200: Created with content" $       withApp (Rest.rest "/" Rest.defaultConfig {           allowedMethods = return [POST],-          contentTypesProvided = return [("text/html",undefined)],+          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")] ""+          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)],+          contentTypesProvided = return [("text/html", undefined)],           contentTypesAccepted = return [-            ("text/plain",return (Rest.SucceededWithLocation "foo.bar"))+            ("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")] ""+          request "POST" "/" [("Content-Type", "text/plain")] ""             `shouldRespondWith` "" {matchStatus = 201, matchHeaders = expectedHeaders}        withApp (Rest.rest "/" Rest.defaultConfig {+          allowedMethods = return [PUT],+          resourceExists = return False,+          contentTypesProvided = return [("text/html", undefined)],+          contentTypesAccepted = return [+            ("text/plain", return Rest.Succeeded)+          ]+        }) $+        it "makes sure we get a 201 on PUT to non-existing when handler returns Succeeded" $ do+          request "PUT" "/" [("Content-Type", "text/plain")] ""+            `shouldRespondWith` "" {matchStatus = 201}++      withApp (Rest.rest "/" Rest.defaultConfig {           allowedMethods = return [POST],           resourceExists = return False,-          contentTypesProvided = return [("text/html",undefined)],+          contentTypesProvided = return [("text/html", undefined)],           contentTypesAccepted = return [-            ("text/plain",return (Rest.SucceededWithContent "text/plain" "foo"))+            ("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")] ""+          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)]+          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")] ""+          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)]+          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")] ""+          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)]+          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}+          request "POST" "/" [("Content-Type", "application/json")] "" `shouldRespondWith` "" {matchStatus = 204}      describe "404: POSTint to never-existed" $       withApp (Rest.rest "/" Rest.defaultConfig {@@ -275,11 +303,11 @@           resourceExists = return False,           previouslyExisted = return False,           allowMissingPost = return False,-          contentTypesProvided = return [("text/html",undefined)],-          contentTypesAccepted = return [("application/json",return Rest.Succeeded)]+          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}+          request "POST" "/" [("Content-Type", "application/json")] "" `shouldRespondWith` "" {matchStatus = 404}    describe "HTTP (PATCH)" $     describe "404: PATCHing a never-existed" $@@ -287,24 +315,32 @@           allowedMethods = return [PATCH],           resourceExists = return False,           previouslyExisted = return False,-          contentTypesProvided = return [("text/html",undefined)],-          contentTypesAccepted = return [("application/json",return Rest.Succeeded)]+          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}+          request "PATCH" "/" [("Content-Type", "application/json")] "" `shouldRespondWith` "" {matchStatus = 404}    describe "HTTP (Vary)" $ do-    describe "Multiple content types provided" $+    describe "Multiple content types provided" $ do       withApp (Rest.rest "/" Rest.defaultConfig {-          contentTypesProvided = return [("text/plain",text "foo"),("text/html",undefined)]+          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} +      withApp (Rest.rest "/" Rest.defaultConfig {+          contentTypesProvided = return [("text/plain", text "foo"), ("text/html", undefined)]+        , languagesProvided = return (Just ["en", "fr"])+        }) $+        it "makes sure the Vary header also includes `Accept-Langauge` when offering several languages" $ do+          let expectedHeaders = ["Vary" <:> "Accept-Language, Accept"]+          request "GET" "/" [] "" `shouldRespondWith` "foo" {matchStatus = 200, matchHeaders = expectedHeaders}+     describe "Multiple languages provided" $       withApp (Rest.rest "/" Rest.defaultConfig {-          contentTypesProvided = return [("text/plain",text "foo")],+          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@@ -313,7 +349,7 @@      describe "Multiple charsets provided" $       withApp (Rest.rest "/" Rest.defaultConfig {-          contentTypesProvided = return [("text/plain",text "foo")],+          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@@ -321,9 +357,18 @@           request "GET" "/" [] "" `shouldRespondWith` "foo" {matchStatus = 200, matchHeaders = expectedHeaders}    describe "HTTP (General)" $ do+    describe "Authorized" $ do+      withApp (Rest.rest "/" Rest.defaultConfig {+          contentTypesProvided = return [("text/html", text "xxx")],+          isAuthorized = return Rest.Authorized+        }) $+        it "makes sure we get a resource when we are authorized" $ do+          request "GET" "/" [] ""+            `shouldRespondWith` "xxx" {matchStatus = 200}+     describe "300: Multiple Representations" $ do       withApp (Rest.rest "/" Rest.defaultConfig {-          contentTypesProvided = return [("text/html",text "xxx")],+          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@@ -332,7 +377,7 @@             `shouldRespondWith` "foo" {matchStatus = 300, matchHeaders = expectedHeaders}        withApp (Rest.rest "/" Rest.defaultConfig {-          contentTypesProvided = return [("text/html",text "xxx")],+          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@@ -342,32 +387,41 @@        withApp (Rest.rest "/" Rest.defaultConfig {           allowedMethods = return [PUT],-          contentTypesProvided = return [("text/html",undefined)],-          contentTypesAccepted = return [("application/json",return (Rest.SucceededWithContent "text/plain" "xxx"))],+          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")] ""+          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"))],+          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")] ""+          request "POST" "/" [("Content-Type", "application/json")] ""             `shouldRespondWith` "foo" {matchStatus = 300, matchHeaders = expectedHeaders} +      withApp (Rest.rest "/" Rest.defaultConfig {+          allowedMethods = return [GET],+          contentTypesProvided = return [("text/html", undefined)],+          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 "GET" "/" [] "" `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)]+          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"]}@@ -377,7 +431,7 @@           resourceExists = return False,           previouslyExisted = return True,           resourceMoved = return (Rest.MovedTemporarily "xxx"),-          contentTypesProvided = return [("text/html",undefined)]+          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"]}@@ -411,7 +465,7 @@     describe "404 Not Found" $       withApp (Rest.rest "/" Rest.defaultConfig {           resourceExists = return False,-          contentTypesProvided = return [("text/html",undefined)]+          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}@@ -419,81 +473,83 @@     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")] ""+          request "GET" "/" [("Accept", "text/html")] ""             `shouldRespondWith` "" {matchStatus = 406}        withApp (Rest.rest "/" Rest.defaultConfig {-        contentTypesProvided = return [("text/html",text "")]+        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")] ""+          request "GET" "/" [("Accept", "text/html; charset=utf-8")] ""             `shouldRespondWith` "" {matchStatus = 406}-          request "GET" "/" [("Accept","text/plain")] ""+          request "GET" "/" [("Accept", "text/plain")] ""             `shouldRespondWith` "" {matchStatus = 406}        withApp (Rest.rest "/" Rest.defaultConfig {-        contentTypesProvided = return [("text/html; charset=utf-8",text "")]+        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","*/*")] ""+          request "GET" "/" [("Accept", "*/*")] ""             `shouldRespondWith` "" {matchStatus = 200}-          request "GET" "/" [("Accept","text/html; charset=utf-8")] ""+          request "GET" "/" [("Accept", "text/html; charset=utf-8")] ""             `shouldRespondWith` "" {matchStatus = 200}-          request "GET" "/" [("Accept","text/html; charset=latin1")] ""+          request "GET" "/" [("Accept", "text/html; charset=latin1")] ""             `shouldRespondWith` "" {matchStatus = 406}-          request "GET" "/" [("Accept","text/*; charset=utf-8")] ""+          request "GET" "/" [("Accept", "text/*; charset=utf-8")] ""             `shouldRespondWith` "" {matchStatus = 200}        withApp (Rest.rest "/" Rest.defaultConfig {-        contentTypesProvided = return [("text/html",text "")],+        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")] ""+          request "GET" "/" [("Accept-Language", "en-gb")] ""             `shouldRespondWith` "" {matchStatus = 200}-          request "GET" "/" [("Accept-Language","en-GB")] ""+          request "GET" "/" [("Accept-Language", "en-GB")] ""             `shouldRespondWith` "" {matchStatus = 200}-          request "GET" "/" [("Accept-Language","en")] ""+          request "GET" "/" [("Accept-Language", "en")] ""             `shouldRespondWith` "" {matchStatus = 200}-          request "GET" "/" [("Accept-Language","en-US")] ""+          request "GET" "/" [("Accept-Language", "en-US")] ""             `shouldRespondWith` "" {matchStatus = 406}-          request "GET" "/" [("Accept-Language","de")] ""+          request "GET" "/" [("Accept-Language", "de")] ""             `shouldRespondWith` "" {matchStatus = 200}-          request "GET" "/" [("Accept-Language","de-DE")] ""+          request "GET" "/" [("Accept-Language", "de-DE")] ""             `shouldRespondWith` "" {matchStatus = 406}-          request "GET" "/" [("Accept-Language","no")] ""+          request "GET" "/" [("Accept-Language", "no")] ""             `shouldRespondWith` "" {matchStatus = 406}-          request "GET" "/" [("Accept-Language","no-NB")] ""+          request "GET" "/" [("Accept-Language", "no-NB")] ""             `shouldRespondWith` "" {matchStatus = 406}-          request "GET" "/" [("Accept-Language","*")] ""+          request "GET" "/" [("Accept-Language", "*")] ""             `shouldRespondWith` "" {matchStatus = 200}        withApp (Rest.rest "/" Rest.defaultConfig {-        contentTypesProvided = return [("text/html",text "")],+        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")] ""+          request "GET" "/" [("Accept-Charset", "UTF-8")] ""             `shouldRespondWith` "" {matchStatus = 200}-          request "GET" "/" [("Accept-Charset","utf-8")] ""+          request "GET" "/" [("Accept-Charset", "utf-8")] ""             `shouldRespondWith` "" {matchStatus = 200}-          request "GET" "/" [("Accept-Charset","ISO-8859-15")] ""+          request "GET" "/" [("Accept-Charset", "ISO-8859-15")] ""             `shouldRespondWith` "" {matchStatus = 406}      describe "409 Conflict" $       withApp (Rest.rest "/" Rest.defaultConfig {-          allowedMethods = return [PUT],+          allowedMethods = return [PUT, PATCH],           isConflict = return True,-          contentTypesProvided = return [("text/plain",undefined)],-          contentTypesAccepted = return [("text/plain",undefined)]+          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")] ""+        it "makes sure we get a 409 when there is a conflict" $ do+          request "PUT" "/" [("Content-Type", "text/plain"), ("Accept", "text/plain")] ""             `shouldRespondWith` "" {matchStatus = 409}+          request "PATCH" "/" [("Content-Type", "text/plain"), ("Accept", "text/plain")] ""+            `shouldRespondWith` "" {matchStatus = 409}      describe "410 Gone" $       withApp (Rest.rest "/" Rest.defaultConfig {@@ -501,12 +557,12 @@           previouslyExisted = return True,           allowedMethods = return [GET, POST, DELETE],           allowMissingPost = return False,-          contentTypesProvided = return [("text/html",undefined)],-          contentTypesAccepted = return [("application/json",undefined)]+          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 "POST" "/" [("Content-Type", "application/json")] "" `shouldRespondWith` "" {matchStatus = 410}           request "DELETE" "/" [] "" `shouldRespondWith` "" {matchStatus = 410}      describe "415: Unsupported Media Type" $ do@@ -514,16 +570,26 @@           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}+          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)]+          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}+          request "POST" "/" [("Content-Type", "--")] "" `shouldRespondWith` "" {matchStatus = 415} +      withApp (Rest.rest "/" Rest.defaultConfig {+          allowedMethods = return [POST],+          contentTypesProvided = return [("text/html", undefined)],+          contentTypesAccepted = return [("text/plain", undefined)]+        }) $+        it "makes sure we get a 415 when POSTing with no content-type header" $ do+          request "POST" "/" [] ""+            `shouldRespondWith` 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" $@@ -541,22 +607,22 @@      describe "Content negotiation" $       withApp (Rest.rest "/" Rest.defaultConfig {-        contentTypesProvided = return [("text/html",text "html"), ("application/json",json ("json" :: String))]+        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","*/*")] ""+          request "GET" "/" [("Accept", "*/*")] ""             `shouldRespondWith` "html" {matchStatus = 200}-          request "GET" "/" [("Accept","application/*")] ""+          request "GET" "/" [("Accept", "application/*")] ""             `shouldRespondWith` "\"json\"" {matchStatus = 200}-          request "GET" "/" [("Accept","application/json")] ""+          request "GET" "/" [("Accept", "application/json")] ""             `shouldRespondWith` "\"json\"" {matchStatus = 200}-          request "GET" "/" [("Accept","text/plain")] ""+          request "GET" "/" [("Accept", "text/plain")] ""             `shouldRespondWith` "" {matchStatus = 406}-          request "GET" "/" [("Accept","text/html;q=0.5, application/json")] ""+          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")] ""+          request "GET" "/" [("Accept", "text/html;q=0.5, application/json;q=0.4")] ""             `shouldRespondWith` "html" {matchStatus = 200}    describe "Exceptions" $@@ -566,26 +632,26 @@         }) $         it "makes sure we can recover from a `raise`" $           request "GET" "/" [] ""-            `shouldRespondWith` "InternalServerError \"XXX\"" {matchStatus = 200}+            `shouldRespondWith` "Internal server error: 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)],+          contentTypesProvided = return [("text/plain", text "wtf")],+          contentTypesAccepted = return [("text/plain", fmap (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"+          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)],+          contentTypesProvided = return [("text/plain", text "wtf")],+          contentTypesAccepted = return [("text/plain", fmap (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"+          request "POST" "/" [("Content-Type", "text/plain"), ("Accept", "text/plain")] "hello"             `shouldRespondWith` "hello" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain"]}