diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ---- diff --git a/servant-server.cabal b/servant-server.cabal --- a/servant-server.cabal +++ b/servant-server.cabal @@ -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 diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs --- a/src/Servant/Server.hs +++ b/src/Servant/Server.hs @@ -1,7 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} 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 @@ -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 diff --git a/src/Servant/Server/Internal/Handler.hs b/src/Servant/Server/Internal/Handler.hs --- a/src/Servant/Server/Internal/Handler.hs +++ b/src/Servant/Server/Internal/Handler.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} diff --git a/src/Servant/Server/Internal/Router.hs b/src/Servant/Server/Internal/Router.hs --- a/src/Servant/Server/Internal/Router.hs +++ b/src/Servant/Server/Internal/Router.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} module Servant.Server.Internal.Router where 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 @@ -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 diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -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" $