git.iko.soy/typeable/servant
on master help sign in
servant-server support for CaptureAll
commitc79a254b36a6c81f704a60d13aeb4e4e5f17da22 authorJonathan Lange <jml@mumak.net> dateThu 26 May 2016, 19:10 (10 years ago) parent7fb9a95
4 files changed+109−10
compare with master
unifiedsplit
servant-server/src/Servant/Server/Internal.hs+41−6 servant-server/src/Servant/Server/Internal/Router.hs+10 servant-server/src/Servant/Server/Internal/RoutingApplication.hs+2−3 servant-server/test/Servant/ServerSpec.hs+56−1
servant-server/src/Servant/Server/Internal.hs+41−6
@@ -45,13 +45,15 @@ import Prelude.Compat
4545import Web.HttpApiData (FromHttpApiData)
4646import Web.HttpApiData.Internal (parseHeaderMaybe,
4747 parseQueryParamMaybe,
48− parseUrlPieceMaybe)
48+ parseUrlPieceMaybe,
49+ parseUrlPieces)
4950
5051import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture,
51− Verb, ReflectMethod(reflectMethod),
52− IsSecure(..), Header,
53− QueryFlag, QueryParam, QueryParams,
54− Raw, RemoteHost, ReqBody, Vault,
52+ CaptureAll, Verb,
53+ ReflectMethod(reflectMethod),
54+ IsSecure(..), Header, QueryFlag,
55+ QueryParam, QueryParams, Raw,
56+ RemoteHost, ReqBody, Vault,
5557 WithNamedContext)
5658import Servant.API.ContentTypes (AcceptHeader (..),
5759 AllCTRender (..),
@@ -128,11 +130,44 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
128130 CaptureRouter $
129131 route (Proxy :: Proxy api)
130132 context
131− (addCapture d $ \ txt -> case parseUrlPieceMaybe txt :: Maybe a of
133+ (addCapture d $ \ txt -> case parseUrlPieceMaybe txt of
132134 Nothing -> delayedFail err400
133135 Just v -> return v
134136 )
135137
138+-- | If you use 'CaptureAll' in one of the endpoints for your API,
139+-- this automatically requires your server-side handler to be a
140+-- function that takes an argument of a list of the type specified by
141+-- the 'CaptureAll'. This lets servant worry about getting values from
142+-- the URL and turning them into values of the type you specify.
143+--
144+-- You can control how they'll be converted from 'Text' to your type
145+-- by simply providing an instance of 'FromHttpApiData' for your type.
146+--
147+-- Example:
148+--
149+-- > type MyApi = "src" :> CaptureAll "segments" Text :> Get '[JSON] SourceFile
150+-- >
151+-- > server :: Server MyApi
152+-- > server = getSourceFile
153+-- > where getSourceFile :: [Text] -> Handler Book
154+-- > getSourceFile pathSegments = ...
155+instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context)
156+ => HasServer (CaptureAll capture a :> sublayout) context where
157+
158+ type ServerT (CaptureAll capture a :> sublayout) m =
159+ [a] -> ServerT sublayout m
160+
161+ route Proxy context d =
162+ CaptureAllRouter $
163+ route (Proxy :: Proxy sublayout)
164+ context
165+ (addCapture d $ \ txts -> case parseUrlPieces txts of
166+ Left _ -> delayedFail err400
167+ Right v -> return v
168+ )
169+
170+
136171allowedMethodHead :: Method -> Request -> Bool
137172allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
138173
servant-server/src/Servant/Server/Internal/Router.hs+10
@@ -31,6 +31,9 @@ data Router' env a =
3131 | CaptureRouter (Router' (Text, env) a)
3232 -- ^ first path component is passed to the child router in its
3333 -- environment and removed afterwards
34+ | CaptureAllRouter (Router' ([Text], env) a)
35+ -- ^ all path components are passed to the child router in its
36+ -- environment and are removed afterwards
3437 | RawRouter (env -> a)
3538 -- ^ to be used for routes we do not know anything about
3639 | Choice (Router' env a) (Router' env a)
@@ -90,6 +93,9 @@ routerStructure (StaticRouter m ls) =
9093routerStructure (CaptureRouter router) =
9194 CaptureRouterStructure $
9295 routerStructure router
96+routerStructure (CaptureAllRouter router) =
97+ CaptureRouterStructure $
98+ routerStructure router
9399routerStructure (RawRouter _) =
94100 RawRouterStructure
95101routerStructure (Choice r1 r2) =
@@ -163,6 +169,10 @@ runRouterEnv router env request respond =
163169 first : rest
164170 -> let request' = request { pathInfo = rest }
165171 in runRouterEnv router' (first, env) request' respond
172+ CaptureAllRouter router' ->
173+ let segments = pathInfo request
174+ request' = request { pathInfo = [] }
175+ in runRouterEnv router' (segments, env) request' respond
166176 RawRouter app ->
167177 app env request respond
168178 Choice r1 r2 ->
servant-server/src/Servant/Server/Internal/RoutingApplication.hs+2−3
@@ -11,7 +11,6 @@ module Servant.Server.Internal.RoutingApplication where
1111import Control.Monad (ap, liftM)
1212import Control.Monad.Trans (MonadIO(..))
1313import Control.Monad.Trans.Except (runExceptT)
14−import Data.Text (Text)
1514import Network.Wai (Application, Request,
1615 Response, ResponseReceived)
1716import Prelude ()
@@ -161,8 +160,8 @@ withRequest f = DelayedIO (\ req -> runDelayedIO (f req) req)
161160
162161-- | Add a capture to the end of the capture block.
163162addCapture :: Delayed env (a -> b)
164− -> (Text -> DelayedIO a)
165− -> Delayed (Text, env) b
163+ -> (captured -> DelayedIO a)
164+ -> Delayed (captured, env) b
166165addCapture Delayed{..} new =
167166 Delayed
168167 { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt
servant-server/test/Servant/ServerSpec.hs+56−1
@@ -39,7 +39,7 @@ import Network.Wai.Test (defaultRequest, request,
3939 simpleHeaders, simpleStatus)
4040import Servant.API ((:<|>) (..), (:>), AuthProtect,
4141 BasicAuth, BasicAuthData(BasicAuthData),
42− Capture, Delete, Get, Header (..),
42+ Capture, CaptureAll, Delete, Get, Header (..),
4343 Headers, HttpVersion,
4444 IsSecure (..), JSON,
4545 NoContent (..), Patch, PlainText,
@@ -216,6 +216,58 @@ captureSpec = do
216216 it "strips the captured path snippet from pathInfo" $ do
217217 get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))
218218
219+-- }}}
220+------------------------------------------------------------------------------
221+-- * captureAllSpec {{{
222+------------------------------------------------------------------------------
223+
224+type CaptureAllApi = CaptureAll "legs" Integer :> Get '[JSON] Animal
225+captureAllApi :: Proxy CaptureAllApi
226+captureAllApi = Proxy
227+captureAllServer :: [Integer] -> Handler Animal
228+captureAllServer legs = case sum legs of
229+ 4 -> return jerry
230+ 2 -> return tweety
231+ 0 -> return beholder
232+ _ -> throwE err404
233+
234+captureAllSpec :: Spec
235+captureAllSpec = do
236+ describe "Servant.API.CaptureAll" $ do
237+ with (return (serve captureAllApi captureAllServer)) $ do
238+
239+ it "can capture a single element of the 'pathInfo'" $ do
240+ response <- get "/2"
241+ liftIO $ decode' (simpleBody response) `shouldBe` Just tweety
242+
243+ it "can capture multiple elements of the 'pathInfo'" $ do
244+ response <- get "/2/2"
245+ liftIO $ decode' (simpleBody response) `shouldBe` Just jerry
246+
247+ it "can capture arbitrarily many elements of the 'pathInfo'" $ do
248+ response <- get "/1/1/0/1/0/1"
249+ liftIO $ decode' (simpleBody response) `shouldBe` Just jerry
250+
251+ it "can capture when there are no elements in 'pathInfo'" $ do
252+ response <- get "/"
253+ liftIO $ decode' (simpleBody response) `shouldBe` Just beholder
254+
255+ it "returns 400 if the decoding fails" $ do
256+ get "/notAnInt" `shouldRespondWith` 400
257+
258+ it "returns 400 if the decoding fails, regardless of which element" $ do
259+ get "/1/0/0/notAnInt/3/" `shouldRespondWith` 400
260+
261+ it "returns 400 if the decoding fails, even when it's multiple elements" $ do
262+ get "/1/0/0/notAnInt/3/orange/" `shouldRespondWith` 400
263+
264+ with (return (serve
265+ (Proxy :: Proxy (CaptureAll "segments" String :> Raw))
266+ (\ _captured request_ respond ->
267+ respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
268+ it "consumes everything from pathInfo" $ do
269+ get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int])))
270+
219271-- }}}
220272------------------------------------------------------------------------------
221273-- * queryParamSpec {{{
@@ -644,4 +696,7 @@ jerry = Animal "Mouse" 4
644696
645697tweety :: Animal
646698tweety = Animal "Bird" 2
699+
700+beholder :: Animal
701+beholder = Animal "Beholder" 0
647702-- }}}