wip

.travis.yml

@@ -14,6 +14,7 @@ branches:
   only:
     - master
     - release-0.12
+    - release-0.13
 
 cache:
   directories:

cabal.make-travis-yml

@@ -1,5 +1,5 @@
 folds: all-but-test
-branches: master release-0.12
+branches: master release-0.12 release-0.13
 
 -- We have inplace packages (servant-js) so we skip installing dependencies in a separate step
 install-dependencies-step: False

servant-server/servant-server.cabal

@@ -45,6 +45,7 @@ library
   exposed-modules:
     Servant
     Servant.Server
+    Servant.Server.Utils.CustomCombinators
     Servant.Server.Experimental.Auth
     Servant.Server.Internal
     Servant.Server.Internal.BasicAuth
@@ -132,10 +133,12 @@ test-suite spec
   main-is: Spec.hs
   other-modules:
       Servant.ArbitraryMonadServerSpec
+      Servant.Server.Utils.CustomCombinatorsSpec
       Servant.Server.ErrorSpec
       Servant.Server.Internal.ContextSpec
       Servant.Server.Internal.RoutingApplicationSpec
       Servant.Server.RouterSpec
+      Servant.ServerSpec
       Servant.Server.StreamingSpec
       Servant.Server.UsingContextSpec
       Servant.Server.UsingContextSpec.TestCombinators
@@ -149,11 +152,13 @@ test-suite spec
     , base-compat
     , aeson
     , base64-bytestring
+    , blaze-builder
     , bytestring
+    , deepseq
+    , directory
     , exceptions
     , http-types
     , mtl
-    , network
     , resourcet
     , safe
     , servant

servant-server/src/Servant/Server/Internal/RoutingApplication.hs

@@ -28,7 +28,7 @@ type RoutingApplication =
      Request -- ^ the request, the field 'pathInfo' may be modified by url routing
   -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
 
--- | The result of matching against a path in the route tree.
+-- | The result of running an endpoint handler. On success this will contains an @a@.
 data RouteResult a =
     Fail ServantErr           -- ^ Keep trying other paths. The @ServantErr@
                               -- should only be 404, 405 or 406.

servant-server/src/Servant/Server/Utils/CustomCombinators.hs

