diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +0.8.2 +------ + +Add `HasServer` instances for `StreamGenerator` + + 0.8.0.1 ------- diff --git a/example/greet.hs b/example/greet.hs --- a/example/greet.hs +++ b/example/greet.hs @@ -14,7 +14,7 @@ import Data.Text import GHC.Generics import qualified Heist.Interpreted as I -import Snap.Core +import Snap.Core hiding (GET) import Snap.CORS import Snap.Snaplet import Snap.Snaplet.Auth @@ -37,7 +37,7 @@ instance ToJSON Greet -- API specification -type TestApi m = +type TestApi m f = -- GET /hello/:name?capital={true, false} returns a Greet as JSON "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON] Greet @@ -52,6 +52,8 @@ -- DELETE /greet/:greetid :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] () + :<|> "stream" :> StreamGet NetstringFraming JSON (f Greet) + :<|> "files" :> Raw :<|> "doraw" :> Raw @@ -69,7 +71,7 @@ type AppHandler = Handler App App -testApi :: Proxy (TestApi AppHandler) +testApi :: Proxy (TestApi AppHandler StreamGenerator) testApi = Proxy @@ -80,11 +82,12 @@ -- -- Each handler runs in the 'AppHandler' monad. -server :: Server (TestApi AppHandler) '[] AppHandler +server :: Server (TestApi AppHandler StreamGenerator) '[] AppHandler server = helloH :<|> helloH' :<|> postGreetH :<|> deleteGreetH + :<|> doStream :<|> serveDirectory "static" :<|> doRaw @@ -103,6 +106,11 @@ postGreetH greet = return greet deleteGreetH _ = return () + + doStream = return $ StreamGenerator $ \sendFirst sendRest -> do + sendFirst (Greet "hi") + sendRest (Greet "tao") + sendRest (Greet "Howareya") doRaw = with auth $ do u <- currentUser diff --git a/servant-snap.cabal b/servant-snap.cabal --- a/servant-snap.cabal +++ b/servant-snap.cabal @@ -1,5 +1,5 @@ name: servant-snap -version: 0.8.1 +version: 0.8.2 synopsis: A family of combinators for defining webservices APIs and serving them description: Interpret a Servant API as a Snap server, using any Snaplets you like. @@ -51,20 +51,21 @@ , bytestring >= 0.10 && < 0.11 , case-insensitive >= 1.2 && < 1.3 , containers >= 0.5 && < 0.6 - , either >= 4.3 && < 4.5 + , either >= 4.3 && < 4.6 , filepath >= 1 && < 1.5 - , http-types >= 0.8 && < 0.10 + , http-media >= 0.7.1.2 && < 0.8 + , http-types >= 0.8 && < 0.13 , http-api-data >= 0.2 && < 0.4 - , io-streams >= 1.3 && < 1.5 + , io-streams >= 1.3 && < 1.6 , network-uri >= 2.6 && < 2.7 , mtl >= 2.0 && < 2.3 , mmorph >= 1 && < 1.2 - , servant >= 0.8 && < 0.13 + , servant >= 0.8 && < 0.14 , string-conversions >= 0.3 && < 0.5 , text >= 1.2 && < 1.3 - , snap >= 1.0 && < 1.1 - , snap-core >= 1.0 && < 1.1 - , snap-server >= 1.0 && < 1.1 + , snap >= 1.0 && < 1.2 + , snap-core >= 1.0.2 && < 1.2 + , snap-server >= 1.0 && < 1.2 , transformers >= 0.3 && < 0.6 , word8 >= 0.1 && < 0.2 hs-source-dirs: src @@ -83,8 +84,10 @@ , either , errors , heist + , http-client , lens , servant + , servant-client , servant-snap , snap-cors , map-syntax @@ -112,6 +115,7 @@ , either , exceptions , hspec >= 2.4.3 && < 2.5 + , io-streams , lens , process , digestive-functors >= 0.8.1.0 && < 0.9 diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -8,6 +8,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -27,10 +28,14 @@ ------------------------------------------------------------------------------- import Control.Applicative ((<$>)) import Control.Monad.Trans.Class (lift) +import Control.Monad (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.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (fromMaybe, isNothing, mapMaybe, + maybeToList) import Data.Proxy import Data.String (fromString) import Data.String.Conversions (cs, (<>)) @@ -42,6 +47,7 @@ Status(..), parseQueryText, methodGet, methodHead, hContentType, hAccept) +import qualified Network.HTTP.Media as NHM import Web.HttpApiData (FromHttpApiData, parseHeaderMaybe, parseQueryParamMaybe, @@ -51,18 +57,23 @@ getResponse, route, method, withRequest) import Servant.API ((:<|>) (..), (:>), BasicAuth, + BoundaryStrategy(..), Capture, - CaptureAll, Header, - IsSecure(..), QueryFlag, + CaptureAll, FramingRender (..), + Header, IsSecure(..), QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody, - ReflectMethod(..), Verb) + ReflectMethod(..), Stream, + ToStreamGenerator (..), Verb, + getStreamGenerator) import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), - AllCTUnrender (..), AllMime(..), canHandleAcceptH) + AllCTUnrender (..), AllMime(..), + MimeRender (..), + canHandleAcceptH, contentType) import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders, getHeaders) --- import Servant.Common.Text (FromText, fromText) +import qualified System.IO.Streams as IOS import Servant.Server.Internal.BasicAuth import Servant.Server.Internal.Context @@ -72,7 +83,7 @@ import Servant.Server.Internal.ServantErr import Servant.Server.Internal.SnapShims --- TODO: add MonadSnap m => m ? + class HasServer api context (m :: * -> *) where type ServerT api context m :: * @@ -501,3 +512,73 @@ ct_wildcard :: B.ByteString ct_wildcard = "*" <> "/" <> "*" -- Because CPP + +instance ( MimeRender ctype a, ReflectMethod method, MimeRender ctype a, -- ToStreamGenerator m (f a), + FramingRender framing ctype, ToStreamGenerator f a + ) => HasServer (Stream method framing ctype (f a)) context m where + type ServerT (Stream method framing ctype (f a)) context m = m (f a) + + route Proxy _ action = streamRouter ([],) method (Proxy) (Proxy :: Proxy framing) (Proxy :: Proxy ctype) action + where method = reflectMethod (Proxy :: Proxy method) + -- status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) + +instance ( MimeRender ctype a, ReflectMethod method, MimeRender ctype (f a), ToStreamGenerator m (f a), + FramingRender framing ctype, ToStreamGenerator f a, GetHeaders (Headers h (f a)) + ) => HasServer (Stream method framing ctype (Headers h (f a))) context m where + type ServerT (Stream method framing ctype (Headers h (f a))) context m = m (Headers h (f a)) + + route Proxy _ action = + streamRouter (\x -> (getHeaders x, getResponse x)) + method + Proxy + (Proxy :: Proxy framing) + (Proxy :: Proxy ctype) + action + where method = reflectMethod (Proxy :: Proxy method) + + +streamRouter :: (MimeRender ctype a, + FramingRender framing ctype, + ToStreamGenerator f a, + MonadSnap m + ) => + (b -> ([(HeaderName, B.ByteString)], f a)) + -> Method + -> Proxy m + -> Proxy framing + -> Proxy ctype + -> Delayed m env (m b) + -> Router m env +streamRouter splitHeaders method handlerProxy 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 + k = getStreamGenerator . toStreamGenerator $ fa in + Route $ flip setResponseBody emptyResponse $ \outStream -> do + let writeAndFlush bb = IOS.write (Just $ bb <> BB.flush) outStream + writeAndFlush (BB.lazyByteString $ header framingproxy ctypeproxy) + case boundary framingproxy ctypeproxy of + BoundaryStrategyBracket f -> + let go x = let bs = mimeRender ctypeproxy x + (before, after) = f bs + in writeAndFlush ( BB.lazyByteString before + <> BB.lazyByteString bs + <> BB.lazyByteString after) + in k go go + BoundaryStrategyIntersperse sep -> k + (\x -> do + writeAndFlush . BB.lazyByteString $ mimeRender ctypeproxy x + ) + (\x -> do + writeAndFlush . (BB.lazyByteString sep <>) . BB.lazyByteString $ mimeRender ctypeproxy x + ) + BoundaryStrategyGeneral f -> + let go = writeAndFlush . BB.lazyByteString . f . mimeRender ctypeproxy + in k go go + IOS.write (Just . BB.lazyByteString $ trailer framingproxy ctypeproxy) outStream + return outStream