diff --git a/src/Thrift/Transport/Wai.hs b/src/Thrift/Transport/Wai.hs --- a/src/Thrift/Transport/Wai.hs +++ b/src/Thrift/Transport/Wai.hs @@ -12,11 +12,15 @@ -} module Thrift.Transport.Wai ( + -- * Request Transport RequestTransport, - StreamTransport, fromRequest, + -- * Stream Transport for response + StreamTransport, toStreamTransport, - thriftWaiApp, + -- * Wai compatible application and middleware + thriftStreamingBody, + thriftApp, thriftMiddleware ) where @@ -31,9 +35,12 @@ import Network.HTTP.Types (status200) import Network.HTTP.Types.Method +-- | Transport layer based on 'Request' +-- This is a readonly transport layer. Write operations will fail. data RequestTransport = RequestTransport Request ReadBuffer -- | Creates RequestTransport from WAI request +-- Initilizes RequestTransport with a lazy request body from request fromRequest :: Request -> IO RequestTransport fromRequest req = RequestTransport <$> return req @@ -54,35 +61,18 @@ tFlush _ = fail "RequestTransport does not support flush" -type WriteBuilder = IORef Builder - -newtype ResponseTransport = ResponseTransport WriteBuilder - -newResponseTransport :: IO ResponseTransport -newResponseTransport = ResponseTransport <$> (newIORef mempty) - -instance Transport ResponseTransport where - - tIsOpen = const $ return False - - tClose = const $ return () - - tRead _ _ = fail "Read operation is not supported for response" - - tPeek _ = fail "Peek is not allowed for response buffers" - - tWrite (ResponseTransport b) bs = modifyIORef b (<> fromLazyByteString bs) - - tFlush (ResponseTransport b) = modifyIORef b (<> flush) - - - -data StreamTransport = StreamTransport { writer :: Builder -> IO () - , flusher :: IO () +-- | StreamTransport is write-only transport layer for thrift 'Transport' +data StreamTransport = StreamTransport { writer :: Builder -> IO () -- ^ to append response to the builder + , flusher :: IO () -- ^ to flush the response to IO } -toStreamTransport :: (Builder -> IO () ) -> IO () -> StreamTransport -toStreamTransport w f = StreamTransport w f +-- | Create 'StreamTransport' from two parts, builder creating the chunk +-- and flush, to flush the chunk to response stream. This is very similar +-- to 'StreamingBody' +toStreamTransport :: (Builder -> IO () ) -- ^ Builder for building the chunks + -> IO () -- ^ Flush the content to the response stream + -> StreamTransport -- ^ 'StreamTransport' for Wai +toStreamTransport = StreamTransport instance Transport StreamTransport where @@ -97,43 +87,71 @@ tWrite st bs = writer st $ fromLazyByteString bs - tFlush st = flusher st - + tFlush = flusher -thriftWaiApp :: +-- | Creates a streaming body that processes the request, and responds by +-- calling thrift handler. It uses 'RequestTransport' for processing the thrift +-- input, and 'StreamTransport' for responding through 'StreamingBody' +-- +-- This is a very useful function, and is in fact used implement 'thriftWaiApp' +-- and 'thriftMiddleware' +-- +-- For example one can use 'thriftStreamingBody' with scotty as +-- +-- > +-- > import qualified Greeting as G -- Thrift generated code +-- > +-- > thriftStream :: ActionM () +-- > thriftStream = do +-- > req <- request +-- > stream $ thriftStreamingBody G.GreetData JSONProtocol JSONProtocol G.process +-- > +thriftStreamingBody :: (Protocol ip, Protocol op) - => h - -> (RequestTransport -> ip RequestTransport) - -> (StreamTransport -> op StreamTransport) - -> (h -> (ip RequestTransport, op StreamTransport) -> IO Bool) - -> Application -thriftWaiApp h isp osp proc_ req responder = do + => h -- ^ Type supporting thrift generated interface + -> (RequestTransport -> ip RequestTransport) -- ^ Input protocol selector for 'RequestTransport' + -> (StreamTransport -> op StreamTransport) -- ^ Output protocol selector for 'StreamTransport' + -> (h -> (ip RequestTransport, op StreamTransport) -> IO Bool) -- ^ Thrift request handler + -> Request -- ^ Wai request, to be embedded in 'RequestTransport' + -> StreamingBody -- ^ Wai 'StreamingBody' +thriftStreamingBody h isp osp proc_ req write flushstream = do inp <- isp <$> fromRequest req - responder $ Wai.responseStream status200 [] $ \write flushstream -> do - let out = osp (StreamTransport write flushstream) - _ <- proc_ h (inp, out) - return () + let out = osp (StreamTransport write flushstream) + _ <- proc_ h (inp, out) + return () + + + +-- | Wai compatible application. +-- This does not add the necessary headers. +-- This does not add necessary headers for allowing cross origin requests +thriftApp :: + (Protocol ip, Protocol op) + => h -- ^ Type supporting thrift generated interface + -> (RequestTransport -> ip RequestTransport) -- ^ Input protocol selector for 'RequestTransport' + -> (StreamTransport -> op StreamTransport) -- ^ Output protocol selector for 'StreamTransport' + -> (h -> (ip RequestTransport, op StreamTransport) -> IO Bool) -- ^ Thrift request handler + -> Application -- ^ Wai application +thriftApp h isp osp proc_ req responder = + responder $ Wai.responseStream status200 [] $ thriftStreamingBody h isp osp proc_ req -- | Creates Wai middleware for the given handler +-- This does not add necessary headers for allowing cross origin requests thriftMiddleware :: (Protocol ip, Protocol op) - => h - -> (RequestTransport -> ip RequestTransport) - -> (StreamTransport -> op StreamTransport) - -> (h -> (ip RequestTransport, op StreamTransport) -> IO Bool) - -> Application - -> Application + => h -- ^ Type supporting thrift generated interface + -> (RequestTransport -> ip RequestTransport) -- ^ Input protocol selector for 'RequestTransport' + -> (StreamTransport -> op StreamTransport) -- ^ Output protocol selector for 'StreamTransport' + -> (h -> (ip RequestTransport, op StreamTransport) -> IO Bool) -- ^ Thrift request handler + -> Middleware -- ^ Wai middleware thriftMiddleware h isp osp proc_ app req responder = app req $ \res -> case res of ResponseStream {} -> if methodPost == requestMethod req then - do - inp <- isp <$> fromRequest req - responder $ Wai.responseStream status200 (responseHeaders res) $ \write flushstream -> do - let out = osp (StreamTransport write flushstream) - _ <- proc_ h (inp, out) - return () + responder + $ Wai.responseStream status200 (responseHeaders res) + $ thriftStreamingBody h isp osp proc_ req else responder res diff --git a/wai-thrift.cabal b/wai-thrift.cabal --- a/wai-thrift.cabal +++ b/wai-thrift.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: wai-thrift -version: 0.0.1.1 +version: 0.0.1.2 synopsis: Thrift transport layer for Wai description: Implements a read-only transport layer for Wai Request, and write-only transport layer for Wai @@ -29,12 +29,11 @@ -- other-modules: -- other-extensions: build-depends: base >=4.8 && <4.9 - , thrift - , wai - , bytestring - , stm - , blaze-builder - , http-types + , thrift == 0.9.3 + , wai >= 3.0 + , bytestring >= 0.10 + , blaze-builder >= 0.4 + , http-types >= 0.8 hs-source-dirs: src default-language: Haskell2010