d4168aa · typeable/servant

git.iko.soy/typeable/servant

on master help sign in

first round of changes

d4168aaGershom9 years ago

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

compare with master

unifiedsplit

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

10{-# LANGUAGE PolyKinds #-}

11{-# LANGUAGE RankNTypes #-}

12{-# LANGUAGE ScopedTypeVariables #-}

13+{-# LANGUAGE TupleSections #-}

13{-# LANGUAGE TypeFamilies #-}

14{-# LANGUAGE TypeFamilies #-}

14{-# LANGUAGE TypeOperators #-}

15{-# LANGUAGE TypeOperators #-}

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

67 WithNamedContext,

68 WithNamedContext,

68 Description, Summary,

69 Description, Summary,

69 Accept(..),

70 Accept(..),

70− Framing(..), Stream,

71+ FramingRender(..), Stream,

71− StreamGenerator(..),

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

72 BoundaryStrategy(..))

73 BoundaryStrategy(..))

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

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

74 AllCTRender (..),

75 AllCTRender (..),

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

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

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

288

289

290

291+instance OVERLAPPABLE_

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

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

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

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

292

307

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

294 hoistServerWithContext _ _ nt s = nt s

309 hoistServerWithContext _ _ nt s = nt s

295

310

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

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

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

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

323 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

299 accCheck = when (isNothing cmediatype) $ delayedFail err406

325 accCheck = when (isNothing cmediatype) $ delayedFail err406

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

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

301 in runAction (action `addMethodCheck` methodCheck method request

327 in runAction (action `addMethodCheck` methodCheck method request

302 `addAcceptCheck` accCheck

328 `addAcceptCheck` accCheck

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

329+ ) env request respond $ \ output ->

330+ let (headers, fa) = splitHeaders output

331+ k = getStreamGenerator . toStreamGenerator $ fa in

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

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

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

333+ write . BB.lazyByteString $ header framingproxy ctypeproxy

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

334+ case boundary framingproxy ctypeproxy of

307 BoundaryStrategyBracket f ->

335 BoundaryStrategyBracket f ->

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

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

309 (before, after) = f bs

337 (before, after) = f bs

310 in write ( BB.lazyByteString before

338 in write ( BB.lazyByteString before

311 <> BB.lazyByteString bs

339 <> BB.lazyByteString bs

312− <> BB.lazyByteString after)

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

313 in k go go

341 in k go go

314 BoundaryStrategyIntersperse sep -> k

342 BoundaryStrategyIntersperse sep -> k

315 (\x -> do

343 (\x -> do

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

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

317 flush)

345 flush)

318 (\x -> do

346 (\x -> do

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

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

320 flush)

348 flush)

349+ BoundaryStrategyGeneral f ->

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

351+ in k go go

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

352+ write . BB.lazyByteString $ terminate framingproxy ctypeproxy

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

323−

324

353

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

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

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

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

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

84 QueryParams)

85import Servant.API.Raw (Raw)

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

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

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

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

88+ FramingUnrender(..),

88 NewlineFraming)

89 NewlineFraming)

89import Servant.API.RemoteHost (RemoteHost)

90import Servant.API.RemoteHost (RemoteHost)

90import Servant.API.ReqBody (ReqBody)

91import Servant.API.ReqBody (ReqBody)

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

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

5{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE OverloadedStrings #-}

7{-# LANGUAGE PolyKinds #-}

8+{-# LANGUAGE TupleSections #-}

8{-# OPTIONS_HADDOCK not-home #-}

9{-# OPTIONS_HADDOCK not-home #-}

10module Servant.API.Stream where

11module Servant.API.Stream where

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

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

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

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

13−import Data.Proxy (Proxy)

16+import Data.Proxy (Proxy)

14−import Data.Typeable (Typeable)

17+import Data.Typeable (Typeable)

15−import GHC.Generics (Generic)

18+import GHC.Generics (Generic)

19+import Text.Read (readMaybe)

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

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

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

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

19 deriving (Typeable, Generic)

23 deriving (Typeable, Generic)

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

25-- | 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 ()}

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+

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.

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.

25−class Framing strategy a where

36+class FramingRender strategy a where

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

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

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

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

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

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

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

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

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

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

33 | BoundaryStrategyIntersperse ByteString

45 | BoundaryStrategyIntersperse ByteString

46+ | BoundaryStrategyGeneral (ByteString -> ByteString)

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

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

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

37data NewlineFraming

55data NewlineFraming

39−instance Framing NewlineFraming a where

57+instance FramingRender NewlineFraming a where

40− header _ _ = empty

58+ header _ _ = empty

41− boundary _ _ = BoundaryStrategyIntersperse "\n"

59+ boundary _ _ = BoundaryStrategyIntersperse "\n"

42− terminate _ _ = empty

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 )

117import Servant.API.Verbs ( Verb )

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

119import Servant.API.Raw ( Raw )

120+import Servant.API.Stream ( Stream )

120import Servant.API.TypeLevel

121import Servant.API.TypeLevel

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

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

122

123

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

306 type MkLink Raw = Link

307 type MkLink Raw = Link

307 toLink _ = id

308 toLink _ = id

308

309

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

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

312+ toLink _ = id

313+

309-- AuthProtext instances

314-- AuthProtext instances

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

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

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

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