eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Merge pull request #519 from jml/capture-all-take-2

Browse source 
CaptureAll combinator - take #2
This commit is contained in:
Arian van Putten 2016-07-11 17:03:01 +02:00 committed by GitHub
commit a844b7c297
16 changed files with 235 additions and 18 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

32
servant-client/src/Servant/Client.hs
View file

@ -118,6 +118,38 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient api)
where p = unpack (toUrlPiece val)
-- | If you use a 'CaptureAll' in one of your endpoints in your API,
-- the corresponding querying function will automatically take an
-- additional argument of a list of the type specified by your
-- 'CaptureAll'. That function will take care of inserting a textual
-- representation of this value at the right place in the request
-- path.
--
-- You can control how these values are turned into text by specifying
-- a 'ToHttpApiData' instance of your type.
--
-- Example:
--
-- > type MyAPI = "src" :> CaptureAll Text -> Get '[JSON] SourceFile
-- >
-- > myApi :: Proxy
-- > myApi = Proxy
--
-- > getSourceFile :: [Text] -> Manager -> BaseUrl -> ClientM SourceFile
-- > getSourceFile = client myApi
-- > -- then you can use "getSourceFile" to query that endpoint
instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout)
=> HasClient (CaptureAll capture a :> sublayout) where
type Client (CaptureAll capture a :> sublayout) =
[a] -> Client sublayout
clientWithRoute Proxy req vals =
clientWithRoute (Proxy :: Proxy sublayout)
(foldl' (flip appendToPath) req ps)
where ps = map (unpack . toUrlPiece) vals
instance OVERLAPPABLE_
-- Note [Non-Empty Content Types]
(MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)

10
servant-client/test/Servant/ClientSpec.hs
View file

@ -105,6 +105,7 @@ type Api =
"get" :> Get '[JSON] Person
:<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent
:<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
:<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
:<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
:<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
:<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
@ -125,6 +126,7 @@ api = Proxy
getGet :: C.Manager -> BaseUrl -> SCR.ClientM Person
getDeleteEmpty :: C.Manager -> BaseUrl -> SCR.ClientM NoContent
getCapture :: String -> C.Manager -> BaseUrl -> SCR.ClientM Person
getCaptureAll :: [String] -> C.Manager -> BaseUrl -> SCR.ClientM [Person]
getBody :: Person -> C.Manager -> BaseUrl -> SCR.ClientM Person
getQueryParam :: Maybe String -> C.Manager -> BaseUrl -> SCR.ClientM Person
getQueryParams :: [String] -> C.Manager -> BaseUrl -> SCR.ClientM [Person]
@ -140,6 +142,7 @@ getDeleteContentType :: C.Manager -> BaseUrl -> SCR.ClientM NoContent
getGet
:<|> getDeleteEmpty
:<|> getCapture
:<|> getCaptureAll
:<|> getBody
:<|> getQueryParam
:<|> getQueryParams
@ -155,6 +158,7 @@ server = serve api (
return alice
:<|> return NoContent
:<|> (\ name -> return $ Person name 0)
:<|> (\ names -> return (zipWith Person names [0..]))
:<|> return
:<|> (\ name -> case name of
Just "alice" -> return alice
@ -250,6 +254,10 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
it "Servant.API.Capture" $ \(_, baseUrl) -> do
(left show <$> runExceptT (getCapture "Paula" manager baseUrl)) `shouldReturn` Right (Person "Paula" 0)
it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do
let expected = [(Person "Paula" 0), (Person "Peta" 1)]
(left show <$> runExceptT (getCaptureAll ["Paula", "Peta"] manager baseUrl)) `shouldReturn` Right expected
it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
let p = Person "Clara" 42
(left show <$> runExceptT (getBody p manager baseUrl)) `shouldReturn` Right p
@ -351,7 +359,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
_ -> fail $ "expected UnsupportedContentType, but got " <> show res
it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
let (_ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
Left res <- runExceptT (getBody alice manager baseUrl)
case res of
InvalidContentTypeHeader "fooooo" _ -> return ()

16
servant-docs/src/Servant/Docs/Internal.hs
View file

@ -702,6 +702,22 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)
symP = Proxy :: Proxy sym
-- | @"books" :> 'CaptureAll' "isbn" Text@ will appear as
-- @/books/:isbn@ in the docs.
instance (KnownSymbol sym, ToCapture (CaptureAll sym a), HasDocs sublayout)
=> HasDocs (CaptureAll sym a :> sublayout) where
docsFor Proxy (endpoint, action) =
docsFor sublayoutP (endpoint', action')
where sublayoutP = Proxy :: Proxy sublayout
captureP = Proxy :: Proxy (CaptureAll sym a)
action' = over captures (|> toCapture captureP) action
endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint
symP = Proxy :: Proxy sym
instance OVERLAPPABLE_
(ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
, ReflectMethod method)

2
servant-docs/test/Servant/DocsSpec.hs
View file

@ -34,6 +34,8 @@ instance ToParam (QueryFlag "foo") where
toParam = error "unused"
instance ToCapture (Capture "foo" Int) where
toCapture = error "unused"
instance ToCapture (CaptureAll "foo" Int) where
toCapture = error "unused"
-- * specs

15
servant-foreign/src/Servant/Foreign/Internal.hs
View file

@ -211,6 +211,21 @@ instance (KnownSymbol sym, HasForeignType lang ftype t, HasForeign lang ftype ap
{ _argName = PathSegment str
, _argType = ftype }
instance (KnownSymbol sym, HasForeignType lang ftype [t], HasForeign lang ftype sublayout)
=> HasForeign lang ftype (CaptureAll sym t :> sublayout) where
type Foreign ftype (CaptureAll sym t :> sublayout) = Foreign ftype sublayout
foreignFor lang Proxy Proxy req =
foreignFor lang Proxy (Proxy :: Proxy sublayout) $
req & reqUrl . path <>~ [Segment (Cap arg)]
& reqFuncName . _FunctionName %~ (++ ["by", str])
where
str = pack . symbolVal $ (Proxy :: Proxy sym)
ftype = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy [t])
arg = Arg
{ _argName = PathSegment str
, _argType = ftype }
instance (Elem JSON list, HasForeignType lang ftype a, ReflectMethod method)
=> HasForeign lang ftype (Verb method status list a) where
type Foreign ftype (Verb method status list a) = Req ftype

18
servant-foreign/test/Servant/ForeignSpec.hs
View file

@ -46,6 +46,7 @@ type TestApi
:<|> "test" :> QueryParam "param" Int :> ReqBody '[JSON] [String] :> Post '[JSON] NoContent
:<|> "test" :> QueryParams "params" Int :> ReqBody '[JSON] String :> Put '[JSON] NoContent
:<|> "test" :> Capture "id" Int :> Delete '[JSON] NoContent
:<|> "test" :> CaptureAll "ids" Int :> Get '[JSON] [Int]
testApi :: [Req String]
testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy String) (Proxy :: Proxy TestApi)
@ -53,9 +54,9 @@ testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy String) (Proxy :: P
listFromAPISpec :: Spec
listFromAPISpec = describe "listFromAPI" $ do
it "generates 4 endpoints for TestApi" $ do
length testApi `shouldBe` 4
length testApi `shouldBe` 5
let [getReq, postReq, putReq, deleteReq] = testApi
let [getReq, postReq, putReq, deleteReq, captureAllReq] = testApi
it "collects all info for get request" $ do
shouldBe getReq $ defReq
@ -106,3 +107,16 @@ listFromAPISpec = describe "listFromAPI" $ do
, _reqReturnType = Just "voidX"
, _reqFuncName = FunctionName ["delete", "test", "by", "id"]
}
it "collects all info for capture all request" $ do
shouldBe captureAllReq $ defReq
{ _reqUrl = Url
[ Segment $ Static "test"
, Segment $ Cap (Arg "ids" "listX of intX") ]
[]
, _reqMethod = "GET"
, _reqHeaders = []
, _reqBody = Nothing
, _reqReturnType = Just "listX of intX"
, _reqFuncName = FunctionName ["get", "test", "by", "ids"]
}

3
servant-mock/src/Servant/Mock.hs
View file

@ -115,6 +115,9 @@ instance (KnownSymbol path, HasMock rest context) => HasMock (path :> rest) cont
instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) => HasMock (Capture s a :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) => HasMock (CaptureAll s a :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance (AllCTUnrender ctypes a, HasMock rest context) => HasMock (ReqBody ctypes a :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context

47
servant-server/src/Servant/Server/Internal.hs
View file

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

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

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

5
servant-server/src/Servant/Server/Internal/RoutingApplication.hs
View file

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

57
servant-server/test/Servant/ServerSpec.hs
View file

@ -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
-- }}}

