servant-snap 0.8.1 → 0.8.2

raw patch · 4 files changed

+118/−19 lines, 4 filesdep +http-clientdep +http-mediadep +servant-clientdep ~eitherdep ~http-typesdep ~io-streamsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: http-client, http-media, servant-client

Dependency ranges changed: either, http-types, io-streams, servant, snap, snap-core, snap-server

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• example/greet.hs +12/−4
• servant-snap.cabal +12/−8
• src/Servant/Server/Internal.hs +88/−7

@@ -1,3 +1,9 @@+0.8.2+------++Add `HasServer` instances for `StreamGenerator`++ 0.8.0.1 ------- 

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

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

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