servant-server 0.12 → 0.13
raw patch · 8 files changed
+336/−141 lines, 8 filesdep +http-mediadep −filemanipdep ~QuickCheckdep ~aesondep ~attoparsec
Dependencies added: http-media
Dependencies removed: filemanip
Dependency ranges changed: QuickCheck, aeson, attoparsec, base, base-compat, base64-bytestring, bytestring, containers, directory, doctest, exceptions, filepath, hspec, hspec-wai, http-api-data, http-types, mtl, network, network-uri, parsec, resourcet, safe, servant, should-not-typecheck, split, string-conversions, tagged, temporary, text, transformers, transformers-compat, wai, wai-app-static, wai-extra, warp, word8
Files
- CHANGELOG.md +8/−0
- servant-server.cabal +76/−59
- src/Servant/Server.hs +0/−1
- src/Servant/Server/Internal.hs +229/−50
- src/Servant/Server/Internal/Handler.hs +0/−1
- src/Servant/Server/Internal/Router.hs +0/−1
- src/Servant/Server/Internal/RoutingApplication.hs +17/−13
- test/Servant/ServerSpec.hs +6/−16
CHANGELOG.md view
@@ -1,6 +1,14 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md) [Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) +0.13+----++- Streaming endpoint support.+ ([#836](https://github.com/haskell-servant/servant/pull/836))+- *servant* Add `Servant.API.Modifiers`+ ([#873](https://github.com/haskell-servant/servant/pull/873))+ 0.12 ----
servant-server.cabal view
@@ -1,5 +1,5 @@ name: servant-server-version: 0.12+version: 0.13 synopsis: A family of combinators for defining webservices APIs and serving them description: A family of combinators for defining webservices APIs and serving them@@ -25,12 +25,12 @@ GHC==7.8.4 GHC==7.10.3 GHC==8.0.2- GHC==8.2.1+ GHC==8.2.2 extra-source-files: include/*.h CHANGELOG.md README.md-bug-reports: http://github.com/haskell-servant/servant/issues+ source-repository head type: git location: http://github.com/haskell-servant/servant.git@@ -54,38 +54,51 @@ Servant.Server.Internal.RoutingApplication Servant.Server.Internal.ServantErr Servant.Utils.StaticFiles++ -- Bundled with GHC: Lower bound to not force re-installs+ -- text and mtl are bundled starting with GHC-8.4+ --+ -- note: mtl lower bound is so low because of GHC-7.8 build-depends:- base >= 4.7 && < 4.11- , base-compat >= 0.9 && < 0.10- , aeson >= 0.7 && < 1.3- , attoparsec >= 0.12 && < 0.14- , base64-bytestring >= 1.0 && < 1.1- , bytestring >= 0.10 && < 0.11- , containers >= 0.5 && < 0.6- , exceptions >= 0.8 && < 0.9- , http-api-data >= 0.3 && < 0.4- , http-types >= 0.8 && < 0.11- , network-uri >= 2.6 && < 2.7- , monad-control >= 1.0.0.4 && < 1.1- , mtl >= 2 && < 2.3- , network >= 2.6 && < 2.7- , safe >= 0.3 && < 0.4- , servant == 0.12.*- , split >= 0.2 && < 0.3- , string-conversions >= 0.3 && < 0.5- , system-filepath >= 0.4 && < 0.5- , filepath >= 1 && < 1.5- , resourcet >= 1.1.6 && <1.2- , tagged >= 0.7.3 && <0.9- , text >= 1.2 && < 1.3- , transformers >= 0.3 && < 0.6- , transformers-base >= 0.4.4 && < 0.5- , transformers-compat>= 0.4 && < 0.6- , wai >= 3.0 && < 3.3- , wai-app-static >= 3.1 && < 3.2- , warp >= 3.0 && < 3.3- , word8 >= 0.1 && < 0.2+ base >= 4.7 && < 4.11+ , bytestring >= 0.10.4.0 && < 0.11+ , containers >= 0.5.5.1 && < 0.6+ , mtl >= 2.1 && < 2.3+ , text >= 1.2.3.0 && < 1.3+ , transformers >= 0.3.0.0 && < 0.6+ , filepath >= 1.3.0.2 && < 1.5 + -- Servant dependencies+ build-depends:+ servant == 0.13.*++ -- Other dependencies: Lower bound around what is in the latest Stackage LTS.+ -- Here can be exceptions if we really need features from the newer versions.+ build-depends:+ aeson >= 1.2.3.0 && < 1.3+ , base-compat >= 0.9.3 && < 0.10+ , attoparsec >= 0.13.2.0 && < 0.14+ , base64-bytestring >= 1.0.0.1 && < 1.1+ , exceptions >= 0.8.3 && < 0.9+ , http-api-data >= 0.3.7.1 && < 0.4+ , http-media >= 0.7.1.1 && < 0.8+ , http-types >= 0.12 && < 0.13+ , network-uri >= 2.6.1.0 && < 2.7+ , monad-control >= 1.0.0.4 && < 1.1+ , network >= 2.6.3.2 && < 2.7+ , safe >= 0.3.15 && < 0.4+ , split >= 0.2.3.2 && < 0.3+ , string-conversions >= 0.4.0.1 && < 0.5+ , system-filepath >= 0.4 && < 0.5+ , resourcet >= 1.1.9 && < 1.3+ , tagged >= 0.8.5 && < 0.9+ , transformers-base >= 0.4.4 && < 0.5+ , transformers-compat >= 0.5.1 && < 0.6+ , wai >= 3.2.1.1 && < 3.3+ , wai-app-static >= 3.1.6.1 && < 3.2+ , warp >= 3.2.13 && < 3.3+ , word8 >= 0.1.3 && < 0.2+ hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall@@ -125,49 +138,53 @@ Servant.HoistSpec Servant.ServerSpec Servant.Utils.StaticFilesSpec- build-tool-depends:- hspec-discover:hspec-discover++ -- Dependencies inherited from the library. No need to specify bounds. build-depends:- base == 4.*+ base , base-compat , aeson , base64-bytestring , bytestring- , directory , exceptions- , hspec == 2.*- , hspec-wai >= 0.8 && <0.9 , http-types , mtl- , network >= 2.6- , parsec- , QuickCheck+ , network , resourcet , safe , servant , servant-server- , should-not-typecheck == 2.1.* , string-conversions- , temporary , text , transformers , transformers-compat , wai- , wai-extra , warp + -- Additonal dependencies+ build-depends:+ directory >= 1.2.1.0 && < 1.4+ , hspec >= 2.4.4 && < 2.5+ , hspec-wai >= 0.9 && < 0.10+ , should-not-typecheck >= 2.1.0 && < 2.2+ , parsec >= 3.1.11 && < 3.2+ , QuickCheck >= 2.10.1 && < 2.12+ , wai-extra >= 3.0.21.0 && < 3.1+ , temporary >= 1.2.0.3 && < 1.3++ build-tool-depends:+ hspec-discover:hspec-discover >=2.4.4 && <2.5+ test-suite doctests- build-depends: base- , servant- , doctest- , filemanip- , directory- , filepath- type: exitcode-stdio-1.0- main-is: test/doctests.hs- buildable: True- default-language: Haskell2010- ghc-options: -Wall -threaded- if impl(ghc >= 8.2)- x-doctest-options: -fdiagnostics-color=never- include-dirs: include+ build-depends:+ base+ , servant-server+ , doctest >= 0.13.0 && <0.14+ type: exitcode-stdio-1.0+ main-is: test/doctests.hs+ buildable: True+ default-language: Haskell2010+ ghc-options: -Wall -threaded+ if impl(ghc >= 8.2)+ x-doctest-options: -fdiagnostics-color=never+ include-dirs: include
src/Servant/Server.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-}
src/Servant/Server/Internal.hs view
@@ -4,7 +4,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-}@@ -13,7 +12,16 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} +#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802+#define HAS_TYPE_ERROR+#endif++#ifdef HAS_TYPE_ERROR+{-# LANGUAGE UndecidableInstances #-}+#endif+ #include "overlapping-compat.h" module Servant.Server.Internal@@ -26,14 +34,17 @@ , module Servant.Server.Internal.ServantErr ) where +import Control.Monad (join, when) import Control.Monad.Trans (liftIO) import Control.Monad.Trans.Resource (runResourceT) import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as BL-import Data.Maybe (fromMaybe, mapMaybe)+import Data.Maybe (fromMaybe, mapMaybe,+ isNothing, maybeToList) import Data.Either (partitionEithers)-import Data.String (fromString)+import Data.String (IsString (..)) import Data.String.Conversions (cs, (<>)) import Data.Tagged (Tagged(..), retag, untag) import qualified Data.Text as T@@ -41,31 +52,40 @@ import GHC.TypeLits (KnownNat, KnownSymbol, natVal, symbolVal) import Network.HTTP.Types hiding (Header, ResponseHeaders)+import qualified Network.HTTP.Media as NHM import Network.Socket (SockAddr) import Network.Wai (Application, Request, httpVersion, isSecure, lazyRequestBody, rawQueryString, remoteHost, requestHeaders, requestMethod,- responseLBS, vault)+ responseLBS, responseStream,+ vault) import Prelude () import Prelude.Compat import Web.HttpApiData (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPieceMaybe, parseUrlPieces)-import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture,+import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture', CaptureAll, Verb, EmptyAPI, ReflectMethod(reflectMethod),- IsSecure(..), Header, QueryFlag,- QueryParam, QueryParams, Raw,- RemoteHost, ReqBody, Vault,+ IsSecure(..), Header', QueryFlag,+ QueryParam', QueryParams, Raw,+ RemoteHost, ReqBody', Vault, WithNamedContext,- Description, Summary)+ Description, Summary,+ Accept(..),+ FramingRender(..), Stream,+ StreamGenerator(..), ToStreamGenerator(..),+ BoundaryStrategy(..),+ If, SBool (..), SBoolI (..))+import Servant.API.Modifiers (unfoldRequestArgument, RequestArgument, FoldRequired, FoldLenient) import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..), AllMime,+ MimeRender(..), canHandleAcceptH) import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders, getResponse)@@ -77,6 +97,9 @@ import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr +#ifdef HAS_TYPE_ERROR+import GHC.TypeLits (TypeError, ErrorMessage (..))+#endif class HasServer api context where type ServerT api (m :: * -> *) :: *@@ -141,9 +164,9 @@ -- > where getBook :: Text -> Handler Book -- > getBook isbn = ... instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)- => HasServer (Capture capture a :> api) context where+ => HasServer (Capture' mods capture a :> api) context where - type ServerT (Capture capture a :> api) m =+ type ServerT (Capture' mods capture a :> api) m = a -> ServerT api m hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s@@ -257,6 +280,70 @@ where method = reflectMethod (Proxy :: Proxy method) status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) ++instance OVERLAPPABLE_+ ( MimeRender ctype a, ReflectMethod method,+ FramingRender framing ctype, ToStreamGenerator f a+ ) => HasServer (Stream method framing ctype (f a)) context where++ type ServerT (Stream method framing ctype (f a)) m = m (f a)+ hoistServerWithContext _ _ nt s = nt s++ route Proxy _ = streamRouter ([],) method (Proxy :: Proxy framing) (Proxy :: Proxy ctype)+ where method = reflectMethod (Proxy :: Proxy method)++instance OVERLAPPING_+ ( MimeRender ctype a, ReflectMethod method,+ FramingRender framing ctype, ToStreamGenerator f a,+ GetHeaders (Headers h (f a))+ ) => HasServer (Stream method framing ctype (Headers h (f a))) context where++ type ServerT (Stream method framing ctype (Headers h (f a))) m = m (Headers h (f a))+ hoistServerWithContext _ _ nt s = nt s++ route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy framing) (Proxy :: Proxy ctype)+ where method = reflectMethod (Proxy :: Proxy method)+++streamRouter :: (MimeRender ctype a, FramingRender framing ctype, ToStreamGenerator f a) =>+ (b -> ([(HeaderName, B.ByteString)], f a))+ -> Method+ -> Proxy framing+ -> Proxy ctype+ -> Delayed env (Handler b)+ -> Router env+streamRouter splitHeaders method framingproxy ctypeproxy action = leafRouter $ \env request respond ->+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders 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 $ responseStream status200 (contentHeader : headers) $ \write flush -> do+ write . 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 write ( BB.lazyByteString before+ <> BB.lazyByteString bs+ <> BB.lazyByteString after) >> flush+ in k go go+ BoundaryStrategyIntersperse sep -> k+ (\x -> do+ write . BB.lazyByteString . mimeRender ctypeproxy $ x+ flush)+ (\x -> do+ write . (BB.lazyByteString sep <>) . BB.lazyByteString . mimeRender ctypeproxy $ x+ flush)+ BoundaryStrategyGeneral f ->+ let go = (>> flush) . write . BB.lazyByteString . f . mimeRender ctypeproxy+ in k go go+ write . BB.lazyByteString $ trailer framingproxy ctypeproxy+ -- | 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'.@@ -277,30 +364,40 @@ -- > server = viewReferer -- > where viewReferer :: Referer -> Handler referer -- > viewReferer referer = return referer-instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)- => HasServer (Header sym a :> api) context where-- type ServerT (Header sym a :> api) m =- Maybe a -> ServerT api m+instance+ (KnownSymbol sym, FromHttpApiData a, HasServer api context+ , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)+ )+ => HasServer (Header' mods sym a :> api) context where+------+ type ServerT (Header' mods sym a :> api) m =+ RequestArgument mods a -> ServerT api m hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context subserver = route (Proxy :: Proxy api) context $ subserver `addHeaderCheck` withRequest headerCheck where- headerName = symbolVal (Proxy :: Proxy sym)+ headerName :: IsString n => n+ headerName = fromString $ symbolVal (Proxy :: Proxy sym)++ headerCheck :: Request -> DelayedIO (RequestArgument mods a) headerCheck req =- case lookup (fromString headerName) (requestHeaders req) of- Nothing -> return Nothing- Just txt ->- case parseHeader txt of- Left e -> delayedFailFatal err400- { errBody = cs $ "Error parsing header "- <> fromString headerName- <> " failed: " <> e- }- Right header -> return $ Just header+ unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev+ where+ mev :: Maybe (Either T.Text a)+ mev = fmap parseHeader $ lookup headerName (requestHeaders 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'@.@@ -322,33 +419,41 @@ -- > where getBooksBy :: Maybe Text -> Handler [Book] -- > getBooksBy Nothing = ...return all books... -- > getBooksBy (Just author) = ...return books by the given author...-instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)- => HasServer (QueryParam sym a :> api) context where-- type ServerT (QueryParam sym a :> api) m =- Maybe a -> ServerT api m+instance+ ( KnownSymbol sym, FromHttpApiData a, HasServer api context+ , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)+ )+ => HasServer (QueryParam' mods sym a :> api) context where+------+ type ServerT (QueryParam' mods sym a :> api) m =+ RequestArgument mods a -> ServerT api m hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context subserver = let querytext req = parseQueryText $ rawQueryString req+ paramname = cs $ symbolVal (Proxy :: Proxy sym)++ parseParam :: Request -> DelayedIO (RequestArgument mods a) parseParam req =- case lookup paramname (querytext req) of- Nothing -> return Nothing -- param absent from the query string- Just Nothing -> return Nothing -- param present with no value -> Nothing- Just (Just v) ->- case parseQueryParam v of- Left e -> delayedFailFatal err400- { errBody = cs $ "Error parsing query parameter "- <> paramname <> " failed: " <> e- }+ unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev+ where+ mev :: Maybe (Either T.Text a)+ mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req - Right param -> return $ Just param+ 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 $ \req -> parseParam req in route (Proxy :: Proxy api) context delayed- where paramname = cs $ symbolVal (Proxy :: Proxy sym) -- | 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@@ -477,11 +582,11 @@ -- > server = postBook -- > where postBook :: Book -> Handler Book -- > postBook book = ...insert into your db...-instance ( AllCTUnrender list a, HasServer api context- ) => HasServer (ReqBody list a :> api) context where+instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods)+ ) => HasServer (ReqBody' mods list a :> api) context where - type ServerT (ReqBody list a :> api) m =- a -> ServerT api m+ type ServerT (ReqBody' mods list a :> api) m =+ If (FoldLenient mods) (Either String a) a -> ServerT api m hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s @@ -504,9 +609,11 @@ -- Body check, we get a body parsing functions as the first argument. bodyCheck f = withRequest $ \ request -> do mrqbody <- f <$> liftIO (lazyRequestBody request)- case mrqbody of- Left e -> delayedFailFatal err400 { errBody = cs e }- Right v -> return v+ 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 @api@.@@ -629,3 +736,75 @@ subContext = descendIntoNamedContext (Proxy :: Proxy name) context hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s++-------------------------------------------------------------------------------+-- TypeError helpers+-------------------------------------------------------------------------------++#ifdef HAS_TYPE_ERROR+-- | This instance catches mistakes when there are non-saturated+-- type applications on LHS of ':>'.+--+-- >>> serve (Proxy :: Proxy (Capture "foo" :> Get '[JSON] Int)) (error "...")+-- ...+-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.+-- ...Maybe you haven't applied enough arguments to+-- ...Capture' '[] "foo"+-- ...+--+-- >>> undefined :: Server (Capture "foo" :> Get '[JSON] Int)+-- ...+-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.+-- ...Maybe you haven't applied enough arguments to+-- ...Capture' '[] "foo"+-- ...+-- +instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context+ where+ type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr)+ -- it doens't really matter what sub route we peak+ route _ _ _ = error "servant-server panic: impossible happened in HasServer (arr :> api)"+ hoistServerWithContext _ _ _ = id++-- Cannot have TypeError here, otherwise use of this symbol will error :)+type HasServerArrowKindError arr =+ 'Text "Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'."+ ':$$: 'Text "Maybe you haven't applied enough arguments to"+ ':$$: 'ShowType arr++-- | This instance prevents from accidentally using '->' instead of ':>'+--+-- >>> serve (Proxy :: Proxy (Capture "foo" Int -> Get '[JSON] Int)) (error "...")+-- ...+-- ...No instance HasServer (a -> b).+-- ...Maybe you have used '->' instead of ':>' between+-- ...Capture' '[] "foo" Int+-- ...and+-- ...Verb 'GET 200 '[JSON] Int+-- ...+--+-- >>> undefined :: Server (Capture "foo" Int -> Get '[JSON] Int)+-- ...+-- ...No instance HasServer (a -> b).+-- ...Maybe you have used '->' instead of ':>' between+-- ...Capture' '[] "foo" Int+-- ...and+-- ...Verb 'GET 200 '[JSON] Int+-- ...+--+instance TypeError (HasServerArrowTypeError a b) => HasServer (a -> b) context+ where+ type ServerT (a -> b) m = TypeError (HasServerArrowTypeError a b)+ route _ _ _ = error "servant-server panic: impossible happened in HasServer (a -> b)"+ hoistServerWithContext _ _ _ = id++type HasServerArrowTypeError a b =+ 'Text "No instance HasServer (a -> b)."+ ':$$: 'Text "Maybe you have used '->' instead of ':>' between "+ ':$$: 'ShowType a+ ':$$: 'Text "and"+ ':$$: 'ShowType b+#endif++-- $setup+-- >>> import Servant
src/Servant/Server/Internal/Handler.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}
src/Servant/Server/Internal/Router.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} module Servant.Server.Internal.Router where
src/Servant/Server/Internal/RoutingApplication.hs view
@@ -3,12 +3,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}@@ -17,11 +13,11 @@ import Control.Monad (ap, liftM) import Control.Monad.Base (MonadBase (..)) import Control.Monad.Catch (MonadThrow (..))-import Control.Monad.Reader (MonadReader (..), ReaderT, runReaderT)+import Control.Monad.Reader (MonadReader (..), ReaderT (..), runReaderT) import Control.Monad.Trans (MonadIO (..), MonadTrans (..)) import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), MonadTransControl (..), defaultLiftBaseWith, defaultRestoreM)-import Control.Monad.Trans.Resource (MonadResource (..), ResourceT, runResourceT, transResourceT)+import Control.Monad.Trans.Resource (MonadResource (..), ResourceT, runResourceT, transResourceT, withInternalState, runInternalState) import Network.Wai (Application, Request, Response, ResponseReceived) import Prelude () import Prelude.Compat@@ -82,13 +78,12 @@ instance MonadTransControl RouteResultT where type StT RouteResultT a = RouteResult a- liftWith f = RouteResultT $ liftM return $ f $ runRouteResultT+ liftWith f = RouteResultT $ liftM return $ f runRouteResultT restoreT = RouteResultT instance MonadThrow m => MonadThrow (RouteResultT m) where throwM = lift . throwM - toApplication :: RoutingApplication -> Application toApplication ra request respond = ra request routingRespond where@@ -198,19 +193,28 @@ deriving ( Functor, Applicative, Monad , MonadIO, MonadReader Request- , MonadBase IO , MonadThrow , MonadResource ) +instance MonadBase IO DelayedIO where+ liftBase = liftIO+ liftRouteResult :: RouteResult a -> DelayedIO a liftRouteResult x = DelayedIO $ lift . lift $ RouteResultT . return $ x instance MonadBaseControl IO DelayedIO where- type StM DelayedIO a = StM (ReaderT Request (ResourceT (RouteResultT IO))) a- liftBaseWith f = DelayedIO $ liftBaseWith $ \g -> f (g . runDelayedIO')- restoreM = DelayedIO . restoreM+ -- type StM DelayedIO a = StM (ReaderT Request (ResourceT (RouteResultT IO))) a+ -- liftBaseWith f = DelayedIO $ liftBaseWith $ \g -> f (g . runDelayedIO')+ -- restoreM = DelayedIO . restoreM + type StM DelayedIO a = RouteResult a+ liftBaseWith f = DelayedIO $ ReaderT $ \req -> withInternalState $ \s ->+ liftBaseWith $ \runInBase -> f $ \x ->+ runInBase (runInternalState (runReaderT (runDelayedIO' x) req) s)+ restoreM = DelayedIO . lift . withInternalState . const . restoreM++ runDelayedIO :: DelayedIO a -> Request -> ResourceT IO (RouteResult a) runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO' m) req @@ -367,7 +371,7 @@ -> (RouteResult Response -> IO r) -> (a -> RouteResult Response) -> IO r-runAction action env req respond k = runResourceT $ do+runAction action env req respond k = runResourceT $ runDelayed action env req >>= go >>= liftIO . respond where go (Fail e) = return $ Fail e
test/Servant/ServerSpec.hs view
@@ -3,7 +3,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -33,11 +32,7 @@ methodDelete, methodGet, methodHead, methodPatch, methodPost, methodPut, ok200,-#if MIN_VERSION_http_types(0,10,0) imATeapot418,-#else- imATeaPot418,-#endif parseQuery) import Network.Wai (Application, Request, requestHeaders, pathInfo, queryString, rawQueryString,@@ -47,7 +42,7 @@ simpleHeaders, simpleStatus) import Servant.API ((:<|>) (..), (:>), AuthProtect, BasicAuth, BasicAuthData(BasicAuthData),- Capture, CaptureAll, Delete, Get, Header (..),+ Capture, CaptureAll, Delete, Get, Header, Headers, HttpVersion, IsSecure (..), JSON, NoContent (..), Patch, PlainText,@@ -74,11 +69,6 @@ import Servant.Server.Internal.Context (NamedContext(..)) -#if !MIN_VERSION_http_types(0,10,0)-imATeapot418 :: Status-imATeapot418 = imATeaPot418-#endif- -- * comprehensive api test -- This declaration simply checks that all instances are in place.@@ -461,8 +451,8 @@ ------------------------------------------------------------------------------ type HeaderApi a = Header "MyHeader" a :> Delete '[JSON] NoContent-headerApi :: Proxy (HeaderApi a)-headerApi = Proxy+headerApi :: Proxy a -> Proxy (HeaderApi a)+headerApi _ = Proxy headerSpec :: Spec headerSpec = describe "Servant.API.Header" $ do@@ -479,19 +469,19 @@ return NoContent expectsString Nothing = error "Expected a string" - with (return (serve headerApi expectsInt)) $ do+ with (return (serve (headerApi (Proxy :: Proxy Int)) expectsInt)) $ do let delete' x = THW.request methodDelete x [("MyHeader", "5")] it "passes the header to the handler (Int)" $ delete' "/" "" `shouldRespondWith` 200 - with (return (serve headerApi expectsString)) $ do+ with (return (serve (headerApi (Proxy :: Proxy String)) expectsString)) $ do let delete' x = THW.request methodDelete x [("MyHeader", "more from you")] it "passes the header to the handler (String)" $ delete' "/" "" `shouldRespondWith` 200 - with (return (serve headerApi expectsInt)) $ do+ with (return (serve (headerApi (Proxy :: Proxy Int)) expectsInt)) $ do let delete' x = THW.request methodDelete x [("MyHeader", "not a number")] it "checks for parse errors" $