d4168aa · typeable/servant

git.iko.soy/typeable/servant

first round of changes

commitd4168aa3ae02133cbc517b39ec7014f44fa62d36 authorGershom <gershom@awakesecurity.com> dateThu 19 Oct 2017, 17:41 (9 years ago) parentc5e0451

4 files changed+103−32

compare with master

unifiedsplit

servant-server/src/Servant/Server/Internal.hs+47−18 servant/src/Servant/API.hs+3−2 servant/src/Servant/API/Stream.hs+48−12 servant/src/Servant/Utils/Links.hs+5

servant-server/src/Servant/Server/Internal.hs+47−18

@@ -10,6 +10,7 @@

1010{-# LANGUAGE PolyKinds #-}

1111{-# LANGUAGE RankNTypes #-}

1212{-# LANGUAGE ScopedTypeVariables #-}

13+{-# LANGUAGE TupleSections #-}

1314{-# LANGUAGE TypeFamilies #-}

1415{-# LANGUAGE TypeOperators #-}

1516

@@ -67,8 +68,8 @@ import Servant.API ((:<|>) (..), (:>), BasicAuth, Capt

6768 WithNamedContext,

6869 Description, Summary,

6970 Accept(..),

70− Framing(..), Stream,

71− StreamGenerator(..),

71+ FramingRender(..), Stream,

72+ StreamGenerator(..), ToStreamGenerator(..),

7273 BoundaryStrategy(..))

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

7475 AllCTRender (..),

@@ -287,40 +288,68 @@ instance OVERLAPPING_

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

288289

289290

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

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

291+instance OVERLAPPABLE_

292+ ( MimeRender ctype a, ReflectMethod method,

293+ FramingRender framing ctype, ToStreamGenerator f a

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

295+

296+ type ServerT (Stream method framing ctype (f a)) m = m (f a)

297+ hoistServerWithContext _ _ nt s = nt s

298+

299+ route Proxy _ = streamRouter ([],) method (Proxy :: Proxy framing) (Proxy :: Proxy ctype)

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

301+

302+instance OVERLAPPING_

303+ ( MimeRender ctype a, ReflectMethod method,

304+ FramingRender framing ctype, ToStreamGenerator f a,

305+ GetHeaders (Headers h (f a))

306+ ) => HasServer (Stream method framing ctype (Headers h (f a))) context where

292307

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

308+ type ServerT (Stream method framing ctype (Headers h (f a))) m = m (Headers h (f a))

294309 hoistServerWithContext _ _ nt s = nt s

295310

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

311+ route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy framing) (Proxy :: Proxy ctype)

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

313+

314+

315+streamRouter :: (MimeRender ctype a, FramingRender framing ctype, ToStreamGenerator f a) =>

316+ (b -> ([(HeaderName, B.ByteString)], f a))

317+ -> Method

318+ -> Proxy framing

319+ -> Proxy ctype

320+ -> Delayed env (Handler b)

321+ -> Router env

322+streamRouter splitHeaders method framingproxy ctypeproxy action = leafRouter $ \env request respond ->

297323 let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

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

324+ cmediatype = NHM.matchAccept [contentType ctypeproxy] accH

299325 accCheck = when (isNothing cmediatype) $ delayedFail err406

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

301327 in runAction (action `addMethodCheck` methodCheck method request

302328 `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

329+ ) env request respond $ \ output ->

330+ let (headers, fa) = splitHeaders output

331+ k = getStreamGenerator . toStreamGenerator $ fa in

332+ Route $ responseStream status200 (contentHeader : headers) $ \write flush -> do

333+ write . BB.lazyByteString $ header framingproxy ctypeproxy

334+ case boundary framingproxy ctypeproxy of

307335 BoundaryStrategyBracket f ->

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

336+ let go x = let bs = mimeRender ctypeproxy $ x

309337 (before, after) = f bs

310338 in write ( BB.lazyByteString before

311339 <> BB.lazyByteString bs

312− <> BB.lazyByteString after)

340+ <> BB.lazyByteString after) >> flush

313341 in k go go

314342 BoundaryStrategyIntersperse sep -> k

315343 (\x -> do

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

344+ write . BB.lazyByteString . mimeRender ctypeproxy $ x

317345 flush)

318346 (\x -> do

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

347+ write . (BB.lazyByteString sep <>) . BB.lazyByteString . mimeRender ctypeproxy $ x

320348 flush)

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

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

323−

349+ BoundaryStrategyGeneral f ->

350+ let go = (>> flush) . write . BB.lazyByteString . f . mimeRender ctypeproxy

351+ in k go go

352+ write . BB.lazyByteString $ terminate framingproxy ctypeproxy

324353

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

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

servant/src/Servant/API.hs+3−2

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

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

8484 QueryParams)

8585import Servant.API.Raw (Raw)

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

87− Framing(..), BoundaryStrategy(..),

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

87+ FramingRender(..), BoundaryStrategy(..),

88+ FramingUnrender(..),

8889 NewlineFraming)

8990import Servant.API.RemoteHost (RemoteHost)

9091import Servant.API.ReqBody (ReqBody)

servant/src/Servant/API/Stream.hs+48−12

@@ -5,38 +5,74 @@

55{-# LANGUAGE MultiParamTypeClasses #-}

66{-# LANGUAGE OverloadedStrings #-}

77{-# LANGUAGE PolyKinds #-}

8+{-# LANGUAGE TupleSections #-}

89{-# OPTIONS_HADDOCK not-home #-}

910

1011module Servant.API.Stream where

1112

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

13−import Data.Proxy (Proxy)

14−import Data.Typeable (Typeable)

15−import GHC.Generics (Generic)

13+import Control.Arrow ((***), first)

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

15+import qualified Data.ByteString.Lazy.Char8 as LB

16+import Data.Proxy (Proxy)

17+import Data.Typeable (Typeable)

18+import GHC.Generics (Generic)

19+import Text.Read (readMaybe)

1620

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

1822data Stream (method :: k1) (framing :: *) (contentType :: *) a

1923 deriving (Typeable, Generic)

2024

2125-- | 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 ())

26+newtype StreamGenerator a = StreamGenerator {getStreamGenerator :: (a -> IO ()) -> (a -> IO ()) -> IO ()}

2327

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

28+-- | ToStreamGenerator is intended to be implemented for types such as Conduit, Pipe, etc. By implementing this class, all such streaming abstractions can be used directly as endpoints.

29+class ToStreamGenerator f a where

30+ toStreamGenerator :: f a -> StreamGenerator a

31+

32+instance ToStreamGenerator StreamGenerator a

33+ where toStreamGenerator x = x

34+

35+-- | The FramingRender class provides the logic for emitting a 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.

36+class FramingRender strategy a where

2637 header :: Proxy strategy -> Proxy a -> ByteString

2738 boundary :: Proxy strategy -> Proxy a -> BoundaryStrategy

2839 terminate :: Proxy strategy -> Proxy a -> ByteString

2940

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

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

43+-- Finally, the general strategy performs an arbitrary rewrite on the content, to allow escaping rules and such.

3244data BoundaryStrategy = BoundaryStrategyBracket (ByteString -> (ByteString,ByteString))

3345 | BoundaryStrategyIntersperse ByteString

46+ | BoundaryStrategyGeneral (ByteString -> ByteString)

3447

48+-- | The FramingUnrender class provides the logic for parsing a framing strategy. Given a ByteString, it strips the header, and returns a tuple of the remainder along with a step function that can progressively "uncons" elements from this remainder. The error state is presented per-frame so that protocols that can resume after errors are able to do so.

49+

50+class FramingUnrender strategy a where

51+ unrenderFrames :: Proxy strategy -> Proxy a -> ByteString -> (ByteString, ByteString -> (Either String ByteString, ByteString))

3552

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

54+-- This assumes that it is used with a Content-Type that encodes without newlines (e.g. JSON).

3755data NewlineFraming

3856

39−instance Framing NewlineFraming a where

40− header _ _ = empty

41− boundary _ _ = BoundaryStrategyIntersperse "\n"

42− terminate _ _ = empty

57+instance FramingRender NewlineFraming a where

58+ header _ _ = empty

59+ boundary _ _ = BoundaryStrategyIntersperse "\n"

60+ terminate _ _ = empty

61+

62+instance FramingUnrender NewlineFraming a where

63+ unrenderFrames _ _ = (, (Right *** LB.drop 1) . LB.break (== '\n'))

64+

65+-- | The netstring framing strategy as defined by djb: <http://cr.yp.to/proto/netstrings.txt>

66+data NetstringFraming

67+

68+instance FramingRender NetstringFraming a where

69+ header _ _ = empty

70+ boundary _ _ = BoundaryStrategyBracket $ \b -> (LB.pack . show . LB.length $ b, "")

71+ terminate _ _ = empty

72+

73+instance FramingUnrender NetstringFraming a where

74+ unrenderFrames _ _ = (, \b -> let (i,r) = LB.break (==':') b

75+ in case readMaybe (LB.unpack i) of

76+ Just len -> first Right $ LB.splitAt len . LB.drop 1 $ r

77+ Nothing -> (Left ("Bad netstring frame, couldn't parse value as integer value: " ++ LB.unpack i), LB.drop 1 . LB.dropWhile (/= ',') $ r)

78+ )

servant/src/Servant/Utils/Links.hs+5

@@ -117,6 +117,7 @@ import Servant.API.RemoteHost ( RemoteHost )

117117import Servant.API.Verbs ( Verb )

118118import Servant.API.Sub ( type (:>) )

119119import Servant.API.Raw ( Raw )

120+import Servant.API.Stream ( Stream )

120121import Servant.API.TypeLevel

121122import Servant.API.Experimental.Auth ( AuthProtect )

122123

@@ -306,6 +307,10 @@ instance HasLink Raw where

306307 type MkLink Raw = Link

307308 toLink _ = id

308309

310+instance HasLink (Stream m fr ct a) where

311+ type MkLink (Stream m fr ct a) = Link

312+ toLink _ = id

313+

309314-- AuthProtext instances

310315instance HasLink sub => HasLink (AuthProtect tag :> sub) where

311316 type MkLink (AuthProtect tag :> sub) = MkLink sub