diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +0.7.1 +------ + +* Remove module `Servant.Server.Internal.Enter` (https://github.com/haskell-servant/servant/pull/478) +* Support GHC 8.0 + 0.7 --- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,5 +6,4 @@ ## Getting started -We've written a [tutorial](http://haskell-servant.github.io/tutorial/) guide that introduces the core types and features of servant. After this article, you should be able to write your first servant webservices, learning the rest from the haddocks' examples. - +We've written a [tutorial](http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html) guide that introduces the core types and features of servant. After this article, you should be able to write your first servant webservices, learning the rest from the haddocks' examples. diff --git a/servant-server.cabal b/servant-server.cabal --- a/servant-server.cabal +++ b/servant-server.cabal @@ -1,17 +1,17 @@ name: servant-server -version: 0.7 +version: 0.7.1 synopsis: A family of combinators for defining webservices APIs and serving them description: A family of combinators for defining webservices APIs and serving them . - You can learn about the basics in the . + You can learn about the basics in the . . is a runnable example, with comments, that defines a dummy API and implements a webserver that serves this API, using this package. . -homepage: http://haskell-servant.github.io/ +homepage: http://haskell-servant.readthedocs.org/ Bug-reports: http://github.com/haskell-servant/servant/issues license: BSD3 license-file: LICENSE @@ -40,7 +40,6 @@ Servant.Server.Internal Servant.Server.Internal.BasicAuth Servant.Server.Internal.Context - Servant.Server.Internal.Enter Servant.Server.Internal.Router Servant.Server.Internal.RoutingApplication Servant.Server.Internal.ServantErr @@ -57,7 +56,6 @@ , http-types >= 0.8 && < 0.10 , network-uri >= 2.6 && < 2.7 , mtl >= 2 && < 3 - , mmorph >= 1 , network >= 2.6 && < 2.7 , safe >= 0.3 && < 0.4 , servant == 0.7.* @@ -76,6 +74,8 @@ hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + if impl(ghc >= 8.0) + ghc-options: -Wno-redundant-constraints include-dirs: include executable greet @@ -94,18 +94,18 @@ test-suite spec type: exitcode-stdio-1.0 - ghc-options: - -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures + ghc-options: -Wall default-language: Haskell2010 hs-source-dirs: test main-is: Spec.hs other-modules: Servant.Server.ErrorSpec Servant.Server.Internal.ContextSpec - Servant.Server.Internal.EnterSpec - Servant.ServerSpec + Servant.Server.RouterSpec + Servant.Server.StreamingSpec Servant.Server.UsingContextSpec Servant.Server.UsingContextSpec.TestCombinators + Servant.ServerSpec Servant.Utils.StaticFilesSpec build-depends: base == 4.* @@ -126,7 +126,7 @@ , servant , servant-server , string-conversions - , should-not-typecheck == 2.* + , should-not-typecheck == 2.1.* , temporary , text , transformers @@ -147,5 +147,5 @@ main-is: test/Doctests.hs buildable: True default-language: Haskell2010 - ghc-options: -threaded + ghc-options: -Wall -threaded 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 @@ -101,7 +101,7 @@ import Data.Text (Text) import Network.Wai (Application) import Servant.Server.Internal -import Servant.Server.Internal.Enter +import Servant.Utils.Enter -- * Implementing Servers 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 @@ -18,7 +18,7 @@ -- | 'Context's are used to pass values to combinators. (They are __not__ meant -- to be used to pass parameters to your handlers, i.e. they should not replace -- any custom 'Control.Monad.Trans.Reader.ReaderT'-monad-stack that you're using --- with 'Servant.Server.Internal.Enter.enter'.) If you don't use combinators that +-- with 'Servant.Utils.Enter'.) If you don't use combinators that -- require any context entries, you can just use 'Servant.Server.serve' as always. -- -- If you are using combinators that require a non-empty 'Context' you have to @@ -59,7 +59,7 @@ -- -- >>> getContextEntry (True :. False :. EmptyContext) :: String -- ... --- No instance for (HasContextEntry '[] [Char]) +-- ...No instance for (HasContextEntry '[] [Char]) -- ... class HasContextEntry (context :: [*]) (val :: *) where getContextEntry :: Context context -> val diff --git a/src/Servant/Server/Internal/Enter.hs b/src/Servant/Server/Internal/Enter.hs deleted file mode 100644 --- a/src/Servant/Server/Internal/Enter.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module Servant.Server.Internal.Enter where - -import qualified Control.Category as C -#if MIN_VERSION_mtl(2,2,1) -import Control.Monad.Except -#endif -import Control.Monad.Identity -import Control.Monad.Morph -import Control.Monad.Reader -import qualified Control.Monad.State.Lazy as LState -import qualified Control.Monad.State.Strict as SState -import qualified Control.Monad.Writer.Lazy as LWriter -import qualified Control.Monad.Writer.Strict as SWriter -import Data.Typeable -import Prelude () -import Prelude.Compat - -import Servant.API - -class Enter typ arg ret | typ arg -> ret, typ ret -> arg where - enter :: arg -> typ -> ret - --- ** Servant combinators -instance ( Enter typ1 arg1 ret1, Enter typ2 arg2 ret2 - , arg1 ~ arg2 - ) => Enter (typ1 :<|> typ2) arg1 (ret1 :<|> ret2) where - enter e (a :<|> b) = enter e a :<|> enter e b - -instance (Enter b arg ret) => Enter (a -> b) arg (a -> ret) where - enter arg f a = enter arg (f a) - --- ** Useful instances - --- | A natural transformation from @m@ to @n@. Used to `enter` particular --- datatypes. -newtype m :~> n = Nat { unNat :: forall a. m a -> n a} deriving Typeable - -instance C.Category (:~>) where - id = Nat id - Nat f . Nat g = Nat (f . g) - -instance Enter (m a) (m :~> n) (n a) where - enter (Nat f) = f - --- | Like `lift`. -liftNat :: (Control.Monad.Morph.MonadTrans t, Monad m) => m :~> t m -liftNat = Nat Control.Monad.Morph.lift - -runReaderTNat :: r -> (ReaderT r m :~> m) -runReaderTNat a = Nat (`runReaderT` a) - -evalStateTLNat :: Monad m => s -> (LState.StateT s m :~> m) -evalStateTLNat a = Nat (`LState.evalStateT` a) - -evalStateTSNat :: Monad m => s -> (SState.StateT s m :~> m) -evalStateTSNat a = Nat (`SState.evalStateT` a) - --- | Log the contents of `SWriter.WriterT` with the function provided as the --- first argument, and return the value of the @WriterT@ computation -logWriterTSNat :: MonadIO m => (w -> IO ()) -> (SWriter.WriterT w m :~> m) -logWriterTSNat logger = Nat $ \x -> do - (a, w) <- SWriter.runWriterT x - liftIO $ logger w - return a - --- | Like `logWriterTSNat`, but for strict @WriterT@. -logWriterTLNat :: MonadIO m => (w -> IO ()) -> (LWriter.WriterT w m :~> m) -logWriterTLNat logger = Nat $ \x -> do - (a, w) <- LWriter.runWriterT x - liftIO $ logger w - return a - --- | Like @mmorph@'s `hoist`. -hoistNat :: (MFunctor t, Monad m) => (m :~> n) -> (t m :~> t n) -hoistNat (Nat n) = Nat $ hoist n - --- | Like @mmorph@'s `embed`. -embedNat :: (MMonad t, Monad n) => (m :~> t n) -> (t m :~> t n) -embedNat (Nat n) = Nat $ embed n - --- | Like @mmorph@'s `squash`. -squashNat :: (Monad m, MMonad t) => t (t m) :~> t m -squashNat = Nat squash - --- | Like @mmorph@'s `generalize`. -generalizeNat :: Applicative m => Identity :~> m -generalizeNat = Nat (pure . runIdentity) 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 @@ -1,9 +1,9 @@ {-# LANGUAGE DataKinds #-} -{-# OPTIONS_GHC -fdefer-type-errors #-} +{-# OPTIONS_GHC -fdefer-type-errors -Wwarn #-} module Servant.Server.Internal.ContextSpec (spec) where import Data.Proxy (Proxy (..)) -import Test.Hspec (Spec, describe, it, shouldBe, pending, context) +import Test.Hspec (Spec, describe, it, shouldBe, context) import Test.ShouldNotTypecheck (shouldNotTypecheck) import Servant.API @@ -26,16 +26,17 @@ shouldNotTypecheck x context "Show instance" $ do - let cxt = 'a' :. True :. EmptyContext it "has a Show instance" $ do + let cxt = 'a' :. True :. EmptyContext show cxt `shouldBe` "'a' :. True :. EmptyContext" context "bracketing" $ do it "works" $ do + let cxt = 'a' :. True :. EmptyContext show (Just cxt) `shouldBe` "Just ('a' :. True :. EmptyContext)" it "works with operators" $ do - let cxt = (1 :. 'a' :. EmptyContext) :<|> ('b' :. True :. EmptyContext) + let cxt = ((1 :: Integer) :. 'a' :. EmptyContext) :<|> ('b' :. True :. EmptyContext) show cxt `shouldBe` "(1 :. 'a' :. EmptyContext) :<|> ('b' :. True :. EmptyContext)" describe "descendIntoNamedContext" $ do diff --git a/test/Servant/Server/Internal/EnterSpec.hs b/test/Servant/Server/Internal/EnterSpec.hs deleted file mode 100644 --- a/test/Servant/Server/Internal/EnterSpec.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -module Servant.Server.Internal.EnterSpec where - -import qualified Control.Category as C -import Control.Monad.Reader -import Control.Monad.Trans.Except -import Data.Proxy -import Servant.API -import Servant.Server - -import Test.Hspec (Spec, describe, it) -import Test.Hspec.Wai (get, matchStatus, post, - shouldRespondWith, with) - -spec :: Spec -spec = describe "module Servant.Server.Enter" $ do - enterSpec - -type ReaderAPI = "int" :> Get '[JSON] Int - :<|> "string" :> Post '[JSON] String - -type IdentityAPI = "bool" :> Get '[JSON] Bool - -type CombinedAPI = ReaderAPI :<|> IdentityAPI - -readerAPI :: Proxy ReaderAPI -readerAPI = Proxy - -combinedAPI :: Proxy CombinedAPI -combinedAPI = Proxy - -readerServer' :: ServerT ReaderAPI (Reader String) -readerServer' = return 1797 :<|> ask - -fReader :: Reader String :~> Handler -fReader = generalizeNat C.. (runReaderTNat "hi") - -readerServer :: Server ReaderAPI -readerServer = enter fReader readerServer' - -combinedReaderServer' :: ServerT CombinedAPI (Reader String) -combinedReaderServer' = readerServer' :<|> enter generalizeNat (return True) - -combinedReaderServer :: Server CombinedAPI -combinedReaderServer = enter fReader combinedReaderServer' - -enterSpec :: Spec -enterSpec = describe "Enter" $ do - with (return (serve readerAPI readerServer)) $ do - - it "allows running arbitrary monads" $ do - get "int" `shouldRespondWith` "1797" - post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 200 } - - with (return (serve combinedAPI combinedReaderServer)) $ do - it "allows combnation of enters" $ do - get "bool" `shouldRespondWith` "true" diff --git a/test/Servant/Server/RouterSpec.hs b/test/Servant/Server/RouterSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/Server/RouterSpec.hs @@ -0,0 +1,294 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# 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 (Application, responseBuilder) +import Network.Wai.Internal (Response (ResponseBuilder)) +import Test.Hspec +import Test.Hspec.Wai (get, shouldRespondWith, with) +import Servant.API +import Servant.Server +import Servant.Server.Internal + +spec :: Spec +spec = describe "Servant.Server.Internal.Router" $ do + routerSpec + distributivitySpec + +routerSpec :: Spec +routerSpec = do + let app' :: Application + app' = toApplication $ runRouter router' + + router', router :: Router () + router' = tweakResponse (fmap twk) router + router = leafRouter $ \_ _ cont -> cont (Route $ responseBuilder (Status 201 "") [] "") + + twk :: Response -> Response + twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b + twk b = b + + describe "tweakResponse" . with (return app') $ do + it "calls f on route result" $ do + get "" `shouldRespondWith` 202 + +distributivitySpec :: Spec +distributivitySpec = + describe "choice" $ do + it "distributes endpoints through static paths" $ do + endpoint `shouldHaveSameStructureAs` endpointRef + it "distributes nested routes through static paths" $ do + static `shouldHaveSameStructureAs` staticRef + it "distributes nested routes through dynamic paths" $ do + dynamic `shouldHaveSameStructureAs` dynamicRef + it "properly reorders permuted static paths" $ do + permute `shouldHaveSameStructureAs` permuteRef + it "properly reorders permuted static paths in the presence of Raw in end" $ do + permuteRawEnd `shouldHaveSameStructureAs` permuteRawEndRef + it "properly reorders permuted static paths in the presence of Raw in beginning" $ do + permuteRawBegin `shouldHaveSameStructureAs` permuteRawBeginRef + it "properly reorders permuted static paths in the presence of Raw in middle" $ do + permuteRawMiddle `shouldHaveSameStructureAs` permuteRawMiddleRef + it "properly reorders permuted static paths in the presence of a root endpoint in end" $ do + permuteEndEnd `shouldHaveSameStructureAs` permuteEndRef + it "properly reorders permuted static paths in the presence of a root endpoint in beginning" $ do + permuteEndBegin `shouldHaveSameStructureAs` permuteEndRef + it "properly reorders permuted static paths in the presence of a root endpoint in middle" $ do + permuteEndMiddle `shouldHaveSameStructureAs` permuteEndRef + it "properly handles mixing static paths at different levels" $ do + level `shouldHaveSameStructureAs` levelRef + +shouldHaveSameStructureAs :: + (HasServer api1 '[], HasServer api2 '[]) => Proxy api1 -> Proxy api2 -> Expectation +shouldHaveSameStructureAs p1 p2 = + unless (sameStructure (makeTrivialRouter p1) (makeTrivialRouter p2)) $ + expectationFailure ("expected:\n" ++ unpack (layout p2) ++ "\nbut got:\n" ++ unpack (layout p1)) + +makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router () +makeTrivialRouter p = + route p EmptyContext (emptyDelayed (FailFatal err501)) + +type End = Get '[JSON] () + +-- The latter version looks more efficient, +-- but the former should be compiled to the +-- same layout: + +type Endpoint = "a" :> End :<|> "a" :> End +type EndpointRef = "a" :> (End :<|> End) + +endpoint :: Proxy Endpoint +endpoint = Proxy + +endpointRef :: Proxy EndpointRef +endpointRef = Proxy + +-- Again, the latter version looks more efficient, +-- but the former should be compiled to the same +-- layout: + +type Static = "a" :> "b" :> End :<|> "a" :> "c" :> End +type StaticRef = "a" :> ("b" :> End :<|> "c" :> End) + +static :: Proxy Static +static = Proxy + +staticRef :: Proxy StaticRef +staticRef = Proxy + +-- Even for dynamic path components, we expect the +-- router to simplify the layout, because captures +-- are delayed and only actually performed once +-- reaching an endpoint. So the former version and +-- the latter should be compiled to the same router +-- structure: + +type Dynamic = + "a" :> Capture "foo" Int :> "b" :> End + :<|> "a" :> Capture "bar" Bool :> "c" :> End + :<|> "a" :> Capture "baz" Char :> "d" :> End + +type DynamicRef = + "a" :> Capture "anything" () :> + ("b" :> End :<|> "c" :> End :<|> "d" :> End) + +dynamic :: Proxy Dynamic +dynamic = Proxy + +dynamicRef :: Proxy DynamicRef +dynamicRef = Proxy + +-- A more complicated example of static route reordering. +-- All the permuted paths should be correctly grouped, +-- so both 'Permute' and 'PermuteRef' should compile to +-- the same layout: + +type Permute = + "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + +type PermuteRef = + "a" :> ( "b" :> "c" :> End + :<|> "c" :> "b" :> End + ) + :<|> "b" :> ( "a" :> "c" :> End + :<|> "c" :> "a" :> End + ) + :<|> "c" :> ( "a" :> "b" :> End + :<|> "b" :> "a" :> End + ) + +permute :: Proxy Permute +permute = Proxy + +permuteRef :: Proxy PermuteRef +permuteRef = Proxy + +-- Adding a 'Raw' in one of the ends should have minimal +-- effect on the grouping. + +type PermuteRawEnd = + "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + :<|> Raw + +type PermuteRawEndRef = PermuteRef :<|> Raw + +type PermuteRawBegin = + Raw + :<|> "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + +type PermuteRawBeginRef = Raw :<|> PermuteRef + +permuteRawBegin :: Proxy PermuteRawBegin +permuteRawBegin = Proxy + +permuteRawBeginRef :: Proxy PermuteRawBeginRef +permuteRawBeginRef = Proxy + +permuteRawEnd :: Proxy PermuteRawEnd +permuteRawEnd = Proxy + +permuteRawEndRef :: Proxy PermuteRawEndRef +permuteRawEndRef = Proxy + +-- Adding a 'Raw' in the middle will disrupt grouping, +-- because we commute things past a 'Raw'. But the two +-- halves should still be grouped. + +type PermuteRawMiddle = + "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> Raw + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + +type PermuteRawMiddleRef = + "a" :> ( "b" :> "c" :> End + :<|> "c" :> "b" :> End + ) + :<|> "b" :> "a" :> "c" :> End + :<|> Raw + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> ( "a" :> "b" :> End + :<|> "b" :> "a" :> End + ) + +permuteRawMiddle :: Proxy PermuteRawMiddle +permuteRawMiddle = Proxy + +permuteRawMiddleRef :: Proxy PermuteRawMiddleRef +permuteRawMiddleRef = Proxy + +-- Adding an endpoint at the top-level in various places +-- is also somewhat critical for grouping, but it should +-- not disrupt grouping at all, even if it is placed in +-- the middle. + +type PermuteEndEnd = + "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + :<|> End + +type PermuteEndBegin = + End + :<|> "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + +type PermuteEndMiddle = + "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> End + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + +type PermuteEndRef = PermuteRef :<|> End + +permuteEndEnd :: Proxy PermuteEndEnd +permuteEndEnd = Proxy + +permuteEndBegin :: Proxy PermuteEndBegin +permuteEndBegin = Proxy + +permuteEndMiddle :: Proxy PermuteEndMiddle +permuteEndMiddle = Proxy + +permuteEndRef :: Proxy PermuteEndRef +permuteEndRef = Proxy + +-- An API with routes on different nesting levels that +-- is composed out of different fragments should still +-- be reordered correctly. + +type LevelFragment1 = + "a" :> "b" :> End + :<|> "a" :> End + +type LevelFragment2 = + "b" :> End + :<|> "a" :> "c" :> End + :<|> End + +type Level = LevelFragment1 :<|> LevelFragment2 + +type LevelRef = + "a" :> ("b" :> End :<|> "c" :> End :<|> End) + :<|> "b" :> End + :<|> End + +level :: Proxy Level +level = Proxy + +levelRef :: Proxy LevelRef +levelRef = Proxy diff --git a/test/Servant/Server/StreamingSpec.hs b/test/Servant/Server/StreamingSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/Server/StreamingSpec.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# 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.Monad.IO.Class +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Lazy as Lazy +import Network.HTTP.Types +import Network.Wai +import Network.Wai.Internal +import Prelude () +import Prelude.Compat +import Servant +import qualified System.Timeout +import Test.Hspec + +type TestAPI = + ReqBody '[OctetStream] Lazy.ByteString :> Get '[JSON] NoContent + +testAPI :: Proxy TestAPI +testAPI = Proxy + +spec :: Spec +spec = do + -- The idea of this test is this: + -- + -- - The mock client will + -- - send some data in the request body, but not all, + -- - wait for the server to acknowledge (outside of http, through an MVar) + -- that the server received some data, + -- - send the rest of the request body. + -- - The mock server will + -- - receive some data, + -- - notify the client that it received some data, + -- - receive the rest of the data, + -- - respond with an empty result. + it "client to server can stream lazy ByteStrings" $ timeout $ do + serverReceivedFirstChunk <- newWaiter + + -- - streams some test data + -- - waits for serverReceivedFirstChunk + -- - streams some more test data + streamTestData <- do + mvar :: MVar [IO Strict.ByteString] <- newMVar $ + map return (replicate 1000 "foo") ++ + (waitFor serverReceivedFirstChunk >> return "foo") : + map return (replicate 1000 "foo") + return $ modifyMVar mvar $ \ actions -> case actions of + (a : r) -> (r, ) <$> a + [] -> return ([], "") + + let request = defaultRequest { + requestBody = streamTestData, + requestBodyLength = ChunkedBody + } + + -- - receives the first chunk + -- - notifies serverReceivedFirstChunk + -- - receives the rest of the request + let handler :: Lazy.ByteString -> Handler NoContent + handler input = liftIO $ do + let prefix = Lazy.take 3 input + prefix `shouldBe` "foo" + notify serverReceivedFirstChunk () + input `shouldBe` mconcat (replicate 2001 "foo") + return NoContent + + app = serve testAPI handler + response <- executeRequest app request + statusCode (responseStatus response) `shouldBe` 200 + +executeRequest :: Application -> Request -> IO Response +executeRequest app request = do + responseMVar <- newEmptyMVar + let respond response = do + putMVar responseMVar response + return ResponseReceived + ResponseReceived <- app request respond + takeMVar responseMVar + +timeout :: IO a -> IO a +timeout action = do + result <- System.Timeout.timeout 1000000 action + maybe (throwIO $ ErrorCall "timeout") return result + +-- * waiter + +data Waiter a + = Waiter { + notify :: a -> IO (), + waitFor :: IO a + } + +newWaiter :: IO (Waiter a) +newWaiter = do + mvar <- newEmptyMVar + return $ Waiter { + notify = putMVar mvar, + waitFor = readMVar mvar + } 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 @@ -5,7 +5,6 @@ module Servant.Server.UsingContextSpec where -import Control.Monad.Trans.Except import Network.Wai import Test.Hspec (Spec, describe, it) import Test.Hspec.Wai 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 @@ -30,12 +30,12 @@ String -> ServerT subApi m route Proxy context delayed = - route subProxy context (fmap (inject context) delayed) + route subProxy context (fmap inject delayed) where subProxy :: Proxy subApi subProxy = Proxy - inject context f = f (getContextEntry context) + inject f = f (getContextEntry context) data InjectIntoContext