add captureCombinator

servant-server/servant-server.cabal

@@ -45,6 +45,7 @@ library
   exposed-modules:
     Servant
     Servant.Server
+    Servant.Server.CombinatorUtils
     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.CombinatorUtilsSpec
       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

servant-server/src/Servant/Server/CombinatorUtils.hs

@@ -5,9 +5,11 @@
 module Servant.Server.CombinatorUtils (
   RouteResult(..),
   argumentCombinator,
+  captureCombinator,
 ) where
 
 import           Data.Proxy
+import           Data.Text
 import           Network.Wai
 
 import           Servant.API
@@ -24,5 +26,19 @@ argumentCombinator ::
   -> Delayed env (Server (combinator :> api))
   -> Router' env RoutingApplication
 argumentCombinator getArg Proxy context delayed =
-  route (Proxy :: Proxy api) context $ addBodyCheck delayed $
+  route (Proxy :: Proxy api) context $ addBodyCheck delayed
-  DelayedIO $ \ request -> return $ getArg request
+    (DelayedIO (return ())) $ \ () ->
+      withRequest $ \ request -> liftRouteResult (getArg request)
+
+captureCombinator ::
+  forall api combinator arg context env .
+  (HasServer api context) =>
+  (Text -> RouteResult arg)
+  -> Proxy (combinator :> api)
+  -> Context context
+  -> Delayed env (arg -> Server api)
+  -> Router' env RoutingApplication
+captureCombinator getArg Proxy context delayed =
+  CaptureRouter $
+  route (Proxy :: Proxy api) context $ addCapture delayed $ \ captured ->
+  (liftRouteResult (getArg captured))

servant-server/test/Servant/Server/CombinatorUtilsSpec.hs

@@ -8,12 +8,13 @@
 
 module Servant.Server.CombinatorUtilsSpec where
 
-import           Blaze.ByteString.Builder
 import           Control.Concurrent
+import           Data.ByteString.Builder
 import           Data.ByteString.Lazy
 import           Data.Monoid
 import           Data.Proxy
 import           Data.String.Conversions
+import           Data.Text
 import           Network.HTTP.Types
 import           Network.Wai
 import           Network.Wai.Internal
@@ -49,10 +50,10 @@ spec :: Spec
 spec = do
   it "allows to write a combinator by providing a function (Request -> a)" $ do
     let server = return
-        app = serve (Proxy :: Proxy (Custom :> Get' String)) server
+        app = serve (Proxy :: Proxy (FooHeader :> Get' String)) server
         request = defaultRequest{
           requestHeaders =
-            ("Custom", "foo") :
+            ("FooHeader", "foo") :
             requestHeaders defaultRequest
         }
     response <- runApp app request
@@ -60,23 +61,57 @@ spec = do
 
   it "allows to write a combinator the errors out" $ do
     let server = return
-        app = serve (Proxy :: Proxy (Custom :> Get' String)) server
+        app = serve (Proxy :: Proxy (FooHeader :> Get' String)) server
         request = defaultRequest
     response <- runApp app request
     responseStatus response `shouldBe` status400
 
-  it "allows to pick the phase of request consumption" $ 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 pick the request check phase" $ do
+    pending
+
+  it "allows to write streaming combinators for request bodies" $ do
+    pending
+
+  it "disallows to access the request body unless in the checkBody phase" $ do
+    pending
+
+  it "allows to access the context" $ do
+    pending
+
+  it "allows to write combinators without args" $ do
+    pending
+
+  it "allows to implement combinators based in terms of existing combinators" $ do
     pending
 
 type Get' = Get '[JSON]
 
-data Custom
+data FooHeader
 
-instance HasServer api context => HasServer (Custom :> api) context where
+instance HasServer api context => HasServer (FooHeader :> api) context where
-  type ServerT (Custom :> api) m = String -> ServerT api m
+  type ServerT (FooHeader :> api) m = String -> ServerT api m
   route = argumentCombinator getCustom
 
 getCustom :: Request -> RouteResult String
-getCustom request = case lookup "Custom" (requestHeaders request) of
+getCustom request = case lookup "FooHeader" (requestHeaders request) of
   Nothing -> FailFatal err400
   Just l -> Route $ cs l
+
+data StringCapture
+
+instance HasServer api context => HasServer (StringCapture :> api) context where
+  type ServerT (StringCapture :> api) m = String -> ServerT api m
+  route = captureCombinator getCapture
+
+getCapture :: Text -> RouteResult String
+getCapture = Route . cs