diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,56 @@ [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.15 +---- + +- Streaming refactoring. + [#991](https://github.com/haskell-servant/servant/pull/991) + [#1076](https://github.com/haskell-servant/servant/pull/1076) + [#1077](https://github.com/haskell-servant/servant/pull/1077) + + The streaming functionality (`Servant.API.Stream`) is refactored to use + `servant`'s own `SourceIO` type (see `Servant.Types.SourceT` documentation), + which replaces both `StreamGenerator` and `ResultStream` types. + + New conversion type-classes are `ToSourceIO` and `FromSourceIO` + (replacing `ToStreamGenerator` and `BuildFromStream`). + There are instances for *conduit*, *pipes* and *machines* in new packages: + [servant-conduit](https://hackage.haskell.org/package/servant-conduit) + [servant-pipes](https://hackage.haskell.org/package/servant-pipes) and + [servant-machines](https://hackage.haskell.org/package/servant-machines) + respectively. + + Writing new framing strategies is simpler. Check existing strategies for examples. + + This change shouldn't affect you, if you don't use streaming endpoints. + +- Drop support for GHC older than 8.0 + [#1008](https://github.com/haskell-servant/servant/pull/1008) + [#1009](https://github.com/haskell-servant/servant/pull/1009) + +- *servant* NewlineFraming encodes newline after each element (i.e last) + [#1079](https://github.com/haskell-servant/servant/pull/1079) + [#1011](https://github.com/haskell-servant/servant/issues/1011) + +- *servant* Add `lookupResponseHeader :: ... => Headers headers r -> ResponseHeader h a` + [#1064](https://github.com/haskell-servant/servant/pull/1064) + +- *servant-server* Add `MonadMask Handler` + [#1068](https://github.com/haskell-servant/servant/pull/1068) + +- *servant* Export `GetHeaders'` + [#1052](https://github.com/haskell-servant/servant/pull/1052) + +- *servant* Add `Bitraversable` and other `Bi-` instances for `:<|>` + [#1032](https://github.com/haskell-servant/servant/pull/1032) + +- *servant* Add `PutCreated` method type alias + [#1024](https://github.com/haskell-servant/servant/pull/1024) + +- *servant* Add `ToSourceIO (NonEmpty a)` instance + [#988](https://github.com/haskell-servant/servant/pull/988) + 0.14.1 ------ diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors +Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors All rights reserved. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wall #-} +module Main (main) where + +#ifndef MIN_VERSION_cabal_doctest +#define MIN_VERSION_cabal_doctest(x,y,z) 0 +#endif + +#if MIN_VERSION_cabal_doctest(1,0,0) + +import Distribution.Extra.Doctest ( defaultMainWithDoctests ) +main :: IO () +main = defaultMainWithDoctests "doctests" + +#else + +#ifdef MIN_VERSION_Cabal +-- If the macro is defined, we have new cabal-install, +-- but for some reason we don't have cabal-doctest in package-db +-- +-- Probably we are running cabal sdist, when otherwise using new-build +-- workflow +#warning You are configuring this package without cabal-doctest installed. \ + The doctests test-suite will not work as a result. \ + To fix this, install cabal-doctest before configuring. +#endif + +import Distribution.Simple + +main :: IO () +main = defaultMain + +#endif diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,31 +0,0 @@ -\begin{code} -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wall #-} -module Main (main) where - -#ifndef MIN_VERSION_cabal_doctest -#define MIN_VERSION_cabal_doctest(x,y,z) 0 -#endif - -#if MIN_VERSION_cabal_doctest(1,0,0) - -import Distribution.Extra.Doctest ( defaultMainWithDoctests ) -main :: IO () -main = defaultMainWithDoctests "doctests" - -#else - -#ifdef MIN_VERSION_Cabal -#warning You are configuring this package without cabal-doctest installed. \ - The doctests test-suite will not work as a result. \ - To fix this, install cabal-doctest before configuring. -#endif - -import Distribution.Simple - -main :: IO () -main = defaultMain - -#endif - -\end{code} diff --git a/example/greet.hs b/example/greet.hs --- a/example/greet.hs +++ b/example/greet.hs @@ -5,8 +5,10 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +import Prelude () +import Prelude.Compat + import Data.Aeson -import Data.Monoid import Data.Proxy import Data.Text import GHC.Generics diff --git a/include/overlapping-compat.h b/include/overlapping-compat.h deleted file mode 100644 --- a/include/overlapping-compat.h +++ /dev/null @@ -1,8 +0,0 @@ -#if __GLASGOW_HASKELL__ >= 710 -#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} -#define OVERLAPPING_ {-# OVERLAPPING #-} -#else -{-# LANGUAGE OverlappingInstances #-} -#define OVERLAPPABLE_ -#define OVERLAPPING_ -#endif diff --git a/servant-server.cabal b/servant-server.cabal --- a/servant-server.cabal +++ b/servant-server.cabal @@ -1,6 +1,9 @@ +cabal-version: >=1.10 name: servant-server -version: 0.14.1 +version: 0.15 + synopsis: A family of combinators for defining webservices APIs and serving them +category: Servant, Web description: A family of combinators for defining webservices APIs and serving them . @@ -11,24 +14,22 @@ a webserver that serves this API, using this package. . + homepage: http://haskell-servant.readthedocs.org/ -Bug-reports: http://github.com/haskell-servant/servant/issues +bug-reports: http://github.com/haskell-servant/servant/issues license: BSD3 license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com -copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors -category: Servant, Web +copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors build-type: Custom -cabal-version: >=1.10 tested-with: - GHC==7.8.4 - GHC==7.10.3 - GHC==8.0.2 - GHC==8.2.2 - GHC==8.4.3 + GHC ==8.0.2 + || ==8.2.2 + || ==8.4.4 + || ==8.6.2 + extra-source-files: - include/*.h CHANGELOG.md README.md @@ -63,52 +64,43 @@ -- 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.12 - , 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 - - if !impl(ghc >= 8.0) - build-depends: - semigroups >= 0.18.4 && < 0.19 + base >= 4.9 && < 4.13 + , bytestring >= 0.10.8.1 && < 0.11 + , containers >= 0.5.7.1 && < 0.7 + , mtl >= 2.2.2 && < 2.3 + , text >= 1.2.3.0 && < 1.3 + , transformers >= 0.5.2.0 && < 0.6 + , filepath >= 1.4.1.1 && < 1.5 -- Servant dependencies + -- strict dependency as we re-export 'servant' things. build-depends: - servant >= 0.14.1 && <0.15 + servant >= 0.15 && < 0.15.1 + , http-api-data >= 0.4 && < 0.4.1 -- 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: - base-compat >= 0.10.1 && < 0.11 + base-compat >= 0.10.5 && < 0.11 , base64-bytestring >= 1.0.0.1 && < 1.1 , exceptions >= 0.10.0 && < 0.11 - , http-api-data >= 0.3.8.1 && < 0.4 - , http-media >= 0.7.1.2 && < 0.8 - , http-types >= 0.12.1 && < 0.13 + , http-media >= 0.7.1.3 && < 0.8 + , http-types >= 0.12.2 && < 0.13 , network-uri >= 2.6.1.0 && < 2.7 , monad-control >= 1.0.2.3 && < 1.1 - , network >= 2.6.3.5 && < 2.8 + , network >= 2.8 && < 2.9 , string-conversions >= 0.4.0.1 && < 0.5 - , resourcet >= 1.1.11 && < 1.3 - , tagged >= 0.8.5 && < 0.9 - , transformers-base >= 0.4.4 && < 0.5 - , transformers-compat >= 0.6.2 && < 0.7 - , wai >= 3.2.1.1 && < 3.3 - , wai-app-static >= 3.1.6.1 && < 3.2 + , resourcet >= 1.2.2 && < 1.3 + , tagged >= 0.8.6 && < 0.9 + , transformers-base >= 0.4.5.2 && < 0.5 + , wai >= 3.2.1.2 && < 3.3 + , wai-app-static >= 3.1.6.2 && < 3.2 , word8 >= 0.1.3 && < 0.2 hs-source-dirs: src default-language: Haskell2010 - ghc-options: -Wall - if impl(ghc >= 8.0) - ghc-options: -Wno-redundant-constraints - include-dirs: include + ghc-options: -Wall -Wno-redundant-constraints executable greet main-is: greet.hs @@ -117,14 +109,15 @@ default-language: Haskell2010 build-depends: base + , base-compat , servant , servant-server , wai , text build-depends: - aeson >= 1.3.1.1 && < 1.5 - , warp >= 3.2.13 && < 3.3 + aeson >= 1.4.1.0 && < 1.5 + , warp >= 3.2.25 && < 3.3 test-suite spec type: exitcode-stdio-1.0 @@ -165,23 +158,23 @@ -- Additonal dependencies build-depends: - aeson >= 1.3.1.1 && < 1.5 - , directory >= 1.2.1.0 && < 1.4 - , hspec >= 2.5.1 && < 2.6 + aeson >= 1.4.1.0 && < 1.5 + , directory >= 1.3.0.0 && < 1.4 + , hspec >= 2.6.0 && < 2.7 , hspec-wai >= 0.9.0 && < 0.10 - , QuickCheck >= 2.11.3 && < 2.12 + , QuickCheck >= 2.12.6.1 && < 2.13 , should-not-typecheck >= 2.1.0 && < 2.2 , temporary >= 1.3 && < 1.4 - , wai-extra >= 3.0.21.0 && < 3.1 + , wai-extra >= 3.0.24.3 && < 3.1 build-tool-depends: - hspec-discover:hspec-discover >= 2.5.1 && <2.6 + hspec-discover:hspec-discover >= 2.6.0 && <2.7 test-suite doctests build-depends: base , servant-server - , doctest >= 0.15.0 && <0.17 + , doctest >= 0.16.0 && <0.17 type: exitcode-stdio-1.0 main-is: test/doctests.hs buildable: True @@ -189,4 +182,3 @@ ghc-options: -Wall -threaded if impl(ghc >= 8.2) x-doctest-options: -fdiagnostics-color=never - include-dirs: include diff --git a/src/Servant.hs b/src/Servant.hs --- a/src/Servant.hs +++ b/src/Servant.hs @@ -7,15 +7,16 @@ module Servant.Server, -- | Utilities on top of the servant core module Servant.Links, - module Servant.Utils.StaticFiles, + module Servant.Server.StaticFiles, -- | Useful re-exports Proxy(..), throwError ) where -import Control.Monad.Error.Class (throwError) +import Control.Monad.Error.Class + (throwError) import Data.Proxy import Servant.API -import Servant.Server import Servant.Links -import Servant.Utils.StaticFiles +import Servant.Server +import Servant.Server.StaticFiles diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs --- a/src/Servant/Server.hs +++ b/src/Servant/Server.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} -- | This module lets you implement 'Server's for defined APIs. You'll -- most likely just need 'serve'. @@ -92,10 +92,14 @@ ) where -import Data.Proxy (Proxy (..)) -import Data.Tagged (Tagged (..)) -import Data.Text (Text) -import Network.Wai (Application) +import Data.Proxy + (Proxy (..)) +import Data.Tagged + (Tagged (..)) +import Data.Text + (Text) +import Network.Wai + (Application) import Servant.Server.Internal diff --git a/src/Servant/Server/Experimental/Auth.hs b/src/Servant/Server/Experimental/Auth.hs --- a/src/Servant/Server/Experimental/Auth.hs +++ b/src/Servant/Server/Experimental/Auth.hs @@ -1,33 +1,37 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Servant.Server.Experimental.Auth where -import Control.Monad.Trans (liftIO) -import Data.Proxy (Proxy (Proxy)) -import Data.Typeable (Typeable) -import GHC.Generics (Generic) -import Network.Wai (Request) +import Control.Monad.Trans + (liftIO) +import Data.Proxy + (Proxy (Proxy)) +import Data.Typeable + (Typeable) +import GHC.Generics + (Generic) +import Network.Wai + (Request) -import Servant ((:>)) +import Servant + ((:>)) import Servant.API.Experimental.Auth -import Servant.Server.Internal (HasContextEntry, - HasServer (..), - getContextEntry) -import Servant.Server.Internal.RoutingApplication (addAuthCheck, - delayedFailFatal, - DelayedIO, - withRequest) -import Servant.Server.Internal.Handler (Handler, runHandler) +import Servant.Server.Internal + (HasContextEntry, HasServer (..), getContextEntry) +import Servant.Server.Internal.Handler + (Handler, runHandler) +import Servant.Server.Internal.RoutingApplication + (DelayedIO, addAuthCheck, delayedFailFatal, withRequest) -- * General Auth diff --git a/src/Servant/Server/Generic.hs b/src/Servant/Server/Generic.hs --- a/src/Servant/Server/Generic.hs +++ b/src/Servant/Server/Generic.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -11,6 +12,8 @@ AsServerT, AsServer, genericServe, + genericServeT, + genericServeTWithContext, genericServer, genericServerT, ) where @@ -37,6 +40,45 @@ ) => routes AsServer -> Application genericServe = serve (Proxy :: Proxy (ToServantApi routes)) . genericServer + +-- | Transform a record of routes with custom monad into a WAI 'Application', +-- by providing a transformation to bring each handler back in the 'Handler' +-- monad. +genericServeT + :: forall (routes :: * -> *) (m :: * -> *). + ( GenericServant routes (AsServerT m) + , GenericServant routes AsApi + , HasServer (ToServantApi routes) '[] + , ServerT (ToServantApi routes) m ~ ToServant routes (AsServerT m) + ) + => (forall a. m a -> Handler a) -- ^ 'hoistServer' argument to come back to 'Handler' + -> routes (AsServerT m) -- ^ your record full of request handlers + -> Application +genericServeT f server = serve p $ hoistServer p f (genericServerT server) + where + p = genericApi (Proxy :: Proxy routes) + +-- | Transform a record of routes with custom monad into a WAI 'Application', +-- while using the given 'Context' to serve the application (contexts are typically +-- used by auth-related combinators in servant, e.g to hold auth checks) and the given +-- transformation to map all the handlers back to the 'Handler' monad. +genericServeTWithContext + :: forall (routes :: * -> *) (m :: * -> *) (ctx :: [*]). + ( GenericServant routes (AsServerT m) + , GenericServant routes AsApi + , HasServer (ToServantApi routes) ctx + , ServerT (ToServantApi routes) m ~ ToServant routes (AsServerT m) + ) + => (forall a. m a -> Handler a) -- ^ 'hoistServer' argument to come back to 'Handler' + -> routes (AsServerT m) -- ^ your record full of request handlers + -> Context ctx -- ^ the 'Context' to serve the application with + -> Application +genericServeTWithContext f server ctx = + serveWithContext p ctx $ + hoistServerWithContext p pctx f (genericServerT server) + where + p = genericApi (Proxy :: Proxy routes) + pctx = Proxy :: Proxy ctx -- | Transform record of endpoints into a 'Server'. genericServer 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 @@ -1,29 +1,23 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# 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 ( module Servant.Server.Internal , module Servant.Server.Internal.BasicAuth @@ -34,72 +28,74 @@ , 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, - isNothing, maybeToList) -import Data.Either (partitionEithers) -import Data.Semigroup ((<>)) -import Data.String (IsString (..)) -import Data.String.Conversions (cs) -import Data.Tagged (Tagged(..), retag, untag) -import qualified Data.Text as T +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.Either + (partitionEithers) +import Data.Maybe + (fromMaybe, isNothing, mapMaybe, maybeToList) +import Data.Semigroup + ((<>)) +import Data.String + (IsString (..)) +import Data.String.Conversions + (cs) +import Data.Tagged + (Tagged (..), retag, untag) +import qualified Data.Text as T import Data.Typeable -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, responseStream, - vault) -import Prelude () +import GHC.TypeLits + (KnownNat, KnownSymbol, natVal, symbolVal) +import qualified Network.HTTP.Media as NHM +import Network.HTTP.Types hiding + (Header, ResponseHeaders) +import Network.Socket + (SockAddr) +import Network.Wai + (Application, Request, httpVersion, isSecure, lazyRequestBody, + rawQueryString, remoteHost, requestBody, requestHeaders, + requestMethod, responseLBS, responseStream, vault) +import Prelude () import Prelude.Compat -import Web.HttpApiData (FromHttpApiData, parseHeader, - parseQueryParam, - parseUrlPieceMaybe, - parseUrlPieces) -import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture', - CaptureAll, Verb, EmptyAPI, - ReflectMethod(reflectMethod), - IsSecure(..), Header', QueryFlag, - QueryParam', QueryParams, Raw, - RemoteHost, ReqBody', Vault, - WithNamedContext, - 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) +import Servant.API + ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture', + CaptureAll, Description, EmptyAPI, FramingRender (..), + FramingUnrender (..), FromSourceIO (..), Header', If, + IsSecure (..), QueryFlag, QueryParam', QueryParams, Raw, + ReflectMethod (reflectMethod), RemoteHost, ReqBody', + SBool (..), SBoolI (..), SourceIO, Stream, StreamBody', + Summary, ToSourceIO (..), Vault, Verb, WithNamedContext) +import Servant.API.ContentTypes + (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..), + AllMime, MimeRender (..), MimeUnrender (..), canHandleAcceptH) +import Servant.API.Modifiers + (FoldLenient, FoldRequired, RequestArgument, + unfoldRequestArgument) +import Servant.API.ResponseHeaders + (GetHeaders, Headers, getHeaders, getResponse) +import qualified Servant.Types.SourceT as S +import Web.HttpApiData + (FromHttpApiData, parseHeader, parseQueryParam, + parseUrlPieceMaybe, parseUrlPieces) -import Servant.Server.Internal.Context import Servant.Server.Internal.BasicAuth +import Servant.Server.Internal.Context import Servant.Server.Internal.Handler import Servant.Server.Internal.Router import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr #ifdef HAS_TYPE_ERROR -import GHC.TypeLits (TypeError, ErrorMessage (..)) +import GHC.TypeLits + (ErrorMessage (..), TypeError) #endif class HasServer api context where @@ -258,7 +254,7 @@ let bdy = if allowedMethodHead method request then "" else body in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy -instance OVERLAPPABLE_ +instance {-# OVERLAPPABLE #-} ( AllCTRender ctypes a, ReflectMethod method, KnownNat status ) => HasServer (Verb method status ctypes a) context where @@ -269,7 +265,7 @@ where method = reflectMethod (Proxy :: Proxy method) status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) -instance OVERLAPPING_ +instance {-# OVERLAPPING #-} ( AllCTRender ctypes a, ReflectMethod method, KnownNat status , GetHeaders (Headers h a) ) => HasServer (Verb method status ctypes (Headers h a)) context where @@ -282,25 +278,26 @@ 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 where +instance {-# OVERLAPPABLE #-} + ( MimeRender ctype chunk, ReflectMethod method, KnownNat status, + FramingRender framing, ToSourceIO chunk a + ) => HasServer (Stream method status framing ctype a) context where - type ServerT (Stream method status framing ctype b) m = m b + type ServerT (Stream method status framing ctype a) m = m a 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 OVERLAPPING_ - ( 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 where - type ServerT (Stream method status framing ctype (Headers h b)) m = m (Headers h b) +instance {-# OVERLAPPING #-} + ( MimeRender ctype chunk, ReflectMethod method, KnownNat status, + FramingRender framing, ToSourceIO chunk a, + GetHeaders (Headers h a) + ) => HasServer (Stream method status framing ctype (Headers h a)) context where + + type ServerT (Stream method status framing ctype (Headers h a)) m = m (Headers h a) hoistServerWithContext _ _ nt s = nt s route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype) @@ -308,8 +305,8 @@ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) -streamRouter :: (MimeRender ctype a, FramingRender framing ctype, ToStreamGenerator b a) => - (c -> ([(HeaderName, B.ByteString)], b)) +streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) => + (c -> ([(HeaderName, B.ByteString)], a)) -> Method -> Status -> Proxy framing @@ -325,29 +322,20 @@ `addAcceptCheck` accCheck ) env request respond $ \ output -> let (headers, fa) = splitHeaders output - k = getStreamGenerator . toStreamGenerator $ fa in - Route $ responseStream status (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 + sourceT = toSourceIO fa + S.SourceT kStepLBS = framingRender framingproxy (mimeRender ctypeproxy :: chunk -> BL.ByteString) sourceT + in Route $ responseStream status (contentHeader : headers) $ \write flush -> do + let loop S.Stop = flush + loop (S.Error err) = fail err -- TODO: throw better error + loop (S.Skip s) = loop s + loop (S.Effect ms) = ms >>= loop + loop (S.Yield lbs s) = do + write (BB.lazyByteString lbs) + flush + loop s + kStepLBS loop + -- | 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'. @@ -619,6 +607,31 @@ Left e -> delayedFailFatal err400 { errBody = cs e } Right v -> return v +instance + ( FramingUnrender framing, FromSourceIO chunk a, MimeUnrender ctype chunk + , HasServer api context + ) => HasServer (StreamBody' mods framing ctype a :> api) context + where + type ServerT (StreamBody' mods framing ctype a :> api) m = a -> ServerT api m + + 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 + ctCheck :: DelayedIO (SourceIO chunk -> a) + -- TODO: do content-type check + ctCheck = return fromSourceIO + + bodyCheck :: (SourceIO chunk -> a) -> DelayedIO a + bodyCheck fromRS = withRequest $ \req -> do + let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk + let framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' :: SourceIO B.ByteString -> SourceIO chunk + let body = requestBody req + let rs = S.fromAction B.null body + let rs' = fromRS $ framingUnrender' rs + return rs' + -- | Make sure the incoming request starts with @"/path"@, strip it and -- pass the rest of the request path to @api@. instance (KnownSymbol path, HasServer api context) => HasServer (path :> api) context where @@ -762,7 +775,7 @@ -- ...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) diff --git a/src/Servant/Server/Internal/BasicAuth.hs b/src/Servant/Server/Internal/BasicAuth.hs --- a/src/Servant/Server/Internal/BasicAuth.hs +++ b/src/Servant/Server/Internal/BasicAuth.hs @@ -1,22 +1,31 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} module Servant.Server.Internal.BasicAuth where -import Control.Monad (guard) -import Control.Monad.Trans (liftIO) -import qualified Data.ByteString as BS -import Data.ByteString.Base64 (decodeLenient) -import Data.Monoid ((<>)) -import Data.Typeable (Typeable) -import Data.Word8 (isSpace, toLower, _colon) +import Control.Monad + (guard) +import Control.Monad.Trans + (liftIO) +import qualified Data.ByteString as BS +import Data.ByteString.Base64 + (decodeLenient) +import Data.Monoid + ((<>)) +import Data.Typeable + (Typeable) +import Data.Word8 + (isSpace, toLower, _colon) import GHC.Generics -import Network.HTTP.Types (Header) -import Network.Wai (Request, requestHeaders) +import Network.HTTP.Types + (Header) +import Network.Wai + (Request, requestHeaders) -import Servant.API.BasicAuth (BasicAuthData(BasicAuthData)) +import Servant.API.BasicAuth + (BasicAuthData (BasicAuthData)) import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr diff --git a/src/Servant/Server/Internal/Context.hs b/src/Servant/Server/Internal/Context.hs --- a/src/Servant/Server/Internal/Context.hs +++ b/src/Servant/Server/Internal/Context.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -8,8 +7,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} -#include "overlapping-compat.h" - module Servant.Server.Internal.Context where import Data.Proxy @@ -64,11 +61,11 @@ class HasContextEntry (context :: [*]) (val :: *) where getContextEntry :: Context context -> val -instance OVERLAPPABLE_ +instance {-# OVERLAPPABLE #-} HasContextEntry xs val => HasContextEntry (notIt ': xs) val where getContextEntry (_ :. xs) = getContextEntry xs -instance OVERLAPPING_ +instance {-# OVERLAPPING #-} HasContextEntry (val ': xs) val where getContextEntry (x :. _) = x 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 @@ -5,23 +5,31 @@ {-# LANGUAGE TypeFamilies #-} module Servant.Server.Internal.Handler where -import Prelude () -import Prelude.Compat +import Prelude () +import Prelude.Compat -import Control.Monad.Base (MonadBase (..)) -import Control.Monad.Catch (MonadCatch, MonadThrow) -import Control.Monad.Error.Class (MonadError) -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Control (MonadBaseControl (..)) -import Control.Monad.Trans.Except (ExceptT, runExceptT) -import GHC.Generics (Generic) -import Servant.Server.Internal.ServantErr (ServantErr) +import Control.Monad.Base + (MonadBase (..)) +import Control.Monad.Catch + (MonadCatch, MonadMask, MonadThrow) +import Control.Monad.Error.Class + (MonadError) +import Control.Monad.IO.Class + (MonadIO) +import Control.Monad.Trans.Control + (MonadBaseControl (..)) +import Control.Monad.Trans.Except + (ExceptT, runExceptT) +import GHC.Generics + (Generic) +import Servant.Server.Internal.ServantErr + (ServantErr) newtype Handler a = Handler { runHandler' :: ExceptT ServantErr IO a } deriving ( Functor, Applicative, Monad, MonadIO, Generic , MonadError ServantErr - , MonadThrow, MonadCatch + , MonadThrow, MonadCatch, MonadMask ) instance MonadBase IO Handler where 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,15 +1,20 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} module Servant.Server.Internal.Router where -import Data.Map (Map) +import Prelude () +import Prelude.Compat + +import Data.Map + (Map) import qualified Data.Map as M -import Data.Monoid -import Data.Text (Text) +import Data.Text + (Text) import qualified Data.Text as T -import Network.Wai (Response, pathInfo) +import Network.Wai + (Response, pathInfo) import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr 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 @@ -10,16 +10,25 @@ {-# LANGUAGE UndecidableInstances #-} module Servant.Server.Internal.RoutingApplication where -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.Trans (MonadIO (..), MonadTrans (..)) -import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), MonadTransControl (..), - defaultLiftBaseWith, defaultRestoreM) -import Control.Monad.Trans.Resource (MonadResource (..), ResourceT, runResourceT, transResourceT, withInternalState, runInternalState) -import Network.Wai (Application, Request, Response, ResponseReceived) -import Prelude () +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.Trans + (MonadIO (..), MonadTrans (..)) +import Control.Monad.Trans.Control + (ComposeSt, MonadBaseControl (..), MonadTransControl (..), + defaultLiftBaseWith, defaultRestoreM) +import Control.Monad.Trans.Resource + (MonadResource (..), ResourceT, runInternalState, + runResourceT, transResourceT, withInternalState) +import Network.Wai + (Application, Request, Response, ResponseReceived) +import Prelude () import Prelude.Compat import Servant.Server.Internal.Handler import Servant.Server.Internal.ServantErr diff --git a/src/Servant/Server/Internal/ServantErr.hs b/src/Servant/Server/Internal/ServantErr.hs --- a/src/Servant/Server/Internal/ServantErr.hs +++ b/src/Servant/Server/Internal/ServantErr.hs @@ -1,14 +1,17 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Servant.Server.Internal.ServantErr where -import Control.Exception (Exception) +import Control.Exception + (Exception) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as LBS -import Data.Typeable (Typeable) +import Data.Typeable + (Typeable) import qualified Network.HTTP.Types as HTTP -import Network.Wai (Response, responseLBS) +import Network.Wai + (Response, responseLBS) data ServantErr = ServantErr { errHTTPCode :: Int , errReasonPhrase :: String diff --git a/src/Servant/Server/StaticFiles.hs b/src/Servant/Server/StaticFiles.hs --- a/src/Servant/Server/StaticFiles.hs +++ b/src/Servant/Server/StaticFiles.hs @@ -24,10 +24,6 @@ (ServerT, Tagged (..)) import System.FilePath (addTrailingPathSeparator) -#if !MIN_VERSION_wai_app_static(3,1,0) -import Filesystem.Path.CurrentOS - (decodeString) -#endif import WaiAppStatic.Storage.Filesystem (ETagLookup) @@ -84,9 +80,4 @@ {-# DEPRECATED serveDirectory "Use serveDirectoryFileServer instead" #-} fixPath :: FilePath -> FilePath -fixPath = -#if MIN_VERSION_wai_app_static(3,1,0) - addTrailingPathSeparator -#else - decodeString . addTrailingPathSeparator -#endif +fixPath = addTrailingPathSeparator diff --git a/src/Servant/Utils/StaticFiles.hs b/src/Servant/Utils/StaticFiles.hs --- a/src/Servant/Utils/StaticFiles.hs +++ b/src/Servant/Utils/StaticFiles.hs @@ -1,5 +1,5 @@ module Servant.Utils.StaticFiles - {-# DEPRECATED "Use Servant.ServerStaticFiles." #-} + {-# DEPRECATED "Use Servant.Server.StaticFiles." #-} ( module Servant.Server.StaticFiles ) where diff --git a/test/Servant/ArbitraryMonadServerSpec.hs b/test/Servant/ArbitraryMonadServerSpec.hs --- a/test/Servant/ArbitraryMonadServerSpec.hs +++ b/test/Servant/ArbitraryMonadServerSpec.hs @@ -9,9 +9,10 @@ import Servant.API import Servant.Server -import Test.Hspec (Spec, describe, it) -import Test.Hspec.Wai (get, matchStatus, post, - shouldRespondWith, with) +import Test.Hspec + (Spec, describe, it) +import Test.Hspec.Wai + (get, matchStatus, post, shouldRespondWith, with) spec :: Spec spec = describe "Arbitrary monad server" $ do diff --git a/test/Servant/HoistSpec.hs b/test/Servant/HoistSpec.hs --- a/test/Servant/HoistSpec.hs +++ b/test/Servant/HoistSpec.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} module Servant.HoistSpec where -import Test.Hspec (Spec) +import Test.Hspec + (Spec) -import Servant +import Servant ------------------------------------------------------------------------------- -- https://github.com/haskell-servant/servant/issues/734 diff --git a/test/Servant/Server/ErrorSpec.hs b/test/Servant/Server/ErrorSpec.hs --- a/test/Servant/Server/ErrorSpec.hs +++ b/test/Servant/Server/ErrorSpec.hs @@ -6,16 +6,20 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.Server.ErrorSpec (spec) where -import Control.Monad (when) -import Data.Aeson (encode) +import Control.Monad + (when) +import Data.Aeson + (encode) import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy.Char8 as BCL -import Data.Monoid ((<>)) +import Data.Monoid + ((<>)) import Data.Proxy -import Network.HTTP.Types (hAccept, hAuthorization, - hContentType, methodGet, - methodPost, methodPut) -import Safe (readMay) +import Network.HTTP.Types + (hAccept, hAuthorization, hContentType, methodGet, methodPost, + methodPut) +import Safe + (readMay) import Test.Hspec import Test.Hspec.Wai diff --git a/test/Servant/Server/Internal/ContextSpec.hs b/test/Servant/Server/Internal/ContextSpec.hs --- a/test/Servant/Server/Internal/ContextSpec.hs +++ b/test/Servant/Server/Internal/ContextSpec.hs @@ -2,9 +2,12 @@ {-# OPTIONS_GHC -fdefer-type-errors -Wwarn #-} module Servant.Server.Internal.ContextSpec (spec) where -import Data.Proxy (Proxy (..)) -import Test.Hspec (Spec, describe, it, shouldBe, context) -import Test.ShouldNotTypecheck (shouldNotTypecheck) +import Data.Proxy + (Proxy (..)) +import Test.Hspec + (Spec, context, describe, it, shouldBe) +import Test.ShouldNotTypecheck + (shouldNotTypecheck) import Servant.API import Servant.Server.Internal.Context diff --git a/test/Servant/Server/Internal/RoutingApplicationSpec.hs b/test/Servant/Server/Internal/RoutingApplicationSpec.hs --- a/test/Servant/Server/Internal/RoutingApplicationSpec.hs +++ b/test/Servant/Server/Internal/RoutingApplicationSpec.hs @@ -1,31 +1,37 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Servant.Server.Internal.RoutingApplicationSpec (spec) where -import Prelude () -import Prelude.Compat +import Prelude () +import Prelude.Compat -import Control.Exception hiding (Handler) -import Control.Monad.Trans.Resource (register) -import Control.Monad.IO.Class -import Data.IORef -import Data.Proxy -import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) -import Servant -import Servant.Server.Internal.RoutingApplication -import Network.Wai (defaultRequest) -import Test.Hspec -import Test.Hspec.Wai (request, shouldRespondWith, with) +import Control.Exception hiding + (Handler) +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource + (register) +import Data.IORef +import Data.Proxy +import GHC.TypeLits + (KnownSymbol, Symbol, symbolVal) +import Network.Wai + (defaultRequest) +import Servant +import Servant.Server.Internal.RoutingApplication +import Test.Hspec +import Test.Hspec.Wai + (request, shouldRespondWith, with) -import qualified Data.Text as T +import qualified Data.Text as T -import System.IO.Unsafe (unsafePerformIO) +import System.IO.Unsafe + (unsafePerformIO) data TestResource x = TestResourceNone diff --git a/test/Servant/Server/RouterSpec.hs b/test/Servant/Server/RouterSpec.hs --- a/test/Servant/Server/RouterSpec.hs +++ b/test/Servant/Server/RouterSpec.hs @@ -1,20 +1,27 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeOperators #-} module Servant.Server.RouterSpec (spec) where -import Control.Monad (unless) -import Data.Proxy (Proxy(..)) -import Data.Text (unpack) -import Network.HTTP.Types (Status (..)) -import Network.Wai (responseBuilder) -import Network.Wai.Internal (Response (ResponseBuilder)) -import Test.Hspec -import Test.Hspec.Wai (get, shouldRespondWith, with) +import Control.Monad + (unless) +import Data.Proxy + (Proxy (..)) +import Data.Text + (unpack) +import Network.HTTP.Types + (Status (..)) +import Network.Wai + (responseBuilder) +import Network.Wai.Internal + (Response (ResponseBuilder)) import Servant.API import Servant.Server import Servant.Server.Internal +import Test.Hspec +import Test.Hspec.Wai + (get, shouldRespondWith, with) spec :: Spec spec = describe "Servant.Server.Internal.Router" $ do diff --git a/test/Servant/Server/StreamingSpec.hs b/test/Servant/Server/StreamingSpec.hs --- a/test/Servant/Server/StreamingSpec.hs +++ b/test/Servant/Server/StreamingSpec.hs @@ -1,18 +1,19 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} -- | This module tests whether streaming works from client to server -- with a server implemented with servant-server. module Servant.Server.StreamingSpec where import Control.Concurrent -import Control.Exception hiding (Handler) +import Control.Exception hiding + (Handler) import Control.Monad.IO.Class -import qualified Data.ByteString as Strict -import qualified Data.ByteString.Lazy as Lazy +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Lazy as Lazy import Network.HTTP.Types import Network.Wai import Network.Wai.Internal diff --git a/test/Servant/Server/UsingContextSpec.hs b/test/Servant/Server/UsingContextSpec.hs --- a/test/Servant/Server/UsingContextSpec.hs +++ b/test/Servant/Server/UsingContextSpec.hs @@ -1,12 +1,13 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeOperators #-} module Servant.Server.UsingContextSpec where import Network.Wai -import Test.Hspec (Spec, describe, it) +import Test.Hspec + (Spec, describe, it) import Test.Hspec.Wai import Servant diff --git a/test/Servant/Server/UsingContextSpec/TestCombinators.hs b/test/Servant/Server/UsingContextSpec/TestCombinators.hs --- a/test/Servant/Server/UsingContextSpec/TestCombinators.hs +++ b/test/Servant/Server/UsingContextSpec/TestCombinators.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- | These are custom combinators for Servant.Server.UsingContextSpec. -- diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} @@ -9,32 +8,30 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} -#if __GLASGOW_HASKELL__ >= 800 {-# OPTIONS_GHC -freduction-depth=100 #-} -#else -{-# OPTIONS_GHC -fcontext-stack=100 #-} -#endif module Servant.ServerSpec where +import Prelude () +import Prelude.Compat + import Control.Monad (forM_, unless, when) import Control.Monad.Error.Class (MonadError (..)) import Data.Aeson (FromJSON, ToJSON, decode', encode) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as Base64 import Data.Char (toUpper) -import Data.Monoid import Data.Proxy (Proxy (Proxy)) import Data.String (fromString) import Data.String.Conversions (cs) -import qualified Data.Text as T +import qualified Data.Text as T import GHC.Generics (Generic) import Network.HTTP.Types @@ -53,18 +50,19 @@ EmptyAPI, Get, Header, Headers, HttpVersion, IsSecure (..), JSON, NoContent (..), NoFraming, OctetStream, Patch, PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, - RemoteHost, ReqBody, StdMethod (..), Stream, - StreamGenerator (..), Verb, addHeader) -import Servant.API.Internal.Test.ComprehensiveAPI + RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Verb, + addHeader) import Servant.Server (Context ((:.), EmptyContext), Handler, Server, Tagged (..), emptyServer, err401, err403, err404, serve, serveWithContext) +import Servant.Test.ComprehensiveAPI +import qualified Servant.Types.SourceT as S import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain) import Test.Hspec.Wai (get, liftIO, matchHeaders, matchStatus, shouldRespondWith, with, (<:>)) -import qualified Test.Hspec.Wai as THW +import qualified Test.Hspec.Wai as THW import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler) @@ -111,7 +109,7 @@ :<|> "accept" :> ( Verb method status '[JSON] Person :<|> Verb method status '[PlainText] String ) - :<|> "stream" :> Stream method status NoFraming OctetStream (StreamGenerator BS.ByteString) + :<|> "stream" :> Stream method status NoFraming OctetStream (SourceIO BS.ByteString) verbSpec :: Spec verbSpec = describe "Servant.API.Verb" $ do @@ -121,7 +119,7 @@ :<|> return (addHeader 5 alice) :<|> return (addHeader 10 NoContent) :<|> (return alice :<|> return "B") - :<|> return (StreamGenerator $ \f _ -> f "bytestring") + :<|> return (S.source ["bytestring"]) get200 = Proxy :: Proxy (VerbApi 'GET 200) post210 = Proxy :: Proxy (VerbApi 'POST 210) diff --git a/test/doctests.hs b/test/doctests.hs --- a/test/doctests.hs +++ b/test/doctests.hs @@ -13,9 +13,11 @@ ----------------------------------------------------------------------------- module Main where -import Build_doctests (flags, pkgs, module_sources) -import Data.Foldable (traverse_) -import Test.DocTest +import Build_doctests + (flags, module_sources, pkgs) +import Data.Foldable + (traverse_) +import Test.DocTest main :: IO () main = do