{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ < 710 {-# LANGUAGE OverlappingInstances #-} #endif module Servant.Server.Internal ( module Servant.Server.Internal , module Servant.Server.Internal.PathInfo , module Servant.Server.Internal.Router , module Servant.Server.Internal.RoutingApplication , module Servant.Server.Internal.ServantErr ) where ------------------------------------------------------------------------------- import Control.Applicative ((<$>)) import Control.Monad.Trans (liftIO) import Control.Monad.Trans.Class (lift) import Control.Monad (join, when) import Data.Bool (bool) import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Builder.Extra as BB import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as BL import Data.Either (partitionEithers) import Data.List (foldl') import Data.Maybe (fromMaybe, isNothing, mapMaybe, maybeToList) import Data.Proxy import Data.String (IsString, fromString) import Data.String.Conversions (cs, (<>)) import Data.Tagged (Tagged(..), retag) import qualified Data.Text as T import Data.Text (Text) import Data.Typeable (Typeable) import GHC.Generics import GHC.TypeLits (KnownNat, KnownSymbol, natVal, symbolVal) import Network.HTTP.Types (HeaderName, Method, Status(..), parseQueryText, methodGet, methodHead, hContentType, hAccept) import qualified Network.HTTP.Media as NHM import Web.HttpApiData (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPieceMaybe, parseUrlPieces) import Snap.Core hiding (Headers, Method, getResponse, route, method, withRequest) import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture', CaptureAll, Description, FramingRender (..), EmptyAPI, Header', IsSecure(..), If, QueryFlag, IsSecure(..), QueryParam', QueryParams, Raw, RemoteHost, ReqBody', ReflectMethod(..), SBool(..), SBoolI, Stream, Summary, Verb, sbool ) import Servant.API.Stream (ToSourceIO(..)) import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..), AllMime(..), MimeRender (..), canHandleAcceptH, contentType) import Servant.API.Modifiers (FoldLenient, FoldRequired, RequestArgument, unfoldRequestArgument) import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders, getHeaders) import qualified Servant.Types.SourceT as S import qualified System.IO.Streams as IOS import Servant.Server.Internal.BasicAuth import Servant.Server.Internal.Context import Servant.Server.Internal.PathInfo import Servant.Server.Internal.Router import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr import Servant.Server.Internal.SnapShims class HasServer api context (m :: * -> *) where type ServerT api context m :: * route :: MonadSnap m => Proxy api -> Context context -> Delayed m env (Server api context m) -> Router m env hoistServerWithContext :: proxy api -> proxy' context -> (forall x. m x -> n x) -> ServerT api context m -> ServerT api context n type Server api context m = ServerT api context m -- * Instances -- | A server for @a ':<|>' b@ first tries to match the request against the route -- represented by @a@ and if it fails tries @b@. You must provide a request -- handler for each route. -- -- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books -- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books -- > -- > server :: Server MyApi -- > server = listAllBooks :<|> postBook -- > where listAllBooks = ... -- > postBook book = ... instance (HasServer a ctx m, HasServer b ctx m) => HasServer (a :<|> b) ctx m where type ServerT (a :<|> b) ctx m = ServerT a ctx m :<|> ServerT b ctx m route Proxy ctx server = choice (route pa ctx ((\ (a :<|> _) -> a) <$> server)) (route pb ctx ((\ (_ :<|> b) -> b) <$> server)) where pa = Proxy :: Proxy a pb = Proxy :: Proxy b hoistServerWithContext _ pc nt (a :<|> b) = hoistServerWithContext (Proxy :: Proxy a) pc nt a :<|> hoistServerWithContext (Proxy :: Proxy b) pc nt b captured :: FromHttpApiData a => proxy (Capture' mods sym a) -> Text -> Maybe a captured _ = parseUrlPieceMaybe -- | If you use 'Capture' 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 the 'Capture'. -- This lets servant worry about getting it from the URL and turning -- it into a value of the type you specify. -- -- You can control how it'll be converted from 'Text' to your type -- by simply providing an instance of 'FromHttpApiData' for your type. -- -- Example: -- -- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book -- > -- > server :: Server MyApi -- > server = getBook -- > where getBook :: Text -> EitherT ServantErr IO Book -- > getBook isbn = ... instance (FromHttpApiData a, HasServer api context m) => HasServer (Capture' mods capture a :> api) context m where type ServerT (Capture' mods capture a :> api) context m = a -> ServerT api context m hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy ctx d = CaptureRouter $ route (Proxy :: Proxy api) ctx (addCapture d $ \ txt -> case parseUrlPieceMaybe txt of Nothing -> delayedFail err400 Just v -> return v ) instance (FromHttpApiData a, HasServer api context m) => HasServer (CaptureAll capture a :> api) context m where type ServerT (CaptureAll capture a :> api) context m = [a] -> ServerT api context m hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy ctx d = CaptureAllRouter $ route (Proxy :: Proxy api) ctx (addCapture d $ \ txts -> case parseUrlPieces txts of Left _ -> delayedFail err400 Right v -> return v ) allowedMethodHead :: Method -> Request -> Bool allowedMethodHead method request = method == methodGet && unSnapMethod (rqMethod request) == methodHead allowedMethod :: Method -> Request -> Bool allowedMethod method request = allowedMethodHead method request || unSnapMethod (rqMethod request) == method processMethodRouter :: Maybe (BL.ByteString, BL.ByteString) -> Status -> Method -> Maybe [(HeaderName, B.ByteString)] -> Request -> RouteResult Response processMethodRouter handleA status method rHeaders request = case handleA of Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does Just (contentT, body) -> Route $ responseLBS status hdrs bdy where bdy = if allowedMethodHead method request then "" else body hdrs = (hContentType, cs contentT) : fromMaybe [] rHeaders methodCheck :: MonadSnap m => Method -> Request -> DelayedM m () methodCheck method request | allowedMethod method request = return () | otherwise = delayedFail err405 -- This has switched between using 'Fail' and 'FailFatal' a number of -- times. If the 'acceptCheck' is run after the body check (which would -- be morally right), then we have to set this to 'FailFatal', because -- the body check is not reversible, and therefore backtracking after the -- body check is no longer an option. However, we now run the accept -- check before the body check and can therefore afford to make it -- recoverable. acceptCheck :: (AllMime list, MonadSnap m) => Proxy list -> B.ByteString -> DelayedM m () acceptCheck proxy accH | canHandleAcceptH proxy (AcceptHeader accH) = return () | otherwise = delayedFail err406 methodRouter :: (AllCTRender ctypes a, MonadSnap m) => Method -> Proxy ctypes -> Status -> Delayed m env (m a) -> Router m env -- Request (RoutingApplication m) m methodRouter method proxy status action = leafRouter route' where route' env request respond = let accH = fromMaybe ct_wildcard $ getHeader hAccept request -- lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request `addAcceptCheck` acceptCheck proxy accH ) env request respond $ \ output -> do let handleA = handleAcceptH proxy (AcceptHeader accH) output processMethodRouter handleA status method Nothing request methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v, MonadSnap m) => Method -> Proxy ctypes -> Status -> Delayed m env (m (Headers h v)) -> Router m env -- Request (RoutingApplication m) m methodRouterHeaders method proxy status action = leafRouter route' where route' env request respond = let accH = fromMaybe ct_wildcard $ getHeader hAccept request -- lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request `addAcceptCheck` acceptCheck proxy accH ) env request respond $ \ output -> do let hdrs = getHeaders output handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output) processMethodRouter handleA status method (Just hdrs) request instance {-# OVERLAPPABLE #-} (AllCTRender ctypes a, ReflectMethod method, KnownNat status) => HasServer (Verb method status ctypes a) context m where type ServerT (Verb method status ctypes a) context m = m a hoistServerWithContext _ _ nt s = nt s route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method) status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) instance {-# OVERLAPPABLE #-} (AllCTRender ctypes a, ReflectMethod method, KnownNat status, GetHeaders (Headers h a)) => HasServer (Verb method status ctypes (Headers h a)) context m where type ServerT (Verb method status ctypes (Headers h a)) context m = m (Headers h a) hoistServerWithContext _ _ nt s = nt s route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method) status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) -- | 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'. -- This lets servant worry about extracting it from the request and turning -- it into a value of the type you specify. -- -- All it asks is for a 'FromHttpApiData' instance. -- -- Example: -- -- > newtype Referer = Referer Text -- > deriving (Eq, Show, FromText, ToText) -- > -- > -- GET /view-my-referer -- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer -- > -- > server :: Server MyApi -- > server = viewReferer -- > where viewReferer :: Referer -> EitherT ServantErr IO referer -- > viewReferer referer = return referer instance (KnownSymbol sym, FromHttpApiData a, HasServer api context m , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods) ) => HasServer (Header' mods sym a :> api) context m where type ServerT (Header' mods sym a :> api) context m = RequestArgument mods a -> ServerT api context m hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy ctx subserver = route (Proxy :: Proxy api) ctx $ subserver `addHeaderCheck` withRequest headerCheck where headerName :: IsString n => n headerName = fromString $ symbolVal (Proxy :: Proxy sym) headerCheck :: Request -> DelayedM m (RequestArgument mods a) headerCheck req = unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev where mev :: Maybe (Either Text a) mev = fmap parseHeader $ getHeader headerName req errReq = delayedFailFatal err400 { errBody = "Header " <> headerName <> " is required" } errSt e = delayedFailFatal err400 { errBody = cs $ "Error parsing header " <> headerName <> " failed: " <> e } -- | 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 -- that takes an argument of type @'Maybe' 'Text'@. -- -- This lets servant worry about looking it up in the query string -- and turning it into a value of the type you specify, enclosed -- in 'Maybe', because it may not be there and servant would then -- hand you 'Nothing'. -- -- You can control how it'll be converted from 'Text' to your type -- by simply providing an instance of 'FromHttpApiData' for your type. -- -- Example: -- -- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book] -- > -- > server :: Server MyApi -- > server = getBooksBy -- > where getBooksBy :: Maybe Text -> EitherT ServantErr IO [Book] -- > getBooksBy Nothing = ...return all books... -- > getBooksBy (Just author) = ...return books by the given author... instance (KnownSymbol sym, FromHttpApiData a, HasServer api context m , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods) ) => HasServer (QueryParam' mods sym a :> api) context m where type ServerT (QueryParam' mods sym a :> api) context m = RequestArgument mods a -> ServerT api context m hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy ctx subserver = let querytext r = parseQueryText $ rqQueryString r paramname = cs $ symbolVal (Proxy :: Proxy sym) parseParam :: Request -> DelayedM m (RequestArgument mods a) parseParam req = unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev where mev :: Maybe (Either T.Text a) mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req errReq = delayedFailFatal err400 { errBody = cs $ "Query parameter " <> paramname <> " is required" } errSt e = delayedFailFatal err400 { errBody = cs $ "Error parsing query parameter " <> paramname <> " failed: " <> e } delayed = addParameterCheck subserver . withRequest $ parseParam in route (Proxy :: Proxy api) ctx delayed -- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of type @['Text']@. -- -- This lets servant worry about looking up 0 or more values in the query string -- associated to @authors@ and turning each of them into a value of -- the type you specify. -- -- You can control how the individual values are converted from 'Text' to your type -- by simply providing an instance of 'FromHttpApiData' for your type. -- -- Example: -- -- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book] -- > -- > server :: Server MyApi -- > server = getBooksBy -- > where getBooksBy :: [Text] -> EitherT ServantErr IO [Book] -- > getBooksBy authors = ...return all books by these authors... instance (KnownSymbol sym, FromHttpApiData a, HasServer api context m) => HasServer (QueryParams sym a :> api) context m where type ServerT (QueryParams sym a :> api) context m = [a] -> ServerT api context m hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy ctx subserver = route (Proxy :: Proxy api) ctx $ subserver `addParameterCheck` withRequest paramsCheck where paramname = cs $ symbolVal (Proxy :: Proxy sym) paramsCheck req = case partitionEithers $ fmap parseQueryParam params of ([], parsed) -> return parsed (errs, _) -> delayedFailFatal err400 { errBody = cs $ "Error parsing query parameter(s) " <> paramname <> " failed: " <> T.intercalate ", " errs } where params :: [T.Text] params = mapMaybe snd . filter (looksLikeParam . fst) . parseQueryText . rqQueryString $ req looksLikeParam name = name == paramname || name == (paramname <> "[]") -- | If you use @'QueryFlag' "published"@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of type 'Bool'. -- -- Example: -- -- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book] -- > -- > server :: Server MyApi -- > server = getBooks -- > where getBooks :: Bool -> EitherT ServantErr IO [Book] -- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument... instance (KnownSymbol sym, HasServer api context m) => HasServer (QueryFlag sym :> api) context m where type ServerT (QueryFlag sym :> api) context m = Bool -> ServerT api context m hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context subserver = let querytext r = parseQueryText $ rqQueryString r param r = case lookup paramname (querytext r) of Just Nothing -> True -- param is there, with no value Just (Just v) -> examine v -- param with a value Nothing -> False -- param not in the query string in route (Proxy :: Proxy api) context (passToServer subserver param) where paramname = cs $ symbolVal (Proxy :: Proxy sym) examine v | v == "true" || v == "1" || v == "" = True | otherwise = False -- | Just pass the request to the underlying application and serve its response. -- -- Example: -- -- > type MyApi = "images" :> Raw -- > -- > server :: Server MyApi -- > server = serveDirectory "/var/www/images" instance HasServer Raw context m where type ServerT Raw context m = m () hoistServerWithContext _ _ nt = nt route Proxy _ rawApplication = RawRouter $ \ env request respond -> do r <- runDelayed rawApplication env request case r of Route app -> (snapToApplication' app) request (respond . Route) Fail a -> respond $ Fail a FailFatal e -> respond $ FailFatal e -- | If you use 'ReqBody' 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 'ReqBody'. -- The @Content-Type@ header is inspected, and the list provided is used to -- attempt deserialization. If the request does not have a @Content-Type@ -- header, it is treated as @application/octet-stream@ (as specified in -- . -- This lets servant worry about extracting it from the request and turning -- it into a value of the type you specify. -- -- -- All it asks is for a 'FromJSON' instance. -- -- Example: -- -- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- > -- > server :: Server MyApi -- > server = postBook -- > where postBook :: Book -> EitherT ServantErr IO Book -- > postBook book = ...insert into your db... instance ( AllCTUnrender list a, HasServer api context m, SBoolI (FoldLenient mods), MonadSnap m ) => HasServer (ReqBody' mods list a :> api) context m where type ServerT (ReqBody' mods list a :> api) context m = If (FoldLenient mods) (Either String a) a -> ServerT api context m hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context subserver = route (Proxy :: Proxy api) context $ addBodyCheck subserver ctCheck bodyCheck where -- Content-Type check, we only lookup we can try to parse the request body ctCheck = withRequest $ \ request -> do -- See HTTP RFC 2616, section 7.2.1 -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1 -- See also "W3C Internet Media Type registration, consistency of use" -- http://www.w3.org/2001/tag/2002/0129-mime let contentTypeH = fromMaybe "application/octet-stream" $ getHeader hContentType request case canHandleCTypeH (Proxy :: Proxy list) (cs contentTypeH) :: Maybe (BL.ByteString -> Either String a) of Nothing -> delayedFail err415 Just f -> return f -- Body check, we get a body parsing functions as the first argument. bodyCheck f = do mrqbody <- lift $ runRequestBody $ \ stream -> f <$> BL.fromChunks <$> IOS.toList {- IOS.toLazyByteString -} stream case sbool :: SBool (FoldLenient mods) of STrue -> return mrqbody SFalse -> case mrqbody of Left e -> delayedFailFatal err400 { errBody = cs e } Right v -> return v -- | Make sure the incoming request starts with @"/path"@, strip it and -- pass the rest of the request path to @api@. instance (KnownSymbol path, HasServer api context m) => HasServer (path :> api) context m where type ServerT (path :> api) context m = ServerT api context m route Proxy context subserver = pathRouter (cs (symbolVal proxyPath)) (route (Proxy :: Proxy api) context subserver) where proxyPath = Proxy :: Proxy path hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s instance HasServer api context m => HasServer (RemoteHost :> api) context m where type ServerT (RemoteHost :> api) context m = B.ByteString -> ServerT api context m route Proxy context subserver = route (Proxy :: Proxy api) context (passToServer subserver rqHostName) hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s instance HasServer api context m => HasServer (IsSecure :> api) context m where type ServerT (IsSecure :> api) context m = IsSecure -> ServerT api context m route Proxy context subserver = route (Proxy :: Proxy api) context (passToServer subserver (bool NotSecure Secure . rqIsSecure)) hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s -- This appears to be about 1000000% WAI-specific, so better hope you didn't need it -- instance HasServer api context m => HasServer (Vault :> api) context m where -- type ServerT (Vault :> api) context m = Vault -> ServerT api context m -- -- route Proxy context subserver = -- route (Proxy :: Proxy api) context (passToServer subserver vault) -- hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s instance HasServer api context m => HasServer (HttpVersion :> api) context m where type ServerT (HttpVersion :> api) context m = HttpVersion -> ServerT api context m route Proxy ctx subserver = route (Proxy :: Proxy api) ctx (passToServer subserver rqVersion) hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s -- | Ignore @'Summary'@ in server handlers. instance HasServer api ctx m => HasServer (Summary desc :> api) ctx m where type ServerT (Summary desc :> api) ctx m = ServerT api ctx m route _ = route (Proxy :: Proxy api) hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s -- | Ignore @'Description'@ in server handlers. instance HasServer api ctx m => HasServer (Description desc :> api) ctx m where type ServerT (Description desc :> api) ctx m = ServerT api ctx m route _ = route (Proxy :: Proxy api) hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s -- | Singleton type representing a server that serves an empty API. data EmptyServer = EmptyServer deriving (Typeable, Eq, Show, Bounded, Enum) -- | Server for `EmptyAPI` emptyServer :: ServerT EmptyAPI context m emptyServer = Tagged EmptyServer -- | The server for an `EmptyAPI` is `emptyAPIServer`. -- -- > type MyApi = "nothing" :> EmptyApi -- > -- > server :: Server MyApi -- > server = emptyAPIServer instance HasServer EmptyAPI context m where type ServerT EmptyAPI context m = Tagged m EmptyServer route Proxy _ _ = StaticRouter mempty mempty hoistServerWithContext _ _ _ = retag -- | Basic Authentication instance ( KnownSymbol realm , HasServer api context m , HasContextEntry context (BasicAuthCheck m usr) ) => HasServer (BasicAuth realm usr :> api) context m where type ServerT (BasicAuth realm usr :> api) context m = usr -> ServerT api context m route Proxy context subserver = route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck) where realm = B.pack $ symbolVal (Proxy :: Proxy realm) basicAuthContext = getContextEntry context authCheck = withRequest $ \ req -> runBasicAuth req realm basicAuthContext hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s -- newtype BasicAuthCheck m usr = -- BasicAuthCheck { unBasicAuthCheck :: BasicAuthData -> m (BasicAuthResult usr) } -- deriving (Functor, Generic) data BasicAuthResult usr = Unauthorized | BadPassword | NoSuchUser | Authorized usr deriving (Functor, Eq, Read, Show, Generic) -- * helpers -- ct_wildcard :: B.ByteString ct_wildcard = "*" <> "/" <> "*" -- Because CPP instance forall ctype chunk method status framing m context a. ( MimeRender ctype chunk, ReflectMethod method, KnownNat status, FramingRender framing, MonadSnap m, ToSourceIO chunk a ) => HasServer (Stream method status framing ctype a) context m where type ServerT (Stream method status framing ctype a) context m = m a hoistServerWithContext _ _ nt s = nt s route Proxy _ action = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype) action where method = reflectMethod (Proxy :: Proxy method) status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) instance ( MimeRender ctype chunk, ReflectMethod method, MimeRender ctype a, KnownNat status, MonadSnap m, FramingRender framing, ToSourceIO chunk a, GetHeaders (Headers h a) ) => HasServer (Stream method status framing ctype (Headers h a)) context m where type ServerT (Stream method status framing ctype (Headers h a)) context m = m (Headers h a) hoistServerWithContext _ _ nt s = nt s route Proxy _ action = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype) action where method = reflectMethod (Proxy :: Proxy method) status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) streamRouter :: forall ctype a c chunk env framing m .(MimeRender ctype chunk, FramingRender framing, -- ToSourceIO chunk (m a), ToSourceIO chunk a, MonadSnap m ) => (c -> ([(HeaderName, B.ByteString)], a)) -> Method -> Status -> Proxy framing -> Proxy ctype -> Delayed m env (m c) -> Router m env streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond -> let accH = fromMaybe ct_wildcard $ getHeader hAccept request cmediatype = NHM.matchAccept [contentType ctypeproxy] 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 $ \ output -> let (headers', fa) = splitHeaders output sourceT = toSourceIO fa S.SourceT kStepLBS = framingRender framingproxy (mimeRender ctypeproxy :: chunk -> BL.ByteString) sourceT response = setResponseStatus (statusCode status) (statusMessage status) $ setHeaders (contentHeader:headers') emptyResponse in Route $ flip setResponseBody response $ \outStream -> do let writeAndFlush bb = IOS.write (Just $ bb <> BB.flush) outStream justFlush = IOS.write (Just BB.flush) outStream loop :: S.StepT IO BL.ByteString -> IO (IOS.OutputStream BB.Builder) loop S.Stop = justFlush >> return outStream loop (S.Error err) = fail err -- TODO: Provide a better error message loop (S.Skip s) = loop s loop (S.Effect ms) = ms >>= loop loop (S.Yield lbs s) = do writeAndFlush (BB.lazyByteString lbs) loop s kStepLBS loop