Skip to content

Commit ca482af

Browse files
shlevyshlevy
committed
Add servant-io-streams
1 parent 13cbac8 commit ca482af

File tree

13 files changed

+286
-2
lines changed

13 files changed

+286
-2
lines changed

‎.github/workflows/master.yml

+1
Original file line numberDiff line numberDiff line change
@@ -75,6 +75,7 @@ jobs:
7575
(cd servant-machines && eval $DOCTEST)
7676
(cd servant-conduit && eval $DOCTEST)
7777
(cd servant-pipes && eval $DOCTEST)
78+
(cd servant-io-streams && eval $DOCTEST)
7879
7980
# stack:
8081
# name: stack / ghc ${{ matrix.ghc }}

‎cabal.project

+1
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@ packages:
2020
servant-machines/
2121
servant-conduit/
2222
servant-pipes/
23+
servant-io-streams/
2324

2425
-- servant GHCJS
2526
-- packages:

‎default.nix

+2
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,7 @@ let
1616
servant-foreign = self.callCabal2nix "servant-foreign" ./servant-foreign {};
1717
servant-conduit = self.callCabal2nix "servant-conduit" ./servant-conduit {};
1818
servant-machines = self.callCabal2nix "servant-machines" ./servant-machines {};
19+
servant-io-streams = self.callCabal2nix "servant-io-streams" ./servant-io-streams {};
1920
servant-client-core = self.callCabal2nix "servant-client-core" ./servant-client-core {};
2021
servant-http-streams = self.callCabal2nix "servant-http-streams" ./servant-http-streams {};
2122
};
@@ -33,6 +34,7 @@ in
3334
servant-http-streams
3435
servant-machines
3536
servant-pipes
37+
servant-io-streams
3638
servant-server;
3739
}
3840

‎doc/cookbook/basic-streaming/Streaming.lhs

