servant-server support for CaptureAll

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

@@ -45,13 +45,15 @@ import           Prelude.Compat
 import           Web.HttpApiData            (FromHttpApiData)
 import           Web.HttpApiData.Internal   (parseHeaderMaybe,
                                              parseQueryParamMaybe,
-                                             parseUrlPieceMaybe)
+                                             parseUrlPieceMaybe,
+                                             parseUrlPieces)
 
 import           Servant.API                 ((:<|>) (..), (:>), BasicAuth, Capture,
-                                              Verb, ReflectMethod(reflectMethod),
+                                              CaptureAll, Verb,
-                                              IsSecure(..), Header,
+                                              ReflectMethod(reflectMethod),
-                                              QueryFlag, QueryParam, QueryParams,
+                                              IsSecure(..), Header, QueryFlag,
-                                              Raw, RemoteHost, ReqBody, Vault,
+                                              QueryParam, QueryParams, Raw,
+                                              RemoteHost, ReqBody, Vault,
                                               WithNamedContext)
 import           Servant.API.ContentTypes    (AcceptHeader (..),
                                               AllCTRender (..),
@@ -128,11 +130,44 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
     CaptureRouter $
         route (Proxy :: Proxy api)
               context
-              (addCapture d $ \ txt -> case parseUrlPieceMaybe txt :: Maybe a of
+              (addCapture d $ \ txt -> case parseUrlPieceMaybe txt of
                  Nothing -> delayedFail err400
                  Just v  -> return v
               )
 
+-- | If you use 'CaptureAll' in one of the endpoints for your API,
+-- this automatically requires your server-side handler to be a
+-- function that takes an argument of a list of the type specified by
+-- the 'CaptureAll'. This lets servant worry about getting values from
+-- the URL and turning them into values of the type you specify.
+--
+-- You can control how they'll be converted from 'Text' to your type
+-- by simply providing an instance of 'FromHttpApiData' for your type.
+--
+-- Example:
+--
+-- > type MyApi = "src" :> CaptureAll "segments" Text :> Get '[JSON] SourceFile
+-- >
+-- > server :: Server MyApi
+-- > server = getSourceFile
+-- >   where getSourceFile :: [Text] -> Handler Book
+-- >         getSourceFile pathSegments = ...
+instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context)
+      => HasServer (CaptureAll capture a :> sublayout) context where
+
+  type ServerT (CaptureAll capture a :> sublayout) m =
+    [a] -> ServerT sublayout m
+
+  route Proxy context d =
+    CaptureAllRouter $
+        route (Proxy :: Proxy sublayout)
+              context
+              (addCapture d $ \ txts -> case parseUrlPieces txts of
+                 Left _  -> delayedFail err400
+                 Right v -> return v
+              )
+
+
 allowedMethodHead :: Method -> Request -> Bool
 allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
 

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

@@ -31,6 +31,9 @@ data Router' env a =
   | CaptureRouter (Router' (Text, env) a)
       -- ^ first path component is passed to the child router in its
       --   environment and removed afterwards
+  | CaptureAllRouter (Router' ([Text], env) a)
+      -- ^ all path components are passed to the child router in its
+      --   environment and are removed afterwards
   | RawRouter     (env -> a)
       -- ^ to be used for routes we do not know anything about
   | Choice        (Router' env a) (Router' env a)
@@ -90,6 +93,9 @@ routerStructure (StaticRouter m ls) =
 routerStructure (CaptureRouter router) =
   CaptureRouterStructure $
     routerStructure router
+routerStructure (CaptureAllRouter router) =
+  CaptureRouterStructure $
+    routerStructure router
 routerStructure (RawRouter _) =
   RawRouterStructure
 routerStructure (Choice r1 r2) =
@@ -163,6 +169,10 @@ runRouterEnv router env request respond =
         first : rest
           -> let request' = request { pathInfo = rest }
              in  runRouterEnv router' (first, env) request' respond
+    CaptureAllRouter router' ->
+      let segments = pathInfo request
+          request' = request { pathInfo = [] }
+      in runRouterEnv router' (segments, env) request' respond
     RawRouter app ->
       app env request respond
     Choice r1 r2 ->

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

@@ -11,7 +11,6 @@ module Servant.Server.Internal.RoutingApplication where
 import           Control.Monad                      (ap, liftM)
 import           Control.Monad.Trans                (MonadIO(..))
 import           Control.Monad.Trans.Except         (runExceptT)
-import           Data.Text                          (Text)
 import           Network.Wai                        (Application, Request,
                                                      Response, ResponseReceived)
 import           Prelude                            ()
@@ -161,8 +160,8 @@ withRequest f = DelayedIO (\ req -> runDelayedIO (f req) req)
 
 -- | Add a capture to the end of the capture block.
 addCapture :: Delayed env (a -> b)
-           -> (Text -> DelayedIO a)
+           -> (captured -> DelayedIO a)
-           -> Delayed (Text, env) b
+           -> Delayed (captured, env) b
 addCapture Delayed{..} new =
   Delayed
     { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt

servant-server/test/Servant/ServerSpec.hs

@@ -39,7 +39,7 @@ import           Network.Wai.Test           (defaultRequest, request,
                                              simpleHeaders, simpleStatus)
 import           Servant.API                ((:<|>) (..), (:>), AuthProtect,
                                              BasicAuth, BasicAuthData(BasicAuthData),
-                                             Capture, Delete, Get, Header (..),
+                                             Capture, CaptureAll, Delete, Get, Header (..),
                                              Headers, HttpVersion,
                                              IsSecure (..), JSON,
                                              NoContent (..), Patch, PlainText,
@@ -216,6 +216,58 @@ captureSpec = do
       it "strips the captured path snippet from pathInfo" $ do
         get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))
 
+-- }}}
+------------------------------------------------------------------------------
+-- * captureAllSpec {{{
+------------------------------------------------------------------------------
+
+type CaptureAllApi = CaptureAll "legs" Integer :> Get '[JSON] Animal
+captureAllApi :: Proxy CaptureAllApi
+captureAllApi = Proxy
+captureAllServer :: [Integer] -> Handler Animal
+captureAllServer legs = case sum legs of
+  4 -> return jerry
+  2 -> return tweety
+  0 -> return beholder
+  _ -> throwE err404
+
+captureAllSpec :: Spec
+captureAllSpec = do
+  describe "Servant.API.CaptureAll" $ do
+    with (return (serve captureAllApi captureAllServer)) $ do
+
+      it "can capture a single element of the 'pathInfo'" $ do
+        response <- get "/2"
+        liftIO $ decode' (simpleBody response) `shouldBe` Just tweety
+
+      it "can capture multiple elements of the 'pathInfo'" $ do
+        response <- get "/2/2"
+        liftIO $ decode' (simpleBody response) `shouldBe` Just jerry
+
+      it "can capture arbitrarily many elements of the 'pathInfo'" $ do
+        response <- get "/1/1/0/1/0/1"
+        liftIO $ decode' (simpleBody response) `shouldBe` Just jerry
+
+      it "can capture when there are no elements in 'pathInfo'" $ do
+        response <- get "/"
+        liftIO $ decode' (simpleBody response) `shouldBe` Just beholder
+
+      it "returns 400 if the decoding fails" $ do
+        get "/notAnInt" `shouldRespondWith` 400
+
+      it "returns 400 if the decoding fails, regardless of which element" $ do
+        get "/1/0/0/notAnInt/3/" `shouldRespondWith` 400
+
+      it "returns 400 if the decoding fails, even when it's multiple elements" $ do
+        get "/1/0/0/notAnInt/3/orange/" `shouldRespondWith` 400
+
+    with (return (serve
+        (Proxy :: Proxy (CaptureAll "segments" String :> Raw))
+        (\ _captured request_ respond ->
+            respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
+      it "consumes everything from pathInfo" $ do
+        get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int])))
+
 -- }}}
 ------------------------------------------------------------------------------
 -- * queryParamSpec {{{
@@ -644,4 +696,7 @@ jerry = Animal "Mouse" 4
 
 tweety :: Animal
 tweety = Animal "Bird" 2
+
+beholder :: Animal
+beholder = Animal "Beholder" 0
 -- }}}