c79a254 · typeable/servant

git.iko.soy/typeable/servant

on master help sign in

servant-server support for CaptureAll

c79a254Jonathan Lange10 years ago

servant-server/src/Servant/Server/Internal.hs+41−6

compare with master

unifiedsplit

@@ -45,13 +45,15 @@ import Prelude.Compat

45import Web.HttpApiData (FromHttpApiData)

46import Web.HttpApiData.Internal (parseHeaderMaybe,

47 parseQueryParamMaybe,

48− parseUrlPieceMaybe)

48+ parseUrlPieceMaybe,

49+ parseUrlPieces)

50import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture,

51import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture,

52+ CaptureAll, Verb,

51− Verb, ReflectMethod(reflectMethod),

53+ ReflectMethod(reflectMethod),

52− IsSecure(..), Header,

54+ IsSecure(..), Header, QueryFlag,

53− QueryFlag, QueryParam, QueryParams,

55+ QueryParam, QueryParams, Raw,

54− Raw, RemoteHost, ReqBody, Vault,

56+ RemoteHost, ReqBody, Vault,

55 WithNamedContext)

57 WithNamedContext)

56import Servant.API.ContentTypes (AcceptHeader (..),

58import Servant.API.ContentTypes (AcceptHeader (..),

57 AllCTRender (..),

59 AllCTRender (..),

@@ -128,11 +130,44 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)

128 CaptureRouter $

130 CaptureRouter $

129 route (Proxy :: Proxy api)

131 route (Proxy :: Proxy api)

130 context

132 context

131− (addCapture d $ \ txt -> case parseUrlPieceMaybe txt :: Maybe a of

133+ (addCapture d $ \ txt -> case parseUrlPieceMaybe txt of

132 Nothing -> delayedFail err400

134 Nothing -> delayedFail err400

133 Just v -> return v

135 Just v -> return v

134 )

136 )

135

137

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+

136allowedMethodHead :: Method -> Request -> Bool

171allowedMethodHead :: Method -> Request -> Bool

137allowedMethodHead method request = method == methodGet && requestMethod request == methodHead

172allowedMethodHead method request = method == methodGet && requestMethod request == methodHead

138

173

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

@@ -31,6 +31,9 @@ data Router' env a =

31 | CaptureRouter (Router' (Text, env) a)

32 -- ^ first path component is passed to the child router in its

33 -- 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

34 | RawRouter (env -> a)

37 | RawRouter (env -> a)

35 -- ^ to be used for routes we do not know anything about

38 -- ^ to be used for routes we do not know anything about

36 | Choice (Router' env a) (Router' env a)

39 | Choice (Router' env a) (Router' env a)

@@ -90,6 +93,9 @@ routerStructure (StaticRouter m ls) =

90routerStructure (CaptureRouter router) =

93routerStructure (CaptureRouter router) =

91 CaptureRouterStructure $

94 CaptureRouterStructure $

92 routerStructure router

95 routerStructure router

96+routerStructure (CaptureAllRouter router) =

97+ CaptureRouterStructure $

98+ routerStructure router

93routerStructure (RawRouter _) =

99routerStructure (RawRouter _) =

94 RawRouterStructure

100 RawRouterStructure

95routerStructure (Choice r1 r2) =

101routerStructure (Choice r1 r2) =

@@ -163,6 +169,10 @@ runRouterEnv router env request respond =

163 first : rest

169 first : rest

164 -> let request' = request { pathInfo = rest }

170 -> let request' = request { pathInfo = rest }

165 in runRouterEnv router' (first, env) request' respond

171 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

166 RawRouter app ->

176 RawRouter app ->

167 app env request respond

177 app env request respond

168 Choice r1 r2 ->

178 Choice r1 r2 ->

servant-server/src/Servant/Server/Internal/RoutingApplication.hs+2−3

@@ -11,7 +11,6 @@ module Servant.Server.Internal.RoutingApplication where

11import Control.Monad (ap, liftM)

12import Control.Monad.Trans (MonadIO(..))

13import Control.Monad.Trans.Except (runExceptT)

14−import Data.Text (Text)

15import Network.Wai (Application, Request,

14import Network.Wai (Application, Request,

16 Response, ResponseReceived)

15 Response, ResponseReceived)

17import Prelude ()

16import Prelude ()

@@ -161,8 +160,8 @@ withRequest f = DelayedIO (\ req -> runDelayedIO (f req) req)

161

160

162-- | Add a capture to the end of the capture block.

161-- | Add a capture to the end of the capture block.

163addCapture :: Delayed env (a -> b)

162addCapture :: Delayed env (a -> b)

164− -> (Text -> DelayedIO a)

163+ -> (captured -> DelayedIO a)

165− -> Delayed (Text, env) b

164+ -> Delayed (captured, env) b

166addCapture Delayed{..} new =

165addCapture Delayed{..} new =

167 Delayed

166 Delayed

168 { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt

167 { 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,

39 simpleHeaders, simpleStatus)

40import Servant.API ((:<|>) (..), (:>), AuthProtect,

41 BasicAuth, BasicAuthData(BasicAuthData),

42− Capture, Delete, Get, Header (..),

42+ Capture, CaptureAll, Delete, Get, Header (..),

43 Headers, HttpVersion,

44 IsSecure (..), JSON,

45 NoContent (..), Patch, PlainText,

@@ -216,6 +216,58 @@ captureSpec = do

216 it "strips the captured path snippet from pathInfo" $ do

217 get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))

218

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+

219-- }}}

271-- }}}

220------------------------------------------------------------------------------

272------------------------------------------------------------------------------

221-- * queryParamSpec {{{

273-- * queryParamSpec {{{

@@ -644,4 +696,7 @@ jerry = Animal "Mouse" 4

644

696

645tweety :: Animal

697tweety :: Animal

646tweety = Animal "Bird" 2

698tweety = Animal "Bird" 2

699+

700+beholder :: Animal

701+beholder = Animal "Beholder" 0

647-- }}}

702-- }}}