diff --git a/.github/workflows/master.yml b/.github/workflows/master.yml index 3cdefa5e0..05ff10476 100644 --- a/.github/workflows/master.yml +++ b/.github/workflows/master.yml @@ -74,6 +74,7 @@ jobs: (cd servant-machines && eval $DOCTEST) (cd servant-conduit && eval $DOCTEST) (cd servant-pipes && eval $DOCTEST) + (cd servant-io-streams && eval $DOCTEST) # stack: # name: stack / ghc ${{ matrix.ghc }} diff --git a/.gitignore b/.gitignore index 3b2084ae6..3bb6ea505 100644 --- a/.gitignore +++ b/.gitignore @@ -32,6 +32,7 @@ doc/tutorial/static/api.js doc/tutorial/static/jq.js shell.nix .hspec-failures +cabal.project.local # nix result* diff --git a/cabal.project b/cabal.project index cc7efb2cf..dbba15b99 100644 --- a/cabal.project +++ b/cabal.project @@ -20,6 +20,7 @@ packages: servant-machines/ servant-conduit/ servant-pipes/ + servant-io-streams/ -- servant GHCJS -- packages: diff --git a/changelog.d/1660 b/changelog.d/1660 new file mode 100644 index 000000000..9834a3223 --- /dev/null +++ b/changelog.d/1660 @@ -0,0 +1,6 @@ +synopsis: Add servant-io-streams package +prs: #1660 + +description: { +Instances of `ToSourceIO` and `FromSourceIO` for `InputStream` from `io-streams`. +} diff --git a/default.nix b/default.nix index e16129de9..fb97eb398 100644 --- a/default.nix +++ b/default.nix @@ -16,6 +16,7 @@ let servant-foreign = self.callCabal2nix "servant-foreign" ./servant-foreign {}; servant-conduit = self.callCabal2nix "servant-conduit" ./servant-conduit {}; servant-machines = self.callCabal2nix "servant-machines" ./servant-machines {}; + servant-io-streams = self.callCabal2nix "servant-io-streams" ./servant-io-streams {}; servant-client-core = self.callCabal2nix "servant-client-core" ./servant-client-core {}; servant-http-streams = self.callCabal2nix "servant-http-streams" ./servant-http-streams {}; }; @@ -33,6 +34,7 @@ in servant-http-streams servant-machines servant-pipes + servant-io-streams servant-server; } diff --git a/doc/cookbook/basic-streaming/Streaming.lhs b/doc/cookbook/basic-streaming/Streaming.lhs index e027d8b87..01fbc2fac 100644 --- a/doc/cookbook/basic-streaming/Streaming.lhs +++ b/doc/cookbook/basic-streaming/Streaming.lhs @@ -10,8 +10,9 @@ In other words, without streaming libraries. We have bindings for them though. - Similar example is bundled with each of our streaming library interop packages (see [servant-pipes](https://github.com/haskell-servant/servant/blob/master/servant-pipes/example/Main.hs), -[servant-conduit](https://github.com/haskell-servant/servant/blob/master/servant-conduit/example/Main.hs) and -[servant-machines](https://github.com/haskell-servant/servant/blob/master/servant-machines/example/Main.hs)) +[servant-conduit](https://github.com/haskell-servant/servant/blob/master/servant-conduit/example/Main.hs), +[servant-machines](https://github.com/haskell-servant/servant/blob/master/servant-machines/example/Main.hs) and +[servant-io-streams](https://github.com/haskell-servant/servant/blob/master/servant-io-streams/example/Main.hs)) - `SourceT` doesn't have *Prelude* with handy combinators, so we have to write things ourselves. (Note to self: `mapM` and `foldM` would be handy to have). diff --git a/servant-io-streams/LICENSE b/servant-io-streams/LICENSE new file mode 100644 index 000000000..449ba2281 --- /dev/null +++ b/servant-io-streams/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2023, Servant Contributors + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Servant Contributors nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/servant-io-streams/README.md b/servant-io-streams/README.md new file mode 100644 index 000000000..05a0f9c6c --- /dev/null +++ b/servant-io-streams/README.md @@ -0,0 +1,3 @@ +# servant-io-streams - Servant Stream support for io-streams + +![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) diff --git a/servant-io-streams/Setup.hs b/servant-io-streams/Setup.hs new file mode 100644 index 000000000..9a994af67 --- /dev/null +++ b/servant-io-streams/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-io-streams/example/Main.hs b/servant-io-streams/example/Main.hs new file mode 100644 index 000000000..e5bd92241 --- /dev/null +++ b/servant-io-streams/example/Main.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} +module Main (main) where + +import Prelude () +import Prelude.Compat + +import Control.Concurrent + (threadDelay) +import Control.Monad.IO.Class + (MonadIO (..)) +import qualified Data.ByteString as BS +import Data.Maybe + (fromMaybe) +import Network.HTTP.Client + (defaultManagerSettings, newManager) +import System.Environment + (getArgs, lookupEnv) +import System.IO + (IOMode (..), openFile, hClose) +import Text.Read + (readMaybe) + +import qualified System.IO.Streams as IOS +import System.IO.Streams.Combinators + (atEndOfInput) +import System.IO.Streams.Handle + (handleToInputStream) +import Servant +import Servant.Client.Streaming +import Servant.IO.Streams () + +import qualified Network.Wai.Handler.Warp as Warp + +type FastAPI = "get" :> Capture "num" Int :> StreamGet NewlineFraming JSON (IOS.InputStream Int) + +type API = FastAPI + :<|> "slow" :> Capture "num" Int :> StreamGet NewlineFraming JSON (IOS.InputStream Int) + :<|> "readme" :> StreamGet NoFraming OctetStream (IOS.InputStream BS.ByteString) + -- we can have streaming request body + :<|> "proxy" + :> StreamBody NoFraming OctetStream (IOS.InputStream BS.ByteString) + :> StreamPost NoFraming OctetStream (IOS.InputStream BS.ByteString) + +api :: Proxy API +api = Proxy + +server :: Server API +server = fast :<|> slow :<|> readme :<|> proxy + where + fast n = liftIO $ do + putStrLn ("/get/" ++ show n) + IOS.fromGenerator $ fastGenerator n + + slow n = liftIO $ do + putStrLn ("/slow/" ++ show n) + IOS.fromGenerator $ slowGenerator n + + readme = liftIO $ do + putStrLn "/readme" + h <- openFile "README.md" ReadMode + is <- handleToInputStream h + atEndOfInput (hClose h) is + + proxy c = liftIO $ do + putStrLn "/proxy" + return c + + fastGenerator n + | n < 0 = return () + | otherwise = IOS.yield n >> fastGenerator (n - 1) + + slowGenerator n + | n < 0 = return () + | otherwise = IOS.yield n >> liftIO (threadDelay 1000000) >> slowGenerator (n - 1) + +app :: Application +app = serve api server + +cli :: Client ClientM FastAPI +cli :<|> _ :<|> _ :<|> _ = client api + +main :: IO () +main = do + args <- getArgs + case args of + ("server":_) -> do + putStrLn "Starting servant-io-streams:example at http://localhost:8000" + port <- fromMaybe 8000 . (>>= readMaybe) <$> lookupEnv "PORT" + Warp.run port app + ("client":ns:_) -> do + n <- maybe (fail $ "not a number: " ++ ns) pure $ readMaybe ns + mgr <- newManager defaultManagerSettings + burl <- parseBaseUrl "http://localhost:8000/" + withClientM (cli n) (mkClientEnv mgr burl) $ \me -> case me of + Left err -> print err + Right s -> do + x <- IOS.fold (\c _ -> c + 1) (0 :: Int) s + print x + _ -> do + putStrLn "Try:" + putStrLn "cabal new-run servant-io-streams:example server" + putStrLn "cabal new-run servant-io-streams:example client 10" + putStrLn "time curl -H 'Accept: application/json' localhost:8000/slow/5" diff --git a/servant-io-streams/servant-io-streams.cabal b/servant-io-streams/servant-io-streams.cabal new file mode 100644 index 000000000..b4b93e99e --- /dev/null +++ b/servant-io-streams/servant-io-streams.cabal @@ -0,0 +1,57 @@ +cabal-version: 2.2 +name: servant-io-streams +version: 0.1 + +synopsis: Servant Stream support for io-streams +category: Servant, Web, io-streams +description: Servant Stream support for io-streams. + . + Provides 'ToSourceIO' and 'FromSourceIO' instances for 'InputStream'. + +homepage: http://docs.servant.dev/ +bug-reports: http://github.com/haskell-servant/servant/issues +license: BSD-3-Clause +license-file: LICENSE +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: 2023 Servant Contributors +build-type: Simple +tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 + +extra-source-files: + CHANGELOG.md + +source-repository head + type: git + location: http://github.com/haskell-servant/servant.git + +library + exposed-modules: Servant.IO.Streams + build-depends: + base >=4.9 && <5 + , io-streams ^>=1.5 + , servant >=0.15 && <0.20 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +test-suite example + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + example + ghc-options: -Wall -rtsopts -threaded + build-depends: + base + , base-compat + , bytestring + , http-media + , servant + , servant-io-streams + , io-streams ^>= 1.5 + , servant-server >=0.15 && <0.20 + , servant-client >=0.15 && <0.20 + , wai >=3.2.1.2 && <3.3 + , warp >=3.2.25 && <3.4 + , http-client + default-language: Haskell2010 diff --git a/servant-io-streams/src/Servant/IO/Streams.hs b/servant-io-streams/src/Servant/IO/Streams.hs new file mode 100644 index 000000000..e42f4f844 --- /dev/null +++ b/servant-io-streams/src/Servant/IO/Streams.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- | This module exports 'ToSourceIO' and 'FromSourceIO' for 'IOStreams.InputStream' +module Servant.IO.Streams where + +import Control.Monad.IO.Class (liftIO) +import qualified System.IO.Streams.Core as IOS +import Servant.API.Stream +import qualified Servant.Types.SourceT as S + +instance ToSourceIO a (IOS.InputStream a) where + toSourceIO src = S.SourceT ($ go) + where + go = S.Effect $ trans <$> IOS.read src + + trans Nothing = S.Stop + trans (Just c) = S.Yield c go + +instance FromSourceIO a (IOS.InputStream a) where + fromSourceIO src = S.unSourceT src $ IOS.fromGenerator . gen + where + gen S.Stop = pure () + gen (S.Error s) = liftIO $ fail s + gen (S.Skip s) = gen s + gen (S.Yield a s) = IOS.yield a >> gen s + gen (S.Effect ms) = liftIO ms >>= gen diff --git a/stack.yaml b/stack.yaml index 76402522e..3e0546184 100644 --- a/stack.yaml +++ b/stack.yaml @@ -12,6 +12,7 @@ packages: - servant-conduit - servant-machines/ - servant-pipes/ +- servant-io-streams/ - servant-swagger/ # allow-newer: true # ignores all bounds, that's a sledgehammer diff --git a/streaming-benchmark.sh b/streaming-benchmark.sh index e7c2e87ac..3d442f198 100644 --- a/streaming-benchmark.sh +++ b/streaming-benchmark.sh @@ -28,6 +28,10 @@ cleanup() { kill "$PIPES_PID" || true fi + if [ ! -z "$STREAMS_PID" ]; then + kill "$STREAMS_PID" || true + fi + if [ ! -z "$COOKBOOK_PID" ]; then kill "$COOKBOOK_PID" || true fi @@ -107,6 +111,27 @@ curl --silent --show-error "$PROXYURL" --request POST --data-binary @"$TESTFILE" kill -INT $COOKBOOK_PID unset COOKBOOK_PID +## io-streams + +bench "server streams" + +$(cabal-plan list-bin servant-io-streams:test:example) server +RTS -sbench-io-streams-server-rts.txt & +STREAMS_PID=$! +echo "Starting servant-io-streams server. PID=$STREAMS_PID" + +# Time to startup +sleep 1 + +# Run slow url to test & warm-up server +curl "$SLOWURL" + +curl --silent --show-error "$FASTURL" --output /dev/null --write-out "$CURLSTATS" > bench-streams-server.txt + +curl --silent --show-error "$PROXYURL" --request POST --data-binary @"$TESTFILE" --output "$TMPFILE" --write-out "$CURLSTATS" > bench-streams-server-proxy.txt + +kill -INT $STREAMS_PID +unset STREAMS_PID + ## Conduit bench "server conduit" @@ -155,6 +180,17 @@ $(cabal-plan list-bin servant-pipes:test:example) client 10 /usr/bin/time --verbose --output bench-pipes-client-time.txt \ "$(cabal-plan list-bin servant-pipes:test:example)" client "$SIZE" +RTS -sbench-pipes-client-rts.txt +## Streams + +bench "client streams" + +# Test run +$(cabal-plan list-bin servant-io-streams:test:example) client 10 + +# Real run +/usr/bin/time --verbose --output bench-io-streams-client-time.txt \ + "$(cabal-plan list-bin servant-io-streams:test:example)" client "$SIZE" +RTS -sbench-io-streams-client-rts.txt + ## Conduit bench "client conduit" @@ -230,6 +266,11 @@ report bench-pipes-server.txt report bench-pipes-server-proxy.txt report bench-pipes-server-rts.txt +header "###" io-streams +report bench-streams-server.txt +report bench-streams-server-proxy.txt +report bench-streams-server-rts.txt + header "###" conduit note "Conduit server is also used for client tests below" report bench-conduit-server.txt @@ -251,6 +292,10 @@ header "###" pipes report2 bench-pipes-client-time.txt report bench-pipes-client-rts.txt +header "###" io-streams +report2 bench-streams-client-time.txt +report bench-streams-client-rts.txt + header "###" conduit report2 bench-conduit-client-time.txt report bench-conduit-client-rts.txt @@ -262,6 +307,7 @@ report bench-cookbook-client-rts.txt # Cleanup filepaths sed -E -i 's/\/[^ ]*machines[^ ]*\/example/...machines:example/' bench.md sed -E -i 's/\/[^ ]*conduit[^ ]*\/example/...conduit:example/' bench.md +sed -E -i 's/\/[^ ]*io-streams[^ ]*\/example/...io-streams:example/' bench.md sed -E -i 's/\/[^ ]*pipes[^ ]*\/example/...pipes:example/' bench.md sed -E -i 's/\/[^ ]*\/cookbook-basic-streaming/...cookbook-basic-streaming/' bench.md