diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +0.8.3 +----- + +Add support for servant-0.14 +Reorder handling of errors + 0.8.2 ------ diff --git a/servant-snap.cabal b/servant-snap.cabal --- a/servant-snap.cabal +++ b/servant-snap.cabal @@ -1,5 +1,5 @@ name: servant-snap -version: 0.8.2 +version: 0.8.3 synopsis: A family of combinators for defining webservices APIs and serving them description: Interpret a Servant API as a Snap server, using any Snaplets you like. @@ -44,28 +44,29 @@ Servant.Server.Internal.SnapShims Servant.Utils.StaticFiles build-depends: - base >= 4.7 && < 4.11 - , aeson >= 0.7 && < 1.3 + base >= 4.7 && < 4.13 + , aeson >= 0.7 && < 1.5 , attoparsec >= 0.12 && < 0.14 , base64-bytestring >= 1.0 && < 1.1 , bytestring >= 0.10 && < 0.11 , case-insensitive >= 1.2 && < 1.3 - , containers >= 0.5 && < 0.6 - , either >= 4.3 && < 4.6 + , containers >= 0.5 && < 0.7 + , either >= 4.3 && < 5.1 , filepath >= 1 && < 1.5 , http-media >= 0.7.1.2 && < 0.8 , http-types >= 0.8 && < 0.13 - , http-api-data >= 0.2 && < 0.4 + , http-api-data >= 0.2 && < 0.5 , io-streams >= 1.3 && < 1.6 , network-uri >= 2.6 && < 2.7 , mtl >= 2.0 && < 2.3 , mmorph >= 1 && < 1.2 - , servant >= 0.8 && < 0.14 + , servant >= 0.14 && < 0.15 , string-conversions >= 0.3 && < 0.5 , text >= 1.2 && < 1.3 , snap >= 1.0 && < 1.2 , snap-core >= 1.0.2 && < 1.2 , snap-server >= 1.0 && < 1.2 + , tagged >= 0.8.5 && < 0.9 , transformers >= 0.3 && < 0.6 , word8 >= 0.1 && < 0.2 hs-source-dirs: src @@ -114,14 +115,14 @@ , directory , either , exceptions - , hspec >= 2.4.3 && < 2.5 + , hspec >= 2.4.3 && < 2.8 , io-streams , lens , process , digestive-functors >= 0.8.1.0 && < 0.9 , time - , hspec-snap >= 1.0.0.2 && < 1.1 - , hspec-core >= 2.4.3 && < 2.5 + , hspec-snap >= 1.0.1.0 && < 1.1 + , hspec-core >= 2.4.3 && < 2.8 , snap-cors , http-types , HUnit >= 1.4 diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -7,10 +7,12 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ < 710 @@ -27,19 +29,25 @@ ------------------------------------------------------------------------------- import Control.Applicative ((<$>)) +import Control.Monad.Trans (liftIO) import Control.Monad.Trans.Class (lift) -import Control.Monad (when) +import Control.Monad (join, when) import Data.Bool (bool) import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Builder.Extra as BB import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as BL +import Data.Either (partitionEithers) +import Data.List (foldl') import Data.Maybe (fromMaybe, isNothing, mapMaybe, maybeToList) import Data.Proxy -import Data.String (fromString) +import Data.String (IsString, fromString) import Data.String.Conversions (cs, (<>)) +import Data.Tagged (Tagged(..), retag) +import qualified Data.Text as T import Data.Text (Text) +import Data.Typeable (Typeable) import GHC.Generics import GHC.TypeLits (KnownNat, KnownSymbol, natVal, symbolVal) @@ -49,8 +57,8 @@ hContentType, hAccept) import qualified Network.HTTP.Media as NHM import Web.HttpApiData (FromHttpApiData, - parseHeaderMaybe, - parseQueryParamMaybe, + parseHeader, + parseQueryParam, parseUrlPieceMaybe, parseUrlPieces) import Snap.Core hiding (Headers, Method, @@ -58,19 +66,24 @@ method, withRequest) import Servant.API ((:<|>) (..), (:>), BasicAuth, BoundaryStrategy(..), - Capture, - CaptureAll, FramingRender (..), - Header, IsSecure(..), QueryFlag, - QueryParam, QueryParams, Raw, - RemoteHost, ReqBody, - ReflectMethod(..), Stream, - ToStreamGenerator (..), Verb, - getStreamGenerator) + Capture', CaptureAll, + Description, EmptyAPI, + FramingRender (..), + Header', If, IsSecure(..), + QueryFlag, QueryParam', + QueryParams, Raw, RemoteHost, + ReqBody', ReflectMethod(..), + SBool(..), SBoolI, + Stream, Summary, + ToStreamGenerator (..), Vault, + Verb, getStreamGenerator, sbool) import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..), AllMime(..), MimeRender (..), canHandleAcceptH, contentType) +import Servant.API.Modifiers (FoldLenient, FoldRequired, + RequestArgument, unfoldRequestArgument) import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders, getHeaders) import qualified System.IO.Streams as IOS @@ -93,6 +106,13 @@ -> Delayed m env (Server api context m) -> Router m env + hoistServerWithContext + :: proxy api + -> proxy' context + -> (forall x. m x -> n x) + -> ServerT api context m + -> ServerT api context n + type Server api context m = ServerT api context m -- * Instances @@ -117,7 +137,11 @@ where pa = Proxy :: Proxy a pb = Proxy :: Proxy b -captured :: FromHttpApiData a => proxy (Capture sym a) -> Text -> Maybe a + hoistServerWithContext _ pc nt (a :<|> b) = + hoistServerWithContext (Proxy :: Proxy a) pc nt a :<|> + hoistServerWithContext (Proxy :: Proxy b) pc nt b + +captured :: FromHttpApiData a => proxy (Capture' mods sym a) -> Text -> Maybe a captured _ = parseUrlPieceMaybe -- | If you use 'Capture' in one of the endpoints for your API, @@ -127,7 +151,7 @@ -- it into a value of the type you specify. -- -- You can control how it'll be converted from 'Text' to your type --- by simply providing an instance of 'FromText' for your type. +-- by simply providing an instance of 'FromHttpApiData' for your type. -- -- Example: -- @@ -137,30 +161,33 @@ -- > server = getBook -- > where getBook :: Text -> EitherT ServantErr IO Book -- > getBook isbn = ... -instance (FromHttpApiData a, HasServer sublayout context m) - => HasServer (Capture capture a :> sublayout) context m where +instance (FromHttpApiData a, HasServer api context m) + => HasServer (Capture' mods capture a :> api) context m where - type ServerT (Capture capture a :> sublayout) context m = - a -> ServerT sublayout context m + type ServerT (Capture' mods capture a :> api) context m = + a -> ServerT api context m + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s + route Proxy ctx d = CaptureRouter $ - route (Proxy :: Proxy sublayout) ctx + route (Proxy :: Proxy api) ctx (addCapture d $ \ txt -> case parseUrlPieceMaybe txt of Nothing -> delayedFail err400 Just v -> return v ) +instance (FromHttpApiData a, HasServer api context m) + => HasServer (CaptureAll capture a :> api) context m where -instance (FromHttpApiData a, HasServer sublayout context m) - => HasServer (CaptureAll capture a :> sublayout) context m where + type ServerT (CaptureAll capture a :> api) context m = + [a] -> ServerT api context m - type ServerT (CaptureAll capture a :> sublayout) context m = - [a] -> ServerT sublayout context m + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy ctx d = CaptureAllRouter $ - route (Proxy :: Proxy sublayout) ctx + route (Proxy :: Proxy api) ctx (addCapture d $ \ txts -> case parseUrlPieces txts of Left _ -> delayedFail err400 Right v -> return v @@ -240,10 +267,13 @@ KnownNat status) => HasServer (Verb method status ctypes a) context m where type ServerT (Verb method status ctypes a) context m = m a + hoistServerWithContext _ _ nt s = nt s + route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method) status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) + instance {-# OVERLAPPABLE #-} (AllCTRender ctypes a, ReflectMethod method, KnownNat status, @@ -251,19 +281,99 @@ => HasServer (Verb method status ctypes (Headers h a)) context m where type ServerT (Verb method status ctypes (Headers h a)) context m = m (Headers h a) + hoistServerWithContext _ _ nt s = nt s + route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method) status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) +instance {-# OVERLAPPABLE #-} (MimeRender ctype a, + ReflectMethod method, + KnownNat status, + FramingRender framing ctype, + ToStreamGenerator b a) + => HasServer (Stream method status framing ctype b) context m where + type ServerT (Stream method status framing ctype b) context m = m b + hoistServerWithContext _ _ nt s = nt s + + route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype) + where method = reflectMethod (Proxy :: Proxy method) + status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) + + +instance {-# OVERLAPPABLE #-} (MimeRender ctype a, + ReflectMethod method, + KnownNat status, + FramingRender framing ctype, + ToStreamGenerator b a, + GetHeaders (Headers h b)) + => HasServer (Stream method status framing ctype (Headers h b)) context m where + + type ServerT (Stream method status framing ctype (Headers h b)) context m = m (Headers h b) + hoistServerWithContext _ _ nt s = nt s + + route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype) + where method = reflectMethod (Proxy :: Proxy method) + status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) + +streamRouter :: (MimeRender ctype a, + FramingRender framing ctype, + ToStreamGenerator b a, + MonadSnap m + ) => + (c -> ([(HeaderName, B.ByteString)], b)) + -> Method + -> Status + -> Proxy framing + -> Proxy ctype + -> Delayed m env (m c) + -> Router m env +streamRouter splitHeaders method (Status code msg) framingproxy ctypeproxy action = leafRouter $ \env request respond -> + let accH = fromMaybe ct_wildcard $ getHeader hAccept request + cmediatype = NHM.matchAccept [contentType ctypeproxy] accH + accCheck = when (isNothing cmediatype) $ delayedFail err406 + contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype) + in runAction (action `addMethodCheck` methodCheck method request + `addAcceptCheck` accCheck + ) env request respond $ \ output -> + let (headerz, fa) = splitHeaders output + k = getStreamGenerator . toStreamGenerator $ fa in + Route $ setResponseStatus code msg + $ (\r -> foldl' (\r' (h,h') -> addHeader h h' r') r $ contentHeader : headerz) + $ flip setResponseBody emptyResponse $ \outStream -> do + let writeAndFlush bb = IOS.write (Just $ bb <> BB.flush) outStream + writeAndFlush (BB.lazyByteString $ header framingproxy ctypeproxy) + case boundary framingproxy ctypeproxy of + BoundaryStrategyBracket f -> + let go x = let bs = mimeRender ctypeproxy x + (before, after) = f bs + in writeAndFlush ( BB.lazyByteString before + <> BB.lazyByteString bs + <> BB.lazyByteString after) + in k go go + BoundaryStrategyIntersperse sep -> k + (\x -> do + writeAndFlush . BB.lazyByteString $ mimeRender ctypeproxy x + ) + (\x -> do + writeAndFlush . (BB.lazyByteString sep <>) . BB.lazyByteString $ mimeRender ctypeproxy x + ) + BoundaryStrategyGeneral f -> + let go = writeAndFlush . BB.lazyByteString . f . mimeRender ctypeproxy + in k go go + IOS.write (Just . BB.lazyByteString $ trailer framingproxy ctypeproxy) outStream + return outStream + + -- | If you use 'Header' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of the type specified by 'Header'. -- This lets servant worry about extracting it from the request and turning -- it into a value of the type you specify. -- --- All it asks is for a 'FromText' instance. +-- All it asks is for a 'FromHttpApiData' instance. -- -- Example: -- @@ -277,18 +387,39 @@ -- > server = viewReferer -- > where viewReferer :: Referer -> EitherT ServantErr IO referer -- > viewReferer referer = return referer -instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context m) - => HasServer (Header sym a :> sublayout) context m where +instance (KnownSymbol sym, FromHttpApiData a, HasServer api context m + , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods) + ) + => HasServer (Header' mods sym a :> api) context m where - type ServerT (Header sym a :> sublayout) context m = - Maybe a -> ServerT sublayout context m + type ServerT (Header' mods sym a :> api) context m = + RequestArgument mods a -> ServerT api context m - route Proxy ctx subserver = - let mheader req = parseHeaderMaybe =<< getHeader str req - in route (Proxy :: Proxy sublayout) ctx (passToServer subserver mheader) - where str = fromString $ symbolVal (Proxy :: Proxy sym) + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s + route Proxy ctx subserver = route (Proxy :: Proxy api) ctx $ + subserver `addHeaderCheck` withRequest headerCheck + where + headerName :: IsString n => n + headerName = fromString $ symbolVal (Proxy :: Proxy sym) + headerCheck :: Request -> DelayedM m (RequestArgument mods a) + headerCheck req = + unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev + where + mev :: Maybe (Either Text a) + mev = fmap parseHeader $ getHeader headerName req + + errReq = delayedFailFatal err400 + { errBody = "Header " <> headerName <> " is required" + } + + errSt e = delayedFailFatal err400 + { errBody = cs $ "Error parsing header " + <> headerName + <> " failed: " <> e + } + -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of type @'Maybe' 'Text'@. @@ -299,7 +430,7 @@ -- hand you 'Nothing'. -- -- You can control how it'll be converted from 'Text' to your type --- by simply providing an instance of 'FromText' for your type. +-- by simply providing an instance of 'FromHttpApiData' for your type. -- -- Example: -- @@ -310,24 +441,40 @@ -- > where getBooksBy :: Maybe Text -> EitherT ServantErr IO [Book] -- > getBooksBy Nothing = ...return all books... -- > getBooksBy (Just author) = ...return books by the given author... -instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context m) - => HasServer (QueryParam sym a :> sublayout) context m where +instance (KnownSymbol sym, FromHttpApiData a, HasServer api context m + , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods) + ) + => HasServer (QueryParam' mods sym a :> api) context m where - type ServerT (QueryParam sym a :> sublayout) context m = - Maybe a -> ServerT sublayout context m + type ServerT (QueryParam' mods sym a :> api) context m = + RequestArgument mods a -> ServerT api context m + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s + route Proxy ctx subserver = let querytext r = parseQueryText $ rqQueryString r - param r = - case lookup paramname (querytext r) of - Nothing -> Nothing -- param absent from the query string - Just Nothing -> Nothing -- param present with no value -> Nothing - Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to - -- the right type - in route (Proxy :: Proxy sublayout) ctx (passToServer subserver param) - where paramname = cs $ symbolVal (Proxy :: Proxy sym) + paramname = cs $ symbolVal (Proxy :: Proxy sym) + parseParam :: Request -> DelayedM m (RequestArgument mods a) + parseParam req = + unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev + where + mev :: Maybe (Either T.Text a) + mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req + errReq = delayedFailFatal err400 + { errBody = cs $ "Query parameter " <> paramname <> " is required" + } + + errSt e = delayedFailFatal err400 + { errBody = cs $ "Error parsing query parameter " + <> paramname <> " failed: " <> e + } + + delayed = addParameterCheck subserver . withRequest $ parseParam + + in route (Proxy :: Proxy api) ctx delayed + -- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of type @['Text']@. @@ -337,7 +484,7 @@ -- the type you specify. -- -- You can control how the individual values are converted from 'Text' to your type --- by simply providing an instance of 'FromText' for your type. +-- by simply providing an instance of 'FromHttpApiData' for your type. -- -- Example: -- @@ -347,26 +494,36 @@ -- > server = getBooksBy -- > where getBooksBy :: [Text] -> EitherT ServantErr IO [Book] -- > getBooksBy authors = ...return all books by these authors... -instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context m) - => HasServer (QueryParams sym a :> sublayout) context m where +instance (KnownSymbol sym, FromHttpApiData a, HasServer api context m) + => HasServer (QueryParams sym a :> api) context m where - type ServerT (QueryParams sym a :> sublayout) context m = - [a] -> ServerT sublayout context m + type ServerT (QueryParams sym a :> api) context m = + [a] -> ServerT api context m - route Proxy ctx subserver = - let querytext r = parseQueryText $ rqQueryString r - -- if sym is "foo", we look for query string parameters - -- named "foo" or "foo[]" and call parseQueryParam on the - -- corresponding values - parameters r = filter looksLikeParam (querytext r) - values r = mapMaybe (convert . snd) (parameters r) - in route (Proxy :: Proxy sublayout) ctx (passToServer subserver values) - where paramname = cs $ symbolVal (Proxy :: Proxy sym) - looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") - convert Nothing = Nothing - convert (Just v) = parseQueryParamMaybe v + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s + route Proxy ctx subserver = route (Proxy :: Proxy api) ctx $ + subserver `addParameterCheck` withRequest paramsCheck + where + paramname = cs $ symbolVal (Proxy :: Proxy sym) + paramsCheck req = + case partitionEithers $ fmap parseQueryParam params of + ([], parsed) -> return parsed + (errs, _) -> delayedFailFatal err400 + { errBody = cs $ "Error parsing query parameter(s) " + <> paramname <> " failed: " + <> T.intercalate ", " errs + } + where + params :: [T.Text] + params = mapMaybe snd + . filter (looksLikeParam . fst) + . parseQueryText + . rqQueryString + $ req + looksLikeParam name = name == paramname || name == (paramname <> "[]") + -- | If you use @'QueryFlag' "published"@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of type 'Bool'. @@ -379,19 +536,21 @@ -- > server = getBooks -- > where getBooks :: Bool -> EitherT ServantErr IO [Book] -- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument... -instance (KnownSymbol sym, HasServer sublayout context m) - => HasServer (QueryFlag sym :> sublayout) context m where +instance (KnownSymbol sym, HasServer api context m) + => HasServer (QueryFlag sym :> api) context m where - type ServerT (QueryFlag sym :> sublayout) context m = - Bool -> ServerT sublayout context m + type ServerT (QueryFlag sym :> api) context m = + Bool -> ServerT api context m - route Proxy ctx subserver = + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s + + route Proxy context subserver = let querytext r = parseQueryText $ rqQueryString r param r = case lookup paramname (querytext r) of Just Nothing -> True -- param is there, with no value Just (Just v) -> examine v -- param with a value Nothing -> False -- param not in the query string - in route (Proxy :: Proxy sublayout) ctx (passToServer subserver param) + in route (Proxy :: Proxy api) context (passToServer subserver param) where paramname = cs $ symbolVal (Proxy :: Proxy sym) examine v | v == "true" || v == "1" || v == "" = True | otherwise = False @@ -409,6 +568,8 @@ type ServerT Raw context m = m () + hoistServerWithContext _ _ nt = nt + route Proxy _ rawApplication = RawRouter $ \ env request respond -> do r <- runDelayed rawApplication env request case r of @@ -416,13 +577,13 @@ Fail a -> respond $ Fail a FailFatal e -> respond $ FailFatal e - -- | If you use 'ReqBody' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of the type specified by 'ReqBody'. -- The @Content-Type@ header is inspected, and the list provided is used to -- attempt deserialization. If the request does not have a @Content-Type@ --- header, it is treated as @application/octet-stream@. +-- header, it is treated as @application/octet-stream@ (as specified in +-- . -- This lets servant worry about extracting it from the request and turning -- it into a value of the type you specify. -- @@ -437,95 +598,153 @@ -- > server = postBook -- > where postBook :: Book -> EitherT ServantErr IO Book -- > postBook book = ...insert into your db... -instance ( AllCTUnrender list a, HasServer sublayout context m - ) => HasServer (ReqBody list a :> sublayout) context m where +instance ( AllCTUnrender list a, HasServer api context m, SBoolI (FoldLenient mods), MonadSnap m + ) => HasServer (ReqBody' mods list a :> api) context m where - type ServerT (ReqBody list a :> sublayout) context m = - a -> ServerT sublayout context m + type ServerT (ReqBody' mods list a :> api) context m = + If (FoldLenient mods) (Either String a) a -> ServerT api context m - route Proxy ctx subserver = - route (Proxy :: Proxy sublayout) ctx (addBodyCheck (subserver ) bodyCheck') + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s + + route Proxy context subserver + = route (Proxy :: Proxy api) context $ + addBodyCheck subserver ctCheck bodyCheck where - -- bodyCheck' :: DelayedM m a - bodyCheck' = do - req <- lift getRequest - let contentTypeH = fromMaybe "application/octet-stream" $ getHeader hContentType req - mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH) <$> - lift (readRequestBody 2147483647) -- Maximum size: 2GB - case mrqbody of - Nothing -> delayedFailFatal err415 - Just (Left e) -> delayedFailFatal err400 { errBody = cs e } - Just (Right v) -> return v + -- Content-Type check, we only lookup we can try to parse the request body + ctCheck = withRequest $ \ request -> do + -- See HTTP RFC 2616, section 7.2.1 + -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1 + -- See also "W3C Internet Media Type registration, consistency of use" + -- http://www.w3.org/2001/tag/2002/0129-mime + let contentTypeH = fromMaybe "application/octet-stream" + $ getHeader hContentType request + case canHandleCTypeH (Proxy :: Proxy list) (cs contentTypeH) :: Maybe (BL.ByteString -> Either String a) of + Nothing -> delayedFail err415 + Just f -> return f + -- Body check, we get a body parsing functions as the first argument. + bodyCheck f = do + mrqbody <- lift $ runRequestBody $ \ stream -> f <$> BL.fromChunks <$> IOS.toList {- IOS.toLazyByteString -} stream + case sbool :: SBool (FoldLenient mods) of + STrue -> return mrqbody + SFalse -> case mrqbody of + Left e -> delayedFailFatal err400 { errBody = cs e } + Right v -> return v -- | Make sure the incoming request starts with @"/path"@, strip it and --- pass the rest of the request path to @sublayout@. -instance (KnownSymbol path, HasServer sublayout context m) => HasServer (path :> sublayout) context m where +-- pass the rest of the request path to @api@. +instance (KnownSymbol path, HasServer api context m) => HasServer (path :> api) context m where - type ServerT (path :> sublayout) context m = ServerT sublayout context m + type ServerT (path :> api) context m = ServerT api context m - route Proxy ctx subserver = + route Proxy context subserver = pathRouter (cs (symbolVal proxyPath)) - (route (Proxy :: Proxy sublayout) ctx subserver) + (route (Proxy :: Proxy api) context subserver) where proxyPath = Proxy :: Proxy path + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s +instance HasServer api context m => HasServer (RemoteHost :> api) context m where + type ServerT (RemoteHost :> api) context m = B.ByteString -> ServerT api context m + route Proxy context subserver = + route (Proxy :: Proxy api) context (passToServer subserver rqHostName) + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s + +instance HasServer api context m => HasServer (IsSecure :> api) context m where + type ServerT (IsSecure :> api) context m = IsSecure -> ServerT api context m + + route Proxy context subserver = + route (Proxy :: Proxy api) context (passToServer subserver (bool NotSecure Secure . rqIsSecure)) + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s + +-- This appears to be about 1000000% WAI-specific, so better hope you didn't need it + +-- instance HasServer api context m => HasServer (Vault :> api) context m where +-- type ServerT (Vault :> api) context m = Vault -> ServerT api context m +-- +-- route Proxy context subserver = +-- route (Proxy :: Proxy api) context (passToServer subserver vault) +-- hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s + instance HasServer api context m => HasServer (HttpVersion :> api) context m where type ServerT (HttpVersion :> api) context m = HttpVersion -> ServerT api context m route Proxy ctx subserver = route (Proxy :: Proxy api) ctx (passToServer subserver rqVersion) + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s +-- | Ignore @'Summary'@ in server handlers. +instance HasServer api ctx m => HasServer (Summary desc :> api) ctx m where + type ServerT (Summary desc :> api) ctx m = ServerT api ctx m -instance HasServer api context m => HasServer (IsSecure :> api) context m where - type ServerT (IsSecure :> api) context m = IsSecure -> ServerT api context m + route _ = route (Proxy :: Proxy api) + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s - route Proxy ctx subserver = - route (Proxy :: Proxy api) ctx (passToServer subserver (bool NotSecure Secure . rqIsSecure)) +-- | Ignore @'Description'@ in server handlers. +instance HasServer api ctx m => HasServer (Description desc :> api) ctx m where + type ServerT (Description desc :> api) ctx m = ServerT api ctx m -instance HasServer api context m => HasServer (RemoteHost :> api) context m where - type ServerT (RemoteHost :> api) context m = B.ByteString -> ServerT api context m + route _ = route (Proxy :: Proxy api) + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s - route Proxy ctx subserver = - route (Proxy :: Proxy api) ctx (passToServer subserver rqHostName) +-- | Singleton type representing a server that serves an empty API. +data EmptyServer = EmptyServer deriving (Typeable, Eq, Show, Bounded, Enum) --- newtype BasicAuthCheck m usr = --- BasicAuthCheck { unBasicAuthCheck :: BasicAuthData -> m (BasicAuthResult usr) } --- deriving (Functor, Generic) +-- | Server for `EmptyAPI` +emptyServer :: ServerT EmptyAPI context m +emptyServer = Tagged EmptyServer -data BasicAuthResult usr = Unauthorized | BadPassword | NoSuchUser | Authorized usr - deriving (Functor, Eq, Read, Show, Generic) +-- | The server for an `EmptyAPI` is `emptyAPIServer`. +-- +-- > type MyApi = "nothing" :> EmptyApi +-- > +-- > server :: Server MyApi +-- > server = emptyAPIServer +instance HasServer EmptyAPI context m where + type ServerT EmptyAPI context m = Tagged m EmptyServer -instance (HasServer api context m, - KnownSymbol realm, - HasContextEntry context (BasicAuthCheck m usr) - ) => HasServer (BasicAuth realm usr :> api) context m where + route Proxy _ _ = StaticRouter mempty mempty + + hoistServerWithContext _ _ _ = retag + +-- | Basic Authentication +instance ( KnownSymbol realm + , HasServer api context m + , HasContextEntry context (BasicAuthCheck m usr) + ) + => HasServer (BasicAuth realm usr :> api) context m where + type ServerT (BasicAuth realm usr :> api) context m = usr -> ServerT api context m - route Proxy ctx subserver = - route (Proxy :: Proxy api) ctx (subserver `addAuthCheck` authCheck) + route Proxy context subserver = + route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck) where realm = B.pack $ symbolVal (Proxy :: Proxy realm) - basicAuthContext = getContextEntry ctx - authCheck = withRequest $ \req -> runBasicAuth req realm basicAuthContext + basicAuthContext = getContextEntry context + authCheck = withRequest $ \ req -> runBasicAuth req realm basicAuthContext + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s + +-- * helpers +-- ct_wildcard :: B.ByteString ct_wildcard = "*" <> "/" <> "*" -- Because CPP +{- instance ( MimeRender ctype a, ReflectMethod method, MimeRender ctype a, -- ToStreamGenerator m (f a), - FramingRender framing ctype, ToStreamGenerator f a - ) => HasServer (Stream method framing ctype (f a)) context m where - type ServerT (Stream method framing ctype (f a)) context m = m (f a) + FramingRender framing ctype -- , ToStreamGenerator f a + ) => HasServer (Stream method status framing ctype (f a)) context m where + type ServerT (Stream method status framing ctype (f a)) context m = m (f a) route Proxy _ action = streamRouter ([],) method (Proxy) (Proxy :: Proxy framing) (Proxy :: Proxy ctype) action where method = reflectMethod (Proxy :: Proxy method) -- status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) -instance ( MimeRender ctype a, ReflectMethod method, MimeRender ctype (f a), ToStreamGenerator m (f a), - FramingRender framing ctype, ToStreamGenerator f a, GetHeaders (Headers h (f a)) - ) => HasServer (Stream method framing ctype (Headers h (f a))) context m where - type ServerT (Stream method framing ctype (Headers h (f a))) context m = m (Headers h (f a)) +instance ( MimeRender ctype a, ReflectMethod method, MimeRender ctype (f a), -- ToStreamGenerator m (f a), + FramingRender framing ctype, {- ToStreamGenerator f a, -} GetHeaders (Headers h (f a)) + ) => HasServer (Stream method status framing ctype (Headers h (f a))) context m where + type ServerT (Stream method status framing ctype (Headers h (f a))) context m = m (Headers h (f a)) route Proxy _ action = streamRouter (\x -> (getHeaders x, getResponse x)) @@ -537,48 +756,11 @@ where method = reflectMethod (Proxy :: Proxy method) -streamRouter :: (MimeRender ctype a, - FramingRender framing ctype, - ToStreamGenerator f a, - MonadSnap m - ) => - (b -> ([(HeaderName, B.ByteString)], f a)) - -> Method - -> Proxy m - -> Proxy framing - -> Proxy ctype - -> Delayed m env (m b) - -> Router m env -streamRouter splitHeaders method handlerProxy framingproxy ctypeproxy action = leafRouter $ \env request respond -> - let accH = fromMaybe ct_wildcard $ getHeader hAccept request - cmediatype = NHM.matchAccept [contentType ctypeproxy] accH - accCheck = when (isNothing cmediatype) $ delayedFail err406 - contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype) - in runAction (action `addMethodCheck` methodCheck method request - `addAcceptCheck` accCheck - ) env request respond $ \ output -> - let (headers, fa) = splitHeaders output - k = getStreamGenerator . toStreamGenerator $ fa in - Route $ flip setResponseBody emptyResponse $ \outStream -> do - let writeAndFlush bb = IOS.write (Just $ bb <> BB.flush) outStream - writeAndFlush (BB.lazyByteString $ header framingproxy ctypeproxy) - case boundary framingproxy ctypeproxy of - BoundaryStrategyBracket f -> - let go x = let bs = mimeRender ctypeproxy x - (before, after) = f bs - in writeAndFlush ( BB.lazyByteString before - <> BB.lazyByteString bs - <> BB.lazyByteString after) - in k go go - BoundaryStrategyIntersperse sep -> k - (\x -> do - writeAndFlush . BB.lazyByteString $ mimeRender ctypeproxy x - ) - (\x -> do - writeAndFlush . (BB.lazyByteString sep <>) . BB.lazyByteString $ mimeRender ctypeproxy x - ) - BoundaryStrategyGeneral f -> - let go = writeAndFlush . BB.lazyByteString . f . mimeRender ctypeproxy - in k go go - IOS.write (Just . BB.lazyByteString $ trailer framingproxy ctypeproxy) outStream - return outStream + +-- newtype BasicAuthCheck m usr = +-- BasicAuthCheck { unBasicAuthCheck :: BasicAuthData -> m (BasicAuthResult usr) } +-- deriving (Functor, Generic) + +data BasicAuthResult usr = Unauthorized | BadPassword | NoSuchUser | Authorized usr + deriving (Functor, Eq, Read, Show, Generic) +-} diff --git a/src/Servant/Server/Internal/RoutingApplication.hs b/src/Servant/Server/Internal/RoutingApplication.hs --- a/src/Servant/Server/Internal/RoutingApplication.hs +++ b/src/Servant/Server/Internal/RoutingApplication.hs @@ -118,14 +118,18 @@ Delayed :: { capturesD :: env -> DelayedM m captures , methodD :: DelayedM m () , authD :: DelayedM m auth - , bodyD :: DelayedM m body - , serverD :: captures -> auth -> body -> Request -> RouteResult c + , acceptD :: DelayedM m () + , contentD :: DelayedM m contentType + , paramsD :: DelayedM m params + , headersD :: DelayedM m headers + , bodyD :: contentType -> DelayedM m body + , serverD :: captures -> params -> headers -> auth -> body -> Request -> RouteResult c } -> Delayed m env c instance Functor (Delayed m env) where fmap f Delayed{..} = Delayed - { serverD = \ c a b req -> f <$> serverD c a b req + { serverD = \ c p h a b req -> f <$> serverD c p h a b req , .. } @@ -169,7 +173,7 @@ -- | A 'Delayed' without any stored checks. emptyDelayed :: Monad m => Proxy (m :: * -> *) -> RouteResult a -> Delayed m env a emptyDelayed (Proxy :: Proxy m) result = - Delayed (const r) r r r (\ _ _ _ _ -> result) + Delayed (const r) r r r r r r (const r) (\ _ _ _ _ _ _ -> result) where r :: DelayedM m () r = return () @@ -193,10 +197,34 @@ addCapture Delayed{..} new = Delayed { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt - , serverD = \ (x, v) a b req -> ($ v) <$> serverD x a b req + , serverD = \ (x, v) p h a b req -> ($ v) <$> serverD x p h a b req , .. } -- Note [Existential Record Update] +-- | Add a parameter check to the end of the params block +addParameterCheck :: Monad m + => Delayed m env (a -> b) + -> DelayedM m a + -> Delayed m env b +addParameterCheck Delayed {..} new = + Delayed + { paramsD = (,) <$> paramsD <*> new + , serverD = \c (p, pNew) h a b req -> ($ pNew) <$> serverD c p h a b req + , .. + } + +-- | Add a header check to the end of the headers block +addHeaderCheck :: Monad m + => Delayed m env (a -> b) + -> DelayedM m a + -> Delayed m env b +addHeaderCheck Delayed {..} new = + Delayed + { headersD = (,) <$> headersD <*> new + , serverD = \c p (h, hNew) a b req -> ($ hNew) <$> serverD c p h a b req + , .. + } + -- | Add a method check to the end of the method block. addMethodCheck :: Monad m => Delayed m env a @@ -216,25 +244,30 @@ addAuthCheck Delayed{..} new = Delayed { authD = (,) <$> authD <*> new - , serverD = \ c (y, v) b req -> ($ v) <$> serverD c y b req + , serverD = \ c p h (y, v) b req -> ($ v) <$> serverD c p h y b req , .. } -- Note [Existential Record Update] --- | Add a body check to the end of the body block. +-- | Add a content type and body checks around parameter checks. +-- +-- We'll report failed content type check (415), before trying to parse +-- query parameters (400). Which, in turn, happens before request body parsing. addBodyCheck :: Monad m => Delayed m env (a -> b) - -> DelayedM m a + -> DelayedM m c -- ^ content type check + -> (c -> DelayedM m a) -- ^ body check -> Delayed m env b -addBodyCheck Delayed{..} new = +addBodyCheck Delayed{..} newContentD newBodyD = Delayed - { bodyD = (,) <$> bodyD <*> new - , serverD = \ c a (z, v) req -> ($ v) <$> serverD c a z req + { contentD = (,) <$> contentD <*> newContentD + , bodyD = \(content, c) -> (,) <$> bodyD content <*> newBodyD c + , serverD = \ c p h a (z, v) req -> ($ v) <$> serverD c p h a z req , .. } -- Note [Existential Record Update] --- | Add an accept header check to the beginning of the body --- block. There is a tradeoff here. In principle, we'd like +-- | Add an accept header check before handling parameters. +-- In principle, we'd like -- to take a bad body (400) response take precedence over a -- failed accept check (406). BUT to allow streaming the body, -- we cannot run the body check and then still backtrack. @@ -249,7 +282,7 @@ -> Delayed m env a addAcceptCheck Delayed{..} new = Delayed - { bodyD = new *> bodyD + { acceptD = acceptD *> new , .. } -- Note [Existential Record Update] @@ -259,7 +292,7 @@ passToServer :: Delayed m env (a -> b) -> (Request -> a) -> Delayed m env b passToServer Delayed{..} x = Delayed - { serverD = \ c a b req -> ($ x req) <$> serverD c a b req + { serverD = \ c p h a b req -> ($ x req) <$> serverD c p h a b req , .. } -- Note [Existential Record Update] @@ -279,5 +312,9 @@ c <- capturesD env methodD a <- authD - b <- bodyD - DelayedM (\ req -> return $ serverD c a b req) + acceptD + content <- contentD + p <- paramsD -- Has to be before body parsing, but after content-type checks + h <- headersD + b <- bodyD content + DelayedM (\ req -> return $ serverD c p h a b req)