servant-server support for CaptureAll
This commit is contained in:
Jonathan Lange
parent
7fb9a95711
commit
c79a254b36
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ->
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
-- }}}
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user