Add servant-io-streams

.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 }}

.gitignore

@@ -32,6 +32,7 @@ doc/tutorial/static/api.js
 doc/tutorial/static/jq.js
 shell.nix
 .hspec-failures
+cabal.project.local
 
 # nix
 result*

cabal.project

@@ -20,6 +20,7 @@ packages:
   servant-machines/
   servant-conduit/
   servant-pipes/
+  servant-io-streams/
 
 -- servant GHCJS
 -- packages:

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`.
+}

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;
   }
 

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). 
 

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.

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)

servant-io-streams/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

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"

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:          [email protected]
+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

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

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

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