4
servant/src/Servant/API.hs
View file

@ -8,7 +8,7 @@ module Servant.API (
-- * Accessing information from the request
module Servant.API.Capture,
-- | Capturing parts of the url path as parsed values: @'Capture'@
-- | Capturing parts of the url path as parsed values: @'Capture'@ and @'CaptureAll'@
module Servant.API.Header,
-- | Retrieving specific headers from the request
module Servant.API.HttpVersion,
@ -60,7 +60,7 @@ module Servant.API (
import Servant.API.Alternative ((:<|>) (..))
import Servant.API.BasicAuth (BasicAuth,BasicAuthData(..))
import Servant.API.Capture (Capture)
import Servant.API.Capture (Capture, CaptureAll)
import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,
FromFormUrlEncoded (..), JSON,
MimeRender (..), NoContent (NoContent),

15
servant/src/Servant/API/Capture.hs
View file

@ -2,7 +2,7 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE PolyKinds #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Capture (Capture) where
module Servant.API.Capture (Capture, CaptureAll) where
import Data.Typeable (Typeable)
import GHC.TypeLits (Symbol)
@ -15,9 +15,22 @@ import GHC.TypeLits (Symbol)
data Capture (sym :: Symbol) a
deriving (Typeable)
-- | Capture all remaining values from the request path under a certain type
-- @a@.
--
-- Example:
--
-- >>> -- GET /src/*
-- >>> type MyAPI = "src" :> CaptureAll "segments" Text :> Get '[JSON] SourceFile
data CaptureAll (sym :: Symbol) a
deriving (Typeable)
-- $setup
-- >>> import Servant.API
-- >>> import Data.Aeson
-- >>> import Data.Text
-- >>> data Book
-- >>> instance ToJSON Book where { toJSON = undefined }
-- >>> data SourceFile
-- >>> instance ToJSON SourceFile where { toJSON = undefined }

3
servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs
View file

@ -30,7 +30,8 @@ type ComprehensiveAPI =
Vault :> GET :<|>
Verb 'POST 204 '[JSON] NoContent :<|>
Verb 'POST 204 '[JSON] Int :<|>
WithNamedContext "foo" '[] GET
WithNamedContext "foo" '[] GET :<|>
CaptureAll "foo" Int :> GET
comprehensiveAPI :: Proxy ComprehensiveAPI
comprehensiveAPI = Proxy

11
servant/src/Servant/Utils/Links.hs
View file

@ -107,7 +107,7 @@ import Prelude.Compat
import Web.HttpApiData
import Servant.API.BasicAuth ( BasicAuth )
import Servant.API.Capture ( Capture )
import Servant.API.Capture ( Capture, CaptureAll )
import Servant.API.ReqBody ( ReqBody )
import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag )
import Servant.API.Header ( Header )
@ -163,6 +163,8 @@ type family IsElem endpoint api :: Constraint where
IsElem sa (ReqBody y x :> sb) = IsElem sa sb
IsElem (Capture z y :> sa) (Capture x y :> sb)
= IsElem sa sb
IsElem (CaptureAll z y :> sa) (CaptureAll x y :> sb)
= IsElem sa sb
IsElem sa (QueryParam x y :> sb) = IsElem sa sb
IsElem sa (QueryParams x y :> sb) = IsElem sa sb
IsElem sa (QueryFlag x :> sb) = IsElem sa sb
@ -284,6 +286,13 @@ instance (ToHttpApiData v, HasLink sub)
toLink (Proxy :: Proxy sub) $
addSegment (escape . Text.unpack $ toUrlPiece v) l
instance (ToHttpApiData v, HasLink sub)
=> HasLink (CaptureAll sym v :> sub) where
type MkLink (CaptureAll sym v :> sub) = [v] -> MkLink sub
toLink _ l vs =
toLink (Proxy :: Proxy sub) $
foldl' (flip $ addSegment . escape . Text.unpack . toUrlPiece) l vs
instance HasLink sub => HasLink (Header sym a :> sub) where
type MkLink (Header sym a :> sub) = MkLink sub
toLink _ = toLink (Proxy :: Proxy sub)

5
servant/test/Servant/Utils/LinksSpec.hs
View file

@ -13,6 +13,7 @@ import Servant.API
type TestApi =
-- Capture and query params
"hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete '[JSON] NoContent
:<|> "all" :> CaptureAll "names" String :> Get '[JSON] NoContent
-- Flags
:<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] NoContent
@ -46,6 +47,10 @@ spec = describe "Servant.Utils.Links" $ do
:> Delete '[JSON] NoContent)
apiLink l2 "bye" (Just True) `shouldBeURI` "hello/bye?capital=true"
it "generates correct links for CaptureAll" $ do
apiLink (Proxy :: Proxy ("all" :> CaptureAll "names" String :> Get '[JSON] NoContent))
["roads", "lead", "to", "rome"]
`shouldBeURI` "all/roads/lead/to/rome"
it "generates correct links for query flags" $ do
let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy"