c5e0451 · typeable/servant

git.iko.soy/typeable/servant

initial checkin

commitc5e04514f99f95b79b255475a22171c1894edcdd authorGershom <gershom@awakesecurity.com> dateWed 18 Oct 2017, 18:43 (9 years ago) parentff5502f

5 files changed+101−5

compare with master

unifiedsplit

servant-server/servant-server.cabal+1 servant-server/src/Servant/Server/Internal.hs+50−4 servant/servant.cabal+1 servant/src/Servant/API.hs+7−1 servant/src/Servant/API/Stream.hs+42

servant-server/servant-server.cabal+1

@@ -60,6 +60,7 @@ library

6060 , containers >= 0.5 && < 0.6

6161 , exceptions >= 0.8 && < 0.9

6262 , http-api-data >= 0.3 && < 0.4

63+ , http-media >= 0.4 && < 0.8

6364 , http-types >= 0.8 && < 0.10

6465 , network-uri >= 2.6 && < 2.7

6566 , monad-control >= 1.0.0.4 && < 1.1

servant-server/src/Servant/Server/Internal.hs+50−4

@@ -25,12 +25,15 @@ module Servant.Server.Internal

2525 , module Servant.Server.Internal.ServantErr

2626 ) where

2727

28+import Control.Monad (when)

2829import Control.Monad.Trans (liftIO)

2930import Control.Monad.Trans.Resource (runResourceT)

3031import qualified Data.ByteString as B

32+import qualified Data.ByteString.Builder as BB

3133import qualified Data.ByteString.Char8 as BC8

3234import qualified Data.ByteString.Lazy as BL

33−import Data.Maybe (fromMaybe, mapMaybe)

35+import Data.Maybe (fromMaybe, mapMaybe,

36+ isNothing, maybeToList)

3437import Data.Either (partitionEithers)

3538import Data.String (fromString)

3639import Data.String.Conversions (cs, (<>))

@@ -40,13 +43,15 @@ import Data.Typeable

4043import GHC.TypeLits (KnownNat, KnownSymbol, natVal,

4144 symbolVal)

4245import Network.HTTP.Types hiding (Header, ResponseHeaders)

46+import qualified Network.HTTP.Media as NHM

4347import Network.Socket (SockAddr)

4448import Network.Wai (Application, Request, Response,

4549 httpVersion, isSecure,

4650 lazyRequestBody,

4751 rawQueryString, remoteHost,

4852 requestHeaders, requestMethod,

49− responseLBS, vault)

53+ responseLBS, responseStream,

54+ vault)

5055import Prelude ()

5156import Prelude.Compat

5257import Web.HttpApiData (FromHttpApiData, parseHeader,

@@ -60,11 +65,16 @@ import Servant.API ((:<|>) (..), (:>), BasicAuth, Capt

6065 QueryParam, QueryParams, Raw,

6166 RemoteHost, ReqBody, Vault,

6267 WithNamedContext,

63− Description, Summary)

68+ Description, Summary,

69+ Accept(..),

70+ Framing(..), Stream,

71+ StreamGenerator(..),

72+ BoundaryStrategy(..))

6473import Servant.API.ContentTypes (AcceptHeader (..),

6574 AllCTRender (..),

6675 AllCTUnrender (..),

6776 AllMime,

77+ MimeRender(..),

6878 canHandleAcceptH)

6979import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,

7080 getResponse)

@@ -276,6 +286,42 @@ instance OVERLAPPING_

276286 where method = reflectMethod (Proxy :: Proxy method)

277287 status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)

278288

289+

290+instance ( MimeRender ctype a, ReflectMethod method, Framing framing ctype

291+ ) => HasServer (Stream method framing ctype a) context where

292+

293+ type ServerT (Stream method framing ctype a) m = m (StreamGenerator a)

294+ hoistServerWithContext _ _ nt s = nt s

295+

296+ route Proxy _ action = leafRouter $ \env request respond ->

297+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

298+ cmediatype = NHM.matchAccept [contentType (Proxy :: Proxy ctype)] accH

299+ accCheck = when (isNothing cmediatype) $ delayedFail err406

300+ contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype)

301+ in runAction (action `addMethodCheck` methodCheck method request

302+ `addAcceptCheck` accCheck

303+ ) env request respond $ \ (StreamGenerator k) ->

304+ Route $ responseStream status200 [contentHeader] $ \write flush -> do

305+ write . BB.lazyByteString . header (Proxy :: Proxy framing) $ (Proxy :: Proxy ctype)

306+ case boundary (Proxy :: Proxy framing) (Proxy :: Proxy ctype) of

307+ BoundaryStrategyBracket f ->

308+ let go x = let bs = mimeRender (Proxy :: Proxy ctype) $ x

309+ (before, after) = f bs

310+ in write ( BB.lazyByteString before

311+ <> BB.lazyByteString bs

312+ <> BB.lazyByteString after)

313+ in k go go

314+ BoundaryStrategyIntersperse sep -> k

315+ (\x -> do

316+ write . BB.lazyByteString . mimeRender (Proxy :: Proxy ctype) $ x

317+ flush)

318+ (\x -> do

319+ write . (BB.lazyByteString sep <>) . BB.lazyByteString . mimeRender (Proxy :: Proxy ctype) $ x

320+ flush)

321+ write . BB.lazyByteString . terminate (Proxy :: Proxy framing) $ (Proxy :: Proxy ctype)

322+ where method = reflectMethod (Proxy :: Proxy method)

323+

324+

279325-- | If you use 'Header' in one of the endpoints for your API,

280326-- this automatically requires your server-side handler to be a function

281327-- that takes an argument of the type specified by 'Header'.

@@ -318,7 +364,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)

318364 <> fromString headerName

319365 <> " failed: " <> e

320366 }

321− Right header -> return $ Just header

367+ Right hdr -> return $ Just hdr

322368

323369-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,

324370-- this automatically requires your server-side handler to be a function

servant/servant.cabal+1

@@ -47,6 +47,7 @@ library

4747 Servant.API.IsSecure

4848 Servant.API.QueryParam

4949 Servant.API.Raw

50+ Servant.API.Stream

5051 Servant.API.RemoteHost

5152 Servant.API.ReqBody

5253 Servant.API.ResponseHeaders

servant/src/Servant/API.hs+7−1

@@ -31,7 +31,10 @@ module Servant.API (

3131 -- * Actual endpoints, distinguished by HTTP method

3232 module Servant.API.Verbs,

3333

34− -- * Authentication

34+ -- * Streaming endpoints, distinguished by HTTP method

35+ module Servant.API.Stream,

36+

37+-- * Authentication

3538 module Servant.API.BasicAuth,

3639

3740 -- * Endpoints description

@@ -80,6 +83,9 @@ import Servant.API.IsSecure (IsSecure (..))

8083import Servant.API.QueryParam (QueryFlag, QueryParam,

8184 QueryParams)

8285import Servant.API.Raw (Raw)

86+import Servant.API.Stream (Stream, StreamGenerator(..),

87+ Framing(..), BoundaryStrategy(..),

88+ NewlineFraming)

8389import Servant.API.RemoteHost (RemoteHost)

8490import Servant.API.ReqBody (ReqBody)

8591import Servant.API.ResponseHeaders (AddHeader, addHeader, noHeader,

servant/src/Servant/API/Stream.hsnew file+42

@@ -0,0 +1,42 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE KindSignatures #-}

5+{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE OverloadedStrings #-}

7+{-# LANGUAGE PolyKinds #-}

8+{-# OPTIONS_HADDOCK not-home #-}

10+module Servant.API.Stream where

11+

12+import Data.ByteString.Lazy (ByteString, empty)

13+import Data.Proxy (Proxy)

14+import Data.Typeable (Typeable)

15+import GHC.Generics (Generic)

16+

17+-- | A stream endpoint for a given method emits a stream of encoded values at a given Content-Type, delimited by a framing strategy.

18+data Stream (method :: k1) (framing :: *) (contentType :: *) a

19+ deriving (Typeable, Generic)

20+

21+-- | Stream endpoints may be implemented as producing a @StreamGenerator@ -- a function that itself takes two emit functions -- the first to be used on the first value the stream emits, and the second to be used on all subsequent values (to allow interspersed framing strategies such as comma separation).

22+data StreamGenerator a = StreamGenerator ((a -> IO ()) -> (a -> IO ()) -> IO ())

23+

24+-- | The Framing class provides the logic for each framing strategy. The strategy emits a header, followed by boundary-delimited data, and finally a termination character. For many strategies, some of these will just be empty bytestrings.

25+class Framing strategy a where

26+ header :: Proxy strategy -> Proxy a -> ByteString

27+ boundary :: Proxy strategy -> Proxy a -> BoundaryStrategy

28+ terminate :: Proxy strategy -> Proxy a -> ByteString

29+

30+-- | The bracketing strategy generates things to precede and follow the content, as with netstrings.

31+-- | The intersperse strategy inserts seperators between things, as with newline framing.

32+data BoundaryStrategy = BoundaryStrategyBracket (ByteString -> (ByteString,ByteString))

33+ | BoundaryStrategyIntersperse ByteString

34+

35+

36+-- | A simple framing strategy that has no header or termination, and inserts a newline character between each frame.

37+data NewlineFraming

38+

39+instance Framing NewlineFraming a where

40+ header _ _ = empty

41+ boundary _ _ = BoundaryStrategyIntersperse "\n"

42+ terminate _ _ = empty