@@ -0,0 +1,217 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+-- fixme: document RouteResult better
+-- fixme: document phases
+-- fixme: document that the req body can only be consumed once
+-- fixme: document dependency problem
+
+-- | This module provides convenience functions that make it easy to write
+-- 'HasServer' instances for your own custom servant combinators.
+--
+-- It is also intended to be a more stable interface for writing
+-- combinators than 'Servant.Server.Internal' and its submodules.
+--
+-- For examples on how to write combinators see 'makeCaptureCombinator' and friends.
+
+module Servant.Server.Utils.CustomCombinators (
+
+  -- * ServerCombinator
+
+  ServerCombinator,
+  runServerCombinator,
+
+  -- * Constructing ServerCombinators
+
+  makeCaptureCombinator,
+  makeRequestCheckCombinator,
+  makeAuthCombinator,
+  makeCombinator,
+
+  -- * Re-exports
+
+  RouteResult(..),
+) where
+
+import           Control.Monad.IO.Class
+import           Control.Exception (throwIO, ErrorCall(..))
+import           Data.Proxy
+import           Data.Text
+import           Network.Wai
+
+import           Servant.API
+import           Servant.Server
+import           Servant.Server.Internal
+
+-- | 'ServerCombinator' is a type to encapsulate the implementations
+-- of the 'route' method of the 'HasServer' class of your custom combinators.
+-- You can create a 'ServerCombinator' using one of the 'make...' functions below.
+--
+-- Type parameters:
+--
+-- - @combinator@ -- Your custom combinator type, usually an uninhabited dummy type.
+-- - @context@ -- The context your combinator (and all other combinators) have access to.
+--   In most cases this can be ignored. For further information, see
+--   'Servant.Server.Internal.Context'.
+-- - @api@ -- The subapi to be used in @serverType@.
+-- - @serverType@ -- The type of the server that implements an api containing your combinator.
+--   This should contain a call to 'ServerT' applied to @api@ -- the other type parameter -- and
+--   'Handler'. If your combinator for example supplies an 'Int' to endpoint handlers,
+--   @serverType@ would be @'Int' -> 'ServerT' api 'Handler'@.
+data ServerCombinator combinator api context serverType where
+  CI :: (forall env .
+    Proxy (combinator :> api)
+    -> Context context
+    -> Delayed env serverType
+    -> Router' env RoutingApplication)
+    -> ServerCombinator combinator api context serverType
+
+-- | 'runServerCombinator' is used to actually implement the method 'route' from the type class
+-- 'HasServer'. You can ignore most of the type of this function. All you need to do is to supply
+-- a 'ServerCombinator'.
+runServerCombinator :: ServerCombinator combinator api context serverType
+  -> Proxy (combinator :> api)
+  -> Context context
+  -> Delayed env serverType
+  -> Router' env RoutingApplication
+runServerCombinator (CI i) = i
+
+-- | 'makeCaptureCombinator' allows you to write a combinator that inspects a path snippet
+-- and provides an additional argument to endpoint handlers. You can choose the type of
+-- that argument.
+--
+-- Here's an example of a combinator 'MyCaptureCombinator' that tries to parse a path snippet as
+-- an 'Int' and provides that 'Int' as an argument to the endpoint handler. Note that in case the
+-- path snippet cannot be parsed as an 'Int' the combinator errors out (using 'Fail'), which means
+-- the endpoint handler will not be called.
+--
+-- >>> :set -XTypeFamilies
+-- >>> :set -XTypeOperators
+-- >>> :set -XFlexibleInstances
+-- >>> :set -XMultiParamTypeClasses
+-- >>> :set -Wno-missing-methods
+-- >>> import Text.Read
+-- >>> import Data.String.Conversions
+-- >>> :{
+--   data MyCaptureCombinator
+--   instance HasServer api context => HasServer (MyCaptureCombinator :> api) context where
+--     type ServerT (MyCaptureCombinator :> api) m = Int -> ServerT api m
+--     route = runServerCombinator $ makeCaptureCombinator getCaptureString
+--   getCaptureString :: Context context -> Text -> IO (RouteResult Int)
+--   getCaptureString _context pathSnippet = return $ case readMaybe (cs pathSnippet) of
+--     Just n -> Route n
+--     Nothing -> Fail err404
+-- :}
+makeCaptureCombinator ::
+  (HasServer api context) =>
+  (Context context -> Text -> IO (RouteResult arg))
+  -> ServerCombinator combinator api context (arg -> ServerT api Handler)
+makeCaptureCombinator = inner -- we use 'inner' to avoid having 'forall' show up in haddock docs
+  where
+    inner ::
+      forall api combinator arg context .
+      (HasServer api context) =>
+      (Context context -> Text -> IO (RouteResult arg))
+      -> ServerCombinator combinator api context (arg -> ServerT api Handler)
+    inner getArg = CI $ \ Proxy context delayed ->
+      CaptureRouter $
+      route (Proxy :: Proxy api) context $ addCapture delayed $ \ captured ->
+      (liftRouteResult =<< liftIO (getArg context captured))
+
+-- | 'makeRequestCheckCombinator' allows you to a combinator that checks a property of the
+-- 'Request', while not providing any additional argument to your endpoint handlers.
+--
+-- Combinators created with 'makeRequestCheckCombinator' are *not* allowed to access the
+-- request body (see 'makeCombinator').
+--
+-- This example shows a combinator 'BlockNonSSL' that disallows requests through @http@ and
+-- only allows @https@. Note that -- in case of @http@ -- it uses 'FailFatal' to prevent
+-- servant from trying out any remaining endpoints.
+--
+-- >>> :{
+--   data BlockNonSSL
+--   instance HasServer api context => HasServer (BlockNonSSL :> api) context where
+--     type ServerT (BlockNonSSL :> api) m = ServerT api m
+--     route = runServerCombinator $ makeRequestCheckCombinator checkRequest
+--   checkRequest :: Context context -> Request -> IO (RouteResult ())
+--   checkRequest _context request = return $ if isSecure request
+--     then Route ()
+--     else FailFatal err400
+-- :}
+makeRequestCheckCombinator ::
+  (HasServer api context) =>
+  (Context context -> Request -> IO (RouteResult ()))
+  -> ServerCombinator combinator api context (ServerT api Handler)
+makeRequestCheckCombinator = inner
+  where
+    inner ::
+      forall api combinator context .
+      (HasServer api context) =>
+      (Context context -> Request -> IO (RouteResult ()))
+      -> ServerCombinator combinator api context (ServerT api Handler)
+    inner check = CI $ \ Proxy context delayed ->
+      route (Proxy :: Proxy api) context $ addMethodCheck delayed $
+      withRequest $ \ request ->
+        liftRouteResult =<< liftIO (check context (protectBody "makeRequestCheckCombinator" request))
+
+-- | 'makeAuthCombinator' allows you to write combinators for authorization.
+--
+-- Combinators created with this function are *not* allowed to access the request body
+-- (see 'makeCombinator').
+makeAuthCombinator ::
+  (HasServer api context) =>
+  (Context context -> Request -> IO (RouteResult authInformation))
+  -> ServerCombinator combinator api context (authInformation -> ServerT api Handler)
+makeAuthCombinator = inner
+  where
+    inner ::
+      forall api combinator authInformation context .
+      (HasServer api context) =>
+      (Context context -> Request -> IO (RouteResult authInformation))
+      -> ServerCombinator combinator api context (authInformation -> ServerT api Handler)
+    inner authCheck = CI $ \ Proxy context delayed ->
+      route (Proxy :: Proxy api) context $ addAuthCheck delayed $
+      withRequest $ \ request ->
+        liftRouteResult =<< liftIO (authCheck context (protectBody "makeAuthCombinator" request))
+
+-- | 'makeCombinator' allows you to write combinators that have access to the whole request
+-- (including the request body) while providing an additional argument to the endpoint handler.
+-- This includes writing combinators that allow you to stream the request body. Here's a simple
+-- example for that using a very simple stream implementation @Source@:
+--
+-- >>> import Data.ByteString
+-- >>> :{
+--   data Source = Source (IO ByteString)
+--   data Stream
+--   instance HasServer api context => HasServer (Stream :> api) context where
+--     type ServerT (Stream :> api) m = Source -> ServerT api m
+--     route = runServerCombinator $ makeCombinator requestToSource
+--   requestToSource :: Context context -> Request -> IO (RouteResult Source)
+--   requestToSource _context request =
+--     return $ Route $ Source $ requestBody request
+-- :}
+makeCombinator ::
+  (HasServer api context) =>
+  (Context context -> Request -> IO (RouteResult arg))
+  -> ServerCombinator combinator api context (arg -> ServerT api Handler)
+makeCombinator = inner
+  where
+    inner ::
+      forall api combinator arg context .
+      (HasServer api context) =>
+      (Context context -> Request -> IO (RouteResult arg))
+      -> ServerCombinator combinator api context (arg -> ServerT api Handler)
+    inner getArg = CI $ \ Proxy context delayed ->
+      route (Proxy :: Proxy api) context $ addBodyCheck delayed
+      (return ())
+      (\ () -> withRequest $ \ request ->
+        liftRouteResult =<< liftIO (getArg context request))
+
+protectBody :: String -> Request -> Request
+protectBody name request = request{
+  requestBody = throwIO $ ErrorCall $
+    "ERROR: " ++ name ++ ": combinator must not access the request body"
+}

servant-server/test/Servant/Server/Utils/CustomCombinatorsSpec.hs

@@ -0,0 +1,301 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Servant.Server.Utils.CustomCombinatorsSpec where
+
+import           Control.Concurrent
+import           Data.ByteString.Builder
+import           Control.DeepSeq
+import           Control.Monad.IO.Class
+import           Data.ByteString as SBS hiding (map)
+import           Data.ByteString.Lazy as LBS hiding (map)
+import           Data.Monoid
+import           Data.Proxy
+import           Data.String.Conversions
+import           Data.Text hiding (map)
+import           Network.HTTP.Types
+import           Network.Wai
+import           Network.Wai.Internal
+import           Test.Hspec hiding (context)
+
+import           Servant.API
+import           Servant.Server
+import           Servant.Server.Utils.CustomCombinators
+
+runApp :: Application -> Request -> IO Response
+runApp app req = do
+  mvar <- newMVar Nothing
+  ResponseReceived <- app req $ \ response -> do
+    modifyMVar mvar $ \ Nothing ->
+      return $ (Just response, ResponseReceived)
+  modifyMVar mvar $ \mResponse -> do
+    case mResponse of
+      Nothing -> error "shouldn't happen"
+      Just response -> return (Just response, response)
+
+responseBodyLbs :: Response -> IO LBS.ByteString
+responseBodyLbs response = do
+  let (_, _, action) = responseToStream response
+  action $ \ streamingBody -> do
+    mvar <- newMVar ""
+    streamingBody
+      (\ builder -> modifyMVar_ mvar $ \ acc ->
+        return $ acc <> toLazyByteString builder)
+      (return ())
+    readMVar mvar
+
+spec :: Spec
+spec = do
+  describe "makeCaptureCombinator" $ do
+    it "allows to write capture combinators" $ do
+      let server = return
+          app = serve (Proxy :: Proxy (StringCapture :> Get' String)) server
+          request = defaultRequest{
+            rawPathInfo = "/foo",
+            pathInfo = ["foo"]
+          }
+      response <- runApp app request
+      responseBodyLbs response `shouldReturn` "\"foo\""
+
+    it "allows to write a combinator that errors out" $ do
+      let server = return
+          app = serve (Proxy :: Proxy (StringCapture :> Get' String)) server
+          request = defaultRequest {
+            rawPathInfo = "/error",
+            pathInfo = ["error"]
+          }
+      response <- runApp app request
+      responseStatus response `shouldBe` status418
+
+  describe "makeRequestCheckCombinator" $ do
+    it "allows to write request check combinators" $ do
+      let server = return ()
+          app = serve (Proxy :: Proxy (CheckFooHeader :> Get' ())) server
+          request = defaultRequest{
+            requestHeaders =
+              ("Foo", "foo") :
+              requestHeaders defaultRequest
+          }
+      response <- runApp app request
+      responseBodyLbs response `shouldReturn` "[]"
+
+    it "disallows to access the request body" $ do
+      let server = return ()
+          app = serve (Proxy :: Proxy (InvalidRequestCheckCombinator :> Get' ())) server
+          request = defaultRequest
+      runApp app request `shouldThrow`
+        errorCall "ERROR: makeRequestCheckCombinator: combinator must not access the request body"
+
+  describe "makeAuthCombinator" $ do
+    it "allows to write an auth combinator" $ do
+      let server (User name) = return name
+          app = serve (Proxy :: Proxy (AuthCombinator :> Get' String)) server
+          request = defaultRequest{
+            requestHeaders =
+              ("Auth", "secret") :
+              requestHeaders defaultRequest
+          }
+      response <- runApp app request
+      responseStatus response `shouldBe` ok200
+      responseBodyLbs response `shouldReturn` "\"Alice\""
+
+    it "disallows to access the request body" $ do
+      let server _user = return "foo"
+          app = serve (Proxy :: Proxy (InvalidAuthCombinator :> Get' String)) server
+          request = defaultRequest
+      runApp app request `shouldThrow`
+        errorCall "ERROR: makeAuthCombinator: combinator must not access the request body"
+
+    it "allows to access the context" $ do
+      let server (User name) = return name
+          context :: Context '[ [(SBS.ByteString, User)] ]
+          context = [("secret", User "Bob")] :. EmptyContext
+          app = serveWithContext (Proxy :: Proxy (AuthWithContext :> Get' String)) context server
+          request = defaultRequest{
+            requestHeaders =
+              ("Auth", "secret") :
+              requestHeaders defaultRequest
+          }
+      response <- runApp app request
+      responseStatus response `shouldBe` ok200
+      responseBodyLbs response `shouldReturn` "\"Bob\""
+
+  describe "makeCombinator" $ do
+    it "allows to write a combinator by providing a function (Request -> a)" $ do
+      let server = return
+          app = serve (Proxy :: Proxy (FooHeader :> Get' String)) server
+          request = defaultRequest{
+            requestHeaders =
+              ("Foo", "foo") :
+              requestHeaders defaultRequest
+          }
+      response <- runApp app request
+      responseBodyLbs response `shouldReturn` "\"foo\""
+
+  describe "makeReqBodyCombinator" $ do
+    let toBody :: [IO SBS.ByteString] -> IO (IO SBS.ByteString)
+        toBody list = do
+          mvar <- newMVar list
+          return $ do
+            modifyMVar mvar $ \case
+              (a : r) -> do
+                chunk <- a
+                return (r, chunk)
+              [] -> return ([], "")
+
+    it "allows to write combinators" $ do
+      body <- toBody $ map return ["foo", "bar"]
+      let server (Source b) = liftIO $ cs <$> fromBody b
+          app = serve (Proxy :: Proxy (StreamRequest :> Get' String)) server
+          request = defaultRequest{
+            requestBody = body
+          }
+      response <- runApp app request
+      responseBodyLbs response `shouldReturn` "\"foobar\""
+
+    it "allows to stream lazily" $ do
+      mvar <- newEmptyMVar
+      body <- toBody [return "foo", takeMVar mvar >> return "bar"]
+      let server (Source b) = liftIO $ do
+            first <- b
+            deepseq first (return ())
+            putMVar mvar ()
+            cs <$> (first <>) <$> fromBody b
+          app = serve (Proxy :: Proxy (StreamRequest :> Get' String)) server
+          request = defaultRequest{
+            requestBody = body
+          }
+      response <- runApp app request
+      responseBodyLbs response `shouldReturn` "\"foobar\""
+
+  it "allows to implement combinators in terms of existing combinators" $ do
+    pending
+
+type Get' = Get '[JSON]
+
+-- * capture combinators
+
+data StringCapture
+
+instance HasServer api context => HasServer (StringCapture :> api) context where
+  type ServerT (StringCapture :> api) m = String -> ServerT api m
+  route = runServerCombinator $ makeCaptureCombinator (const getCapture)
+
+getCapture :: Text -> IO (RouteResult String)
+getCapture snippet = return $ case snippet of
+  "error" -> FailFatal $ ServantErr 418 "I'm a teapot" "" []
+  text -> Route $ cs text
+
+-- * request check combinators
+
+data CheckFooHeader
+
+instance HasServer api context => HasServer (CheckFooHeader :> api) context where
+  type ServerT (CheckFooHeader :> api) m = ServerT api m
+  route = runServerCombinator $ makeRequestCheckCombinator (const checkFooHeader)
+
+checkFooHeader :: Request -> IO (RouteResult ())
+checkFooHeader request = return $
+  case lookup "Foo" (requestHeaders request) of
+    Just _ -> Route ()
+    Nothing -> FailFatal err400
+
+-- | a combinator that tries to access the request body in an invalid way
+data InvalidRequestCheckCombinator
+
+instance HasServer api context => HasServer (InvalidRequestCheckCombinator :> api) context where
+  type ServerT (InvalidRequestCheckCombinator :> api) m = ServerT api m
+  route = runServerCombinator $ makeRequestCheckCombinator (const accessReqBody)
+
+accessReqBody :: Request -> IO (RouteResult ())
+accessReqBody request = do
+  body <- fromBody $ requestBody request
+  deepseq body (return $ Route ())
+
+-- * auth combinators
+
+data AuthCombinator
+
+data User = User String
+  deriving (Eq, Show)
+
+instance HasServer api context => HasServer (AuthCombinator :> api) context where
+  type ServerT (AuthCombinator :> api) m = User -> ServerT api m
+  route = runServerCombinator $ makeAuthCombinator (const checkAuth)
+
+checkAuth :: Request -> IO (RouteResult User)
+checkAuth request = return $ case lookup "Auth" (requestHeaders request) of
+  Just "secret" -> Route $ User "Alice"
+  Just _ -> FailFatal err401
+  Nothing -> FailFatal err400
+
+-- | a combinator that tries to access the request body in an invalid way
+data InvalidAuthCombinator
+
+instance HasServer api context => HasServer (InvalidAuthCombinator :> api) context where
+  type ServerT (InvalidAuthCombinator :> api) m = User -> ServerT api m
+  route = runServerCombinator $ makeAuthCombinator (const authWithReqBody)
+
+authWithReqBody :: Request -> IO (RouteResult User)
+authWithReqBody request = do
+  body <- fromBody $ requestBody request
+  deepseq body (return $ Route $ User $ cs body)
+
+data AuthWithContext
+
+instance (HasContextEntry context [(SBS.ByteString, User)], HasServer api context) =>
+  HasServer (AuthWithContext :> api) context where
+  type ServerT (AuthWithContext :> api) m = User -> ServerT api m
+  route = runServerCombinator $ makeAuthCombinator authWithContext
+
+authWithContext :: (HasContextEntry context [(SBS.ByteString, User)]) =>
+  Context context -> Request -> IO (RouteResult User)
+authWithContext context request = return $ case lookup "Auth" (requestHeaders request) of
+  Nothing -> FailFatal err401
+  Just authToken -> case lookup authToken userDict of
+    Nothing -> FailFatal err403
+    Just user -> Route user
+  where
+    userDict = getContextEntry context
+
+-- * general combinators
+
+data FooHeader
+
+instance HasServer api context => HasServer (FooHeader :> api) context where
+  type ServerT (FooHeader :> api) m = String -> ServerT api m
+  route = runServerCombinator $ makeCombinator $ const $ getCustom
+
+getCustom :: Request -> IO (RouteResult String)
+getCustom request = return $ case lookup "Foo" (requestHeaders request) of
+  Nothing -> FailFatal err400
+  Just l -> Route $ cs l
+
+-- * streaming combinators
+
+data StreamRequest
+
+data Source = Source (IO SBS.ByteString)
+
+instance HasServer api context => HasServer (StreamRequest :> api) context where
+  type ServerT (StreamRequest :> api) m = Source -> ServerT api m
+  route = runServerCombinator $ makeCombinator $
+    \ _context request -> return $ Route $ Source $ requestBody request
+
+-- * utils
+
+fromBody :: IO SBS.ByteString -> IO SBS.ByteString
+fromBody getChunk = do
+  chunk <- getChunk
+  if chunk == ""
+    then return ""
+    else do
+      rest <- fromBody getChunk
+      return $ chunk <> rest