+3-2
Original file line numberDiff line numberDiff line change
@@ -10,8 +10,9 @@ In other words, without streaming libraries.
1010
We have bindings for them though.
1111
- Similar example is bundled with each of our streaming library interop packages (see
1212
[servant-pipes](https://github.com/haskell-servant/servant/blob/master/servant-pipes/example/Main.hs),
13-
[servant-conduit](https://github.com/haskell-servant/servant/blob/master/servant-conduit/example/Main.hs) and
14-
[servant-machines](https://github.com/haskell-servant/servant/blob/master/servant-machines/example/Main.hs))
13+
[servant-conduit](https://github.com/haskell-servant/servant/blob/master/servant-conduit/example/Main.hs),
14+
[servant-machines](https://github.com/haskell-servant/servant/blob/master/servant-machines/example/Main.hs) and
15+
[servant-io-streams](https://github.com/haskell-servant/servant/blob/master/servant-io-streams/example/Main.hs))
1516
- `SourceT` doesn't have *Prelude* with handy combinators, so we have to write
1617
things ourselves. (Note to self: `mapM` and `foldM` would be handy to have).
1718

‎servant-io-streams/CHANGELOG.md

+4
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
0.1
2+
----
3+
4+
- First release

‎servant-io-streams/LICENSE

+30
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,30 @@
1+
Copyright (c) 2023, Servant Contributors
2+
3+
All rights reserved.
4+
5+
Redistribution and use in source and binary forms, with or without
6+
modification, are permitted provided that the following conditions are met:
7+
8+
* Redistributions of source code must retain the above copyright
9+
notice, this list of conditions and the following disclaimer.
10+
11+
* Redistributions in binary form must reproduce the above
12+
copyright notice, this list of conditions and the following
13+
disclaimer in the documentation and/or other materials provided
14+
with the distribution.
15+
16+
* Neither the name of Servant Contributors nor the names of other
17+
contributors may be used to endorse or promote products derived
18+
from this software without specific prior written permission.
19+
20+
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

‎servant-io-streams/README.md

+3
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
# servant-io-streams - Servant Stream support for io-streams
2+
3+
![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png)

‎servant-io-streams/Setup.hs

+2
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,2 @@
1+
import Distribution.Simple
2+
main = defaultMain

‎servant-io-streams/example/Main.hs

+105
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,105 @@
1+
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE DeriveGeneric #-}
3+
{-# LANGUAGE TypeOperators #-}
4+
module Main (main) where
5+
6+
import Prelude ()
7+
import Prelude.Compat
8+
9+
import Control.Concurrent
10+
(threadDelay)
11+
import Control.Monad.IO.Class
12+
(MonadIO (..))
13+
import qualified Data.ByteString as BS
14+
import Data.Maybe
15+
(fromMaybe)
16+
import Network.HTTP.Client
17+
(defaultManagerSettings, newManager)
18+
import System.Environment
19+
(getArgs, lookupEnv)
20+
import System.IO
21+
(IOMode (..), openFile, hClose)
22+
import Text.Read
23+
(readMaybe)
24+
25+
import qualified System.IO.Streams as IOS
26+
import System.IO.Streams.Combinators
27+
(atEndOfInput)
28+
import System.IO.Streams.Handle
29+
(handleToInputStream)
30+
import Servant
31+
import Servant.Client.Streaming
32+
import Servant.IO.Streams ()
33+
34+
import qualified Network.Wai.Handler.Warp as Warp
35+
36+
type FastAPI = "get" :> Capture "num" Int :> StreamGet NewlineFraming JSON (IOS.InputStream Int)
37+
38+
type API = FastAPI
39+
:<|> "slow" :> Capture "num" Int :> StreamGet NewlineFraming JSON (IOS.InputStream Int)
40+
:<|> "readme" :> StreamGet NoFraming OctetStream (IOS.InputStream BS.ByteString)
41+
-- we can have streaming request body
42+
:<|> "proxy"
43+
:> StreamBody NoFraming OctetStream (IOS.InputStream BS.ByteString)
44+
:> StreamPost NoFraming OctetStream (IOS.InputStream BS.ByteString)
45+
46+
api :: Proxy API
47+
api = Proxy
48+
49+
server :: Server API
50+
server = fast :<|> slow :<|> readme :<|> proxy
51+
where
52+
fast n = liftIO $ do
53+
putStrLn ("/get/" ++ show n)
54+
IOS.fromGenerator $ fastGenerator n
55+
56+
slow n = liftIO $ do
57+
putStrLn ("/slow/" ++ show n)
58+
IOS.fromGenerator $ slowGenerator n
59+
60+
readme = liftIO $ do
61+
putStrLn "/readme"
62+
h <- openFile "README.md" ReadMode
63+
is <- handleToInputStream h
64+
atEndOfInput (hClose h) is
65+
66+
proxy c = liftIO $ do
67+
putStrLn "/proxy"
68+
return c
69+
70+
fastGenerator n
71+
| n < 0 = return ()
72+
| otherwise = IOS.yield n >> fastGenerator (n - 1)
73+
74+
slowGenerator n
75+
| n < 0 = return ()
76+
| otherwise = IOS.yield n >> liftIO (threadDelay 1000000) >> slowGenerator (n - 1)
77+
78+
app :: Application
79+
app = serve api server
80+
81+
cli :: Client ClientM FastAPI
82+
cli :<|> _ :<|> _ :<|> _ = client api
83+
84+
main :: IO ()
85+
main = do
86+
args <- getArgs
87+
case args of
88+
("server":_) -> do
89+
putStrLn "Starting servant-io-streams:example at http://localhost:8000"
90+
port <- fromMaybe 8000 . (>>= readMaybe) <$> lookupEnv "PORT"
91+
Warp.run port app
92+
("client":ns:_) -> do
93+
n <- maybe (fail $ "not a number: " ++ ns) pure $ readMaybe ns
94+
mgr <- newManager defaultManagerSettings
95+
burl <- parseBaseUrl "http://localhost:8000/"
96+
withClientM (cli n) (mkClientEnv mgr burl) $ \me -> case me of
97+
Left err -> print err
98+
Right s -> do
99+
x <- IOS.fold (\c _ -> c + 1) (0 :: Int) s
100+
print x
101+
_ -> do
102+
putStrLn "Try:"
103+
putStrLn "cabal new-run servant-io-streams:example server"
104+
putStrLn "cabal new-run servant-io-streams:example client 10"
105+
putStrLn "time curl -H 'Accept: application/json' localhost:8000/slow/5"

‎servant-io-streams/servant-io-streams.cabal

+57
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,57 @@
1+
cabal-version: 2.2
2+
name: servant-io-streams
3+
version: 0.1
4+
5+
synopsis: Servant Stream support for io-streams
6+
category: Servant, Web, io-streams
7+
description: Servant Stream support for io-streams.
8+
.
9+
Provides 'ToSourceIO' and 'FromSourceIO' instances for 'InputStream'.
10+
11+
homepage: http://docs.servant.dev/
12+
bug-reports: http://github.com/haskell-servant/servant/issues
13+
license: BSD-3-Clause
14+
license-file: LICENSE
15+
author: Servant Contributors
16+
maintainer: [email protected]
17+
copyright: 2023 Servant Contributors
18+
build-type: Simple
19+
tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2
20+
21+
extra-source-files:
22+
CHANGELOG.md
23+
24+
source-repository head
25+
type: git
26+
location: http://github.com/haskell-servant/servant.git
27+
28+
library
29+
exposed-modules: Servant.IO.Streams
30+
build-depends:
31+
base >=4.9 && <5
32+
, io-streams ^>=1.5
33+
, servant >=0.15 && <0.20
34+
hs-source-dirs: src
35+
default-language: Haskell2010
36+
ghc-options: -Wall
37+
38+
test-suite example
39+
type: exitcode-stdio-1.0
40+
main-is: Main.hs
41+
hs-source-dirs:
42+
example
43+
ghc-options: -Wall -rtsopts -threaded
44+
build-depends:
45+
base
46+
, base-compat
47+
, bytestring
48+
, http-media
49+
, servant
50+
, servant-io-streams
51+
, io-streams ^>= 1.5
52+
, servant-server >=0.15 && <0.20
53+
, servant-client >=0.15 && <0.20
54+
, wai >=3.2.1.2 && <3.3
55+
, warp >=3.2.25 && <3.4
56+
, http-client
57+
default-language: Haskell2010

‎servant-io-streams/src/Servant/IO/Streams.hs

+31
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,31 @@
1+
{-# LANGUAGE FlexibleInstances #-}
2+
{-# LANGUAGE MultiParamTypeClasses #-}
3+
{-# OPTIONS_GHC -Wno-orphans #-}
4+
{-# OPTIONS_GHC -fno-cse #-}
5+
-- | This module exports 'ToSourceIO' and 'FromSourceIO' for 'IOStreams.InputStream'
6+
module Servant.IO.Streams where
7+
8+
import Control.Monad.IO.Class (liftIO)
9+
import System.IO.Unsafe
10+
(unsafePerformIO)
11+
import qualified System.IO.Streams.Core as IOS
12+
import Servant.API.Stream
13+
import qualified Servant.Types.SourceT as S
14+
15+
instance ToSourceIO a (IOS.InputStream a) where
16+
toSourceIO src = S.SourceT ($ go)
17+
where
18+
go = S.Effect $ trans <$> IOS.read src
19+
20+
trans Nothing = S.Stop
21+
trans (Just c) = S.Yield c go
22+
23+
instance FromSourceIO a (IOS.InputStream a) where
24+
{-# NOINLINE fromSourceIO #-}
25+
fromSourceIO src = unsafePerformIO $ S.unSourceT src $ IOS.fromGenerator . gen
26+
where
27+
gen S.Stop = pure ()
28+
gen (S.Error s) = liftIO $ fail s
29+
gen (S.Skip s) = gen s
30+
gen (S.Yield a s) = IOS.yield a >> gen s
31+
gen (S.Effect ms) = liftIO ms >>= gen

‎stack.yaml

+1
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@ packages:
1111
- servant-conduit
1212
- servant-machines/
1313
- servant-pipes/
14+
- servant-io-streams/
1415
- servant-swagger/
1516

1617
# allow-newer: true # ignores all bounds, that's a sledgehammer

‎streaming-benchmark.sh

+46
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,10 @@ cleanup() {
2828
kill "$PIPES_PID" || true
2929
fi
3030

31+
if [ ! -z "$STREAMS_PID" ]; then
32+
kill "$STREAMS_PID" || true
33+
fi
34+
3135
if [ ! -z "$COOKBOOK_PID" ]; then
3236
kill "$COOKBOOK_PID" || true
3337
fi
@@ -107,6 +111,27 @@ curl --silent --show-error "$PROXYURL" --request POST --data-binary @"$TESTFILE"
107111
kill -INT $COOKBOOK_PID
108112
unset COOKBOOK_PID
109113

114+
## io-streams
115+
116+
bench "server streams"
117+
118+
$(cabal-plan list-bin servant-io-streams:test:example) server +RTS -sbench-io-streams-server-rts.txt &
119+
STREAMS_PID=$!
120+
echo "Starting servant-io-streams server. PID=$STREAMS_PID"
121+
122+
# Time to startup
123+
sleep 1
124+
125+
# Run slow url to test & warm-up server
126+
curl "$SLOWURL"
127+
128+
curl --silent --show-error "$FASTURL" --output /dev/null --write-out "$CURLSTATS" > bench-streams-server.txt
129+
130+
curl --silent --show-error "$PROXYURL" --request POST --data-binary @"$TESTFILE" --output "$TMPFILE" --write-out "$CURLSTATS" > bench-streams-server-proxy.txt
131+
132+
kill -INT $STREAMS_PID
133+
unset STREAMS_PID
134+
110135
## Conduit
111136

112137
bench "server conduit"
@@ -155,6 +180,17 @@ $(cabal-plan list-bin servant-pipes:test:example) client 10
155180
/usr/bin/time --verbose --output bench-pipes-client-time.txt \
156181
"$(cabal-plan list-bin servant-pipes:test:example)" client "$SIZE" +RTS -sbench-pipes-client-rts.txt
157182

183+
## Streams
184+
185+
bench "client streams"
186+
187+
# Test run
188+
$(cabal-plan list-bin servant-io-streams:test:example) client 10
189+
190+
# Real run
191+
/usr/bin/time --verbose --output bench-io-streams-client-time.txt \
192+
"$(cabal-plan list-bin servant-io-streams:test:example)" client "$SIZE" +RTS -sbench-io-streams-client-rts.txt
193+
158194
## Conduit
159195

160196
bench "client conduit"
@@ -230,6 +266,11 @@ report bench-pipes-server.txt
230266
report bench-pipes-server-proxy.txt
231267
report bench-pipes-server-rts.txt
232268

269+
header "###" io-streams
270+
report bench-streams-server.txt
271+
report bench-streams-server-proxy.txt
272+
report bench-streams-server-rts.txt
273+
233274
header "###" conduit
234275
note "Conduit server is also used for client tests below"
235276
report bench-conduit-server.txt
@@ -251,6 +292,10 @@ header "###" pipes
251292
report2 bench-pipes-client-time.txt
252293
report bench-pipes-client-rts.txt
253294

295+
header "###" io-streams
296+
report2 bench-streams-client-time.txt
297+
report bench-streams-client-rts.txt
298+
254299
header "###" conduit
255300
report2 bench-conduit-client-time.txt
256301
report bench-conduit-client-rts.txt
@@ -262,6 +307,7 @@ report bench-cookbook-client-rts.txt
262307
# Cleanup filepaths
263308
sed -E -i 's/\/[^ ]*machines[^ ]*\/example/...machines:example/' bench.md
264309
sed -E -i 's/\/[^ ]*conduit[^ ]*\/example/...conduit:example/' bench.md
310+
sed -E -i 's/\/[^ ]*io-streams[^ ]*\/example/...io-streams:example/' bench.md
265311
sed -E -i 's/\/[^ ]*pipes[^ ]*\/example/...pipes:example/' bench.md
266312
sed -E -i 's/\/[^ ]*\/cookbook-basic-streaming/...cookbook-basic-streaming/' bench.md
267313

0 commit comments

Comments
 (0)