eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

initial checkin

Browse source
This commit is contained in:
Gershom 2017-10-18 18:43:43 -04:00
parent ff5502f4f7
commit c5e04514f9
5 changed files with 101 additions and 5 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
servant-server/servant-server.cabal
View file

@ -60,6 +60,7 @@ library
, containers >= 0.5 && < 0.6
, exceptions >= 0.8 && < 0.9
, http-api-data >= 0.3 && < 0.4
, http-media >= 0.4 && < 0.8
, http-types >= 0.8 && < 0.10
, network-uri >= 2.6 && < 2.7
, monad-control >= 1.0.0.4 && < 1.1

54
servant-server/src/Servant/Server/Internal.hs
View file

@ -25,12 +25,15 @@ module Servant.Server.Internal
, module Servant.Server.Internal.ServantErr
) where
import Control.Monad (when)
import Control.Monad.Trans (liftIO)
import Control.Monad.Trans.Resource (runResourceT)
import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Char8 as BC8
import qualified Data.ByteString.Lazy as BL
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Maybe (fromMaybe, mapMaybe,
isNothing, maybeToList)
import Data.Either (partitionEithers)
import Data.String (fromString)
import Data.String.Conversions (cs, (<>))
@ -40,13 +43,15 @@ import Data.Typeable
import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
symbolVal)
import Network.HTTP.Types hiding (Header, ResponseHeaders)
import qualified Network.HTTP.Media as NHM
import Network.Socket (SockAddr)
import Network.Wai (Application, Request, Response,
httpVersion, isSecure,
lazyRequestBody,
rawQueryString, remoteHost,
requestHeaders, requestMethod,
responseLBS, vault)
responseLBS, responseStream,
vault)
import Prelude ()
import Prelude.Compat
import Web.HttpApiData (FromHttpApiData, parseHeader,
@ -60,11 +65,16 @@ import Servant.API ((:<|>) (..), (:>), BasicAuth, Capt
QueryParam, QueryParams, Raw,
RemoteHost, ReqBody, Vault,
WithNamedContext,
Description, Summary)
Description, Summary,
Accept(..),
Framing(..), Stream,
StreamGenerator(..),
BoundaryStrategy(..))
import Servant.API.ContentTypes (AcceptHeader (..),
AllCTRender (..),
AllCTUnrender (..),
AllMime,
MimeRender(..),
canHandleAcceptH)
import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
getResponse)
@ -276,6 +286,42 @@ instance OVERLAPPING_
where method = reflectMethod (Proxy :: Proxy method)
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
instance ( MimeRender ctype a, ReflectMethod method, Framing framing ctype
) => HasServer (Stream method framing ctype a) context where
type ServerT (Stream method framing ctype a) m = m (StreamGenerator a)
hoistServerWithContext _ _ nt s = nt s
route Proxy _ action = leafRouter $ \env request respond ->
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
cmediatype = NHM.matchAccept [contentType (Proxy :: Proxy ctype)] accH
accCheck = when (isNothing cmediatype) $ delayedFail err406
contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype)
in runAction (action `addMethodCheck` methodCheck method request
`addAcceptCheck` accCheck
) env request respond $ \ (StreamGenerator k) ->
Route $ responseStream status200 [contentHeader] $ \write flush -> do
write . BB.lazyByteString . header (Proxy :: Proxy framing) $ (Proxy :: Proxy ctype)
case boundary (Proxy :: Proxy framing) (Proxy :: Proxy ctype) of
BoundaryStrategyBracket f ->
let go x = let bs = mimeRender (Proxy :: Proxy ctype) $ x
(before, after) = f bs
in write ( BB.lazyByteString before
<> BB.lazyByteString bs
<> BB.lazyByteString after)
in k go go
BoundaryStrategyIntersperse sep -> k
(\x -> do
write . BB.lazyByteString . mimeRender (Proxy :: Proxy ctype) $ x
flush)
(\x -> do
write . (BB.lazyByteString sep <>) . BB.lazyByteString . mimeRender (Proxy :: Proxy ctype) $ x
flush)
write . BB.lazyByteString . terminate (Proxy :: Proxy framing) $ (Proxy :: Proxy ctype)
where method = reflectMethod (Proxy :: Proxy method)
-- | If you use 'Header' in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function
-- that takes an argument of the type specified by 'Header'.
@ -318,7 +364,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
<> fromString headerName
<> " failed: " <> e
}
Right header -> return $ Just header
Right hdr -> return $ Just hdr
-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function

1
servant/servant.cabal
View file

@ -47,6 +47,7 @@ library
Servant.API.IsSecure
Servant.API.QueryParam
Servant.API.Raw
Servant.API.Stream
Servant.API.RemoteHost
Servant.API.ReqBody
Servant.API.ResponseHeaders

8
servant/src/Servant/API.hs
View file

@ -31,7 +31,10 @@ module Servant.API (
-- * Actual endpoints, distinguished by HTTP method
module Servant.API.Verbs,
-- * Authentication
-- * Streaming endpoints, distinguished by HTTP method
module Servant.API.Stream,
-- * Authentication
module Servant.API.BasicAuth,
-- * Endpoints description
@ -80,6 +83,9 @@ import Servant.API.IsSecure (IsSecure (..))
import Servant.API.QueryParam (QueryFlag, QueryParam,
QueryParams)
import Servant.API.Raw (Raw)
import Servant.API.Stream (Stream, StreamGenerator(..),
Framing(..), BoundaryStrategy(..),
NewlineFraming)
import Servant.API.RemoteHost (RemoteHost)
import Servant.API.ReqBody (ReqBody)
import Servant.API.ResponseHeaders (AddHeader, addHeader, noHeader,

42
servant/src/Servant/API/Stream.hs Normal file
View file

@ -0,0 +1,42 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Stream where
import Data.ByteString.Lazy (ByteString, empty)
import Data.Proxy (Proxy)
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
-- | A stream endpoint for a given method emits a stream of encoded values at a given Content-Type, delimited by a framing strategy.
data Stream (method :: k1) (framing :: *) (contentType :: *) a
deriving (Typeable, Generic)
-- | 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).
data StreamGenerator a = StreamGenerator ((a -> IO ()) -> (a -> IO ()) -> IO ())
-- | 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.
class Framing strategy a where
header :: Proxy strategy -> Proxy a -> ByteString
boundary :: Proxy strategy -> Proxy a -> BoundaryStrategy
terminate :: Proxy strategy -> Proxy a -> ByteString
-- | The bracketing strategy generates things to precede and follow the content, as with netstrings.
-- | The intersperse strategy inserts seperators between things, as with newline framing.
data BoundaryStrategy = BoundaryStrategyBracket (ByteString -> (ByteString,ByteString))
| BoundaryStrategyIntersperse ByteString
-- | A simple framing strategy that has no header or termination, and inserts a newline character between each frame.
data NewlineFraming
instance Framing NewlineFraming a where
header _ _ = empty
boundary _ _ = BoundaryStrategyIntersperse "\n"
terminate _ _ = empty