diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 21374dbe..de4a237a 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/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), - IsSecure(..), Header, - QueryFlag, QueryParam, QueryParams, - Raw, RemoteHost, ReqBody, Vault, + CaptureAll, Verb, + ReflectMethod(reflectMethod), + IsSecure(..), Header, QueryFlag, + 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 diff --git a/servant-server/src/Servant/Server/Internal/Router.hs b/servant-server/src/Servant/Server/Internal/Router.hs index 3b69c04c..d01cc67a 100644 --- a/servant-server/src/Servant/Server/Internal/Router.hs +++ b/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 -> diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 10bdc461..5f78d0bb 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/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) - -> Delayed (Text, env) b + -> (captured -> DelayedIO a) + -> Delayed (captured, env) b addCapture Delayed{..} new = Delayed { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 4e1adade..2337c258 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/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 -- }}}