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

Add URI fragment as a separate combinator (#1324)

Browse source
This commit is contained in:
Andrey Prokopenko 2020-11-18 21:57:20 +03:00 committed by GitHub
parent 339eec6a90
commit da0c83d318
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
19 changed files with 418 additions and 120 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

48
servant-client-core/src/Servant/Client/Core/HasClient.hs
View file

@ -1,4 +1,5 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
@ -13,6 +14,10 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
#define HAS_TYPE_ERROR
#endif
module Servant.Client.Core.HasClient (
clientIn,
HasClient (..),
@ -63,17 +68,18 @@ import qualified Network.HTTP.Types as H
import Servant.API
((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
BuildHeadersTo (..), Capture', CaptureAll, Description,
EmptyAPI, FramingRender (..), FramingUnrender (..),
EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..),
FromSourceIO (..), Header', Headers (..), HttpVersion,
IsSecure, MimeRender (mimeRender),
MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag,
QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost,
ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData,
ToSourceIO (..), Vault, Verb, NoContentVerb, WithNamedContext,
contentType, getHeadersHList, getResponse, toQueryParam,
toUrlPiece)
MimeUnrender (mimeUnrender), NoContent (NoContent),
NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,
ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
Verb, WithNamedContext, contentType, getHeadersHList,
getResponse, toQueryParam, toUrlPiece)
import Servant.API.ContentTypes
(contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
import Servant.API.Modifiers
(FoldRequired, RequiredArgument, foldRequiredArgument)
import Servant.API.UVerb
@ -745,6 +751,34 @@ instance ( HasClient m api
hoistClientMonad pm _ f cl = \authreq ->
hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq)
-- | Ignore @'Fragment'@ in client functions.
-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
--
-- Example:
--
-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > getBooksBy :: Maybe Text -> ClientM [Book]
-- > getBooksBy = client myApi
-- > -- then you can just use "getBooksBy" to query that endpoint.
-- > -- 'getBooksBy Nothing' for all books
-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
#ifdef HAS_TYPE_ERROR
instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api
#else
instance ( HasClient m api
#endif
) => HasClient m (Fragment a :> api) where
type Client m (Fragment a :> api) = Client m api
clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)
-- * Basic Authentication
instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where

23
servant-client/test/Servant/ClientTestUtils.hs
View file

@ -32,9 +32,11 @@ import Data.Char
(chr, isPrint)
import Data.Monoid ()
import Data.Proxy
import Data.Text (Text)
import Data.Text
(Text)
import qualified Data.Text as Text
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.Text.Encoding
(decodeUtf8, encodeUtf8)
import GHC.Generics
(Generic)
import qualified Network.HTTP.Client as C
@ -50,13 +52,12 @@ import Web.FormUrlEncoded
import Servant.API
((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,
BasicAuthData (..), Capture, CaptureAll,
DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,
Headers, JSON, MimeRender(mimeRender),
MimeUnrender(mimeUnrender), NoContent (NoContent), PlainText,
Post, QueryFlag, QueryParam, QueryParams, Raw, ReqBody,
StdMethod(GET), Union, UVerb, WithStatus(WithStatus),
addHeader)
BasicAuthData (..), Capture, CaptureAll, DeleteNoContent,
EmptyAPI, FormUrlEncoded, Fragment, Get, Header, Headers,
JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender),
NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,
QueryParams, Raw, ReqBody, StdMethod (GET), UVerb, Union,
WithStatus (WithStatus), addHeader)
import Servant.Client
import qualified Servant.Client.Core.Auth as Auth
import Servant.Server
@ -109,6 +110,7 @@ type Api =
:<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
:<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
:<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool
:<|> "fragment" :> Fragment String :> Get '[JSON] Person
:<|> "rawSuccess" :> Raw
:<|> "rawSuccessPassHeaders" :> Raw
:<|> "rawFailure" :> Raw
@ -141,6 +143,7 @@ getBody :: Person -> ClientM Person
getQueryParam :: Maybe String -> ClientM Person
getQueryParams :: [String] -> ClientM [Person]
getQueryFlag :: Bool -> ClientM Bool
getFragment :: ClientM Person
getRawSuccess :: HTTP.Method -> ClientM Response
getRawSuccessPassHeaders :: HTTP.Method -> ClientM Response
getRawFailure :: HTTP.Method -> ClientM Response
@ -163,6 +166,7 @@ getRoot
:<|> getQueryParam
:<|> getQueryParams
:<|> getQueryFlag
:<|> getFragment
:<|> getRawSuccess
:<|> getRawSuccessPassHeaders
:<|> getRawFailure
@ -188,6 +192,7 @@ server = serve api (
Nothing -> throwError $ ServerError 400 "missing parameter" "" [])
:<|> (\ names -> return (zipWith Person names [0..]))
:<|> return
:<|> return alice
:<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
:<|> (Tagged $ \ request respond -> (respond $ Wai.responseLBS HTTP.ok200 (Wai.requestHeaders $ request) "rawSuccess"))
:<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")

7
servant-client/test/Servant/SuccessSpec.hs
View file

@ -45,9 +45,10 @@ import Servant.API
(NoContent (NoContent), WithStatus (WithStatus), getHeaders)
import Servant.Client
import qualified Servant.Client.Core.Request as Req
import Servant.Client.Internal.HttpClient (defaultMakeClientRequest)
import Servant.Test.ComprehensiveAPI
import Servant.Client.Internal.HttpClient
(defaultMakeClientRequest)
import Servant.ClientTestUtils
import Servant.Test.ComprehensiveAPI
-- This declaration simply checks that all instances are in place.
_ = client comprehensiveAPIWithoutStreaming
@ -103,6 +104,8 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag
it "Servant.API.Fragment" $ \(_, baseUrl) -> do
left id <$> runClient getFragment baseUrl `shouldReturn` Right alice
it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
case res of

22
servant-docs/golden/comprehensive.md
View file

@ -182,6 +182,28 @@
```
## GET /fragment
### Fragment:
- *foo*: Fragment Int
### Response:
- Status code 200
- Headers: []
- Supported content types are:
- `application/json;charset=utf-8`
- `application/json`
- Example (`application/json;charset=utf-8`, `application/json`):
```javascript
```
## GET /get-int
### Response:

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

@ -25,8 +25,8 @@ import Control.Applicative
import Control.Arrow
(second)
import Control.Lens
(makeLenses, mapped, over, traversed, view, (%~), (&), (.~),
(<>~), (^.), (|>))
(makeLenses, mapped, over, set, traversed, view, (%~), (&),
(.~), (<>~), (^.), (|>))
import qualified Data.ByteString.Char8 as BSC
import Data.ByteString.Lazy.Char8
(ByteString)
@ -161,6 +161,20 @@ data DocQueryParam = DocQueryParam
, _paramKind :: ParamKind
} deriving (Eq, Ord, Show)
-- | A type to represent fragment. Holds the name of the fragment and its description.
--
-- Write a 'ToFragment' instance for your fragment types.
data DocFragment = DocFragment
{ _fragSymbol :: String -- type supplied
, _fragDesc :: String -- user supplied
} deriving (Eq, Ord, Show)
-- | There should be at most one 'Fragment' per API endpoint.
-- So here we are keeping the first occurrence.
combineFragment :: Maybe DocFragment -> Maybe DocFragment -> Maybe DocFragment
Nothing `combineFragment` mdocFragment = mdocFragment
Just docFragment `combineFragment` _ = Just docFragment
-- | An introductory paragraph for your documentation. You can pass these to
-- 'docsWithIntros'.
data DocIntro = DocIntro
@ -283,6 +297,7 @@ data Action = Action
, _captures :: [DocCapture] -- type collected + user supplied info
, _headers :: [Text] -- type collected
, _params :: [DocQueryParam] -- type collected + user supplied info
, _fragment :: Maybe DocFragment -- type collected + user supplied info
, _notes :: [DocNote] -- user supplied
, _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info
, _rqtypes :: [M.MediaType] -- type collected
@ -296,8 +311,9 @@ data Action = Action
-- As such, we invent a non-commutative, left associative operation
-- 'combineAction' to mush two together taking the response from the very left.
combineAction :: Action -> Action -> Action
Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' ts' body' resp' =
Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') (ts <> ts') (body <> body') (resp `combineResponse` resp')
Action a c h p f n m ts body resp
`combineAction` Action a' c' h' p' f' n' m' ts' body' resp' =
Action (a <> a') (c <> c') (h <> h') (p <> p') (f `combineFragment` f') (n <> n') (m <> m') (ts <> ts') (body <> body') (resp `combineResponse` resp')
-- | Default 'Action'. Has no 'captures', no query 'params', expects
-- no request body ('rqbody') and the typical response is 'defResponse'.
@ -305,10 +321,10 @@ Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' ts' bod
-- Tweakable with lenses.
--
-- >>> defAction
-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}}
-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}}
--
-- >>> defAction & response.respStatus .~ 201
-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 201, _respTypes = [], _respBody = [], _respHeaders = []}}
-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 201, _respTypes = [], _respBody = [], _respHeaders = []}}
--
defAction :: Action
defAction =
@ -316,6 +332,7 @@ defAction =
[]
[]
[]
Nothing
[]
[]
[]
@ -368,6 +385,7 @@ makeLenses ''API
makeLenses ''Endpoint
makeLenses ''DocCapture
makeLenses ''DocQueryParam
makeLenses ''DocFragment
makeLenses ''DocIntro
makeLenses ''DocNote
makeLenses ''Response
@ -587,6 +605,15 @@ class ToCapture c where
class ToAuthInfo a where
toAuthInfo :: Proxy a -> DocAuthentication
-- | The class that helps us get documentation for URL fragments.
--
-- Example of an instance:
--
-- > instance ToFragment (Fragment a) where
-- > toFragment _ = DocFragment "fragment" "fragment description"
class ToFragment t where
toFragment :: Proxy t -> DocFragment
-- | Generate documentation in Markdown format for
-- the given 'API'.
--
@ -629,6 +656,7 @@ markdownWith RenderingOptions{..} api = unlines $
capturesStr (action ^. captures) ++
headersStr (action ^. headers) ++
paramsStr meth (action ^. params) ++
fragmentStr (action ^. fragment) ++
rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++
responseStr (action ^. response) ++
[]
@ -730,6 +758,14 @@ markdownWith RenderingOptions{..} api = unlines $
where values = param ^. paramValues
fragmentStr :: Maybe DocFragment -> [String]
fragmentStr Nothing = []
fragmentStr (Just frag) =
[ "### Fragment:", ""
, "- *" ++ (frag ^. fragSymbol) ++ "*: " ++ (frag ^. fragDesc)
, ""
]
rqbodyStr :: [M.MediaType] -> [(Text, M.MediaType, ByteString)]-> [String]
rqbodyStr [] [] = []
rqbodyStr types s =
@ -959,6 +995,15 @@ instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs api)
paramP = Proxy :: Proxy (QueryFlag sym)
action' = over params (|> toParam paramP) action
instance (ToFragment (Fragment a), HasDocs api)
=> HasDocs (Fragment a :> api) where
docsFor Proxy (endpoint, action) =
docsFor subApiP (endpoint, action')
where subApiP = Proxy :: Proxy api
fragmentP = Proxy :: Proxy (Fragment a)
action' = set fragment (Just (toFragment fragmentP)) action
instance HasDocs Raw where
docsFor _proxy (endpoint, action) _ =

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

@ -58,6 +58,8 @@ instance ToCapture (Capture "foo" Int) where
toCapture _ = DocCapture "foo" "Capture foo Int"
instance ToCapture (CaptureAll "foo" Int) where
toCapture _ = DocCapture "foo" "Capture all foo Int"
instance ToFragment (Fragment Int) where
toFragment _ = DocFragment "foo" "Fragment Int"
-- * specs

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

@ -84,6 +84,11 @@ captureArg _ = error "captureArg called on non capture"
type Path f = [Segment f]
newtype Frag f = Frag { unFragment :: Arg f }
deriving (Data, Eq, Show, Typeable)
makePrisms ''Frag
data ArgType
= Normal
| Flag
@ -115,11 +120,12 @@ makePrisms ''HeaderArg
data Url f = Url
{ _path :: Path f
, _queryStr :: [QueryArg f]
, _frag :: Maybe f
}
deriving (Data, Eq, Show, Typeable)
defUrl :: Url f
defUrl = Url [] []
defUrl = Url [] [] Nothing
makeLenses ''Url
@ -324,6 +330,16 @@ instance
{ _argName = PathSegment str
, _argType = typeFor lang ftype (Proxy :: Proxy Bool) }
instance
(HasForeignType lang ftype (Maybe a), HasForeign lang ftype api)
=> HasForeign lang ftype (Fragment a :> api) where
type Foreign ftype (Fragment a :> api) = Foreign ftype api
foreignFor lang Proxy Proxy req =
foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy api) $
req & reqUrl . frag .~ Just argT
where
argT = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy (Maybe a))
instance HasForeign lang ftype Raw where
type Foreign ftype Raw = HTTP.Method -> Req ftype

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

@ -14,8 +14,8 @@ module Servant.ForeignSpec where
import Data.Monoid
((<>))
import Data.Proxy
import Servant.Test.ComprehensiveAPI
import Servant.Foreign
import Servant.Test.ComprehensiveAPI
import Servant.Types.SourceT
(SourceT)
@ -91,6 +91,7 @@ listFromAPISpec = describe "listFromAPI" $ do
{ _reqUrl = Url
[ Segment $ Static "test" ]
[ QueryArg (Arg "flag" "boolX") Flag ]
Nothing
, _reqMethod = "GET"
, _reqHeaders = [HeaderArg $ Arg "header" "maybe listX of stringX"]
, _reqBody = Nothing
@ -103,6 +104,7 @@ listFromAPISpec = describe "listFromAPI" $ do
{ _reqUrl = Url
[ Segment $ Static "test" ]
[ QueryArg (Arg "param" "maybe intX") Normal ]
Nothing
, _reqMethod = "POST"
, _reqHeaders = []
, _reqBody = Just "listX of stringX"
@ -116,6 +118,7 @@ listFromAPISpec = describe "listFromAPI" $ do
[ Segment $ Static "test" ]
-- Should this be |intX| or |listX of intX| ?
[ QueryArg (Arg "params" "listX of intX") List ]
Nothing
, _reqMethod = "PUT"
, _reqHeaders = []
, _reqBody = Just "stringX"
@ -129,6 +132,7 @@ listFromAPISpec = describe "listFromAPI" $ do
[ Segment $ Static "test"
, Segment $ Cap (Arg "id" "intX") ]
[]
Nothing
, _reqMethod = "DELETE"
, _reqHeaders = []
, _reqBody = Nothing
@ -142,6 +146,7 @@ listFromAPISpec = describe "listFromAPI" $ do
[ Segment $ Static "test"
, Segment $ Cap (Arg "ids" "listX of intX") ]
[]
Nothing
, _reqMethod = "GET"
, _reqHeaders = []
, _reqBody = Nothing

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

@ -71,17 +71,17 @@ import Prelude ()
import Prelude.Compat
import Servant.API
((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',
CaptureAll, Description, EmptyAPI, FramingRender (..),
FramingUnrender (..), FromSourceIO (..), Header', If,
IsSecure (..), QueryFlag, QueryParam', QueryParams, Raw,
ReflectMethod (reflectMethod), RemoteHost, ReqBody',
SBool (..), SBoolI (..), SourceIO, Stream, StreamBody',
Summary, ToSourceIO (..), Vault, Verb, NoContentVerb,
CaptureAll, Description, EmptyAPI, Fragment,
FramingRender (..), FramingUnrender (..), FromSourceIO (..),
Header', If, IsSecure (..), NoContentVerb, QueryFlag,
QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),
RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
WithNamedContext)
import Servant.API.ContentTypes
(AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
AllMime, MimeRender (..), MimeUnrender (..), canHandleAcceptH,
NoContent)
AllMime, MimeRender (..), MimeUnrender (..), NoContent,
canHandleAcceptH)
import Servant.API.Modifiers
(FoldLenient, FoldRequired, RequestArgument,
unfoldRequestArgument)
@ -89,8 +89,8 @@ import Servant.API.ResponseHeaders
(GetHeaders, Headers, getHeaders, getResponse)
import qualified Servant.Types.SourceT as S
import Web.HttpApiData
(FromHttpApiData, parseHeader, parseQueryParam,
parseUrlPieces, parseUrlPiece)
(FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
parseUrlPieces)
import Servant.Server.Internal.BasicAuth
import Servant.Server.Internal.Context
@ -106,6 +106,8 @@ import Servant.Server.Internal.ServerError
#ifdef HAS_TYPE_ERROR
import GHC.TypeLits
(ErrorMessage (..), TypeError)
import Servant.API.TypeLevel
(AtLeastOneFragment, FragmentUnique)
#endif
class HasServer api context where
@ -880,5 +882,28 @@ type HasServerArrowTypeError a b =
':$$: 'ShowType b
#endif
-- | Ignore @'Fragment'@ in server handlers.
-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
--
-- Example:
--
-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
-- >
-- > server :: Server MyApi
-- > server = getBooksBy
-- > where getBooksBy :: Handler [Book]
-- > getBooksBy = ...return all books...
#ifdef HAS_TYPE_ERROR
instance (AtLeastOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer api context)
#else
instance (HasServer api context)
#endif
=> HasServer (Fragment a1 :> api) context where
type ServerT (Fragment a1 :> api) m = ServerT api m
route _ = route (Proxy :: Proxy api)
hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api)
-- $setup
-- >>> import Servant

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

@ -48,12 +48,12 @@ import Network.Wai.Test
import Servant.API
((:<|>) (..), (:>), AuthProtect, BasicAuth,
BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,
Delete, EmptyAPI, Get, HasStatus(StatusOf), Header, Headers,
HttpVersion, IsSecure (..), JSON, Lenient, NoContent (..),
NoContentVerb, NoFraming, OctetStream, Patch, PlainText, Post,
Put, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost,
ReqBody, SourceIO, StdMethod (..), Stream, Strict, Union,
UVerb, Verb, addHeader)
Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,
Headers, HttpVersion, IsSecure (..), JSON, Lenient,
NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,
PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,
RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,
UVerb, Union, Verb, addHeader)
import Servant.Server
(Context ((:.), EmptyContext), Handler, Server, Tagged (..),
emptyServer, err401, err403, err404, respond, serve,
@ -92,6 +92,7 @@ spec = do
captureSpec
captureAllSpec
queryParamSpec
fragmentSpec
reqBodySpec
headerSpec
rawSpec
@ -461,6 +462,37 @@ queryParamSpec = do
{ name = "Alice"
}
-- }}}
------------------------------------------------------------------------------
-- * fragmentSpec {{{
------------------------------------------------------------------------------
type FragmentApi = "name" :> Fragment String :> Get '[JSON] Person
:<|> "age" :> Fragment Integer :> Get '[JSON] Person
fragmentApi :: Proxy FragmentApi
fragmentApi = Proxy
fragServer :: Server FragmentApi
fragServer = fragmentServer :<|> fragAge
where
fragmentServer = return alice
fragAge = return alice
fragmentSpec :: Spec
fragmentSpec = do
let mkRequest params pinfo = Network.Wai.Test.request defaultRequest
{ rawQueryString = params
, queryString = parseQuery params
, pathInfo = pinfo
}
describe "Servant.API.Fragment" $ do
it "ignores fragment even if it is present in query" $ do
flip runSession (serve fragmentApi fragServer) $ do
response1 <- mkRequest "#Alice" ["name"]
liftIO $ decode' (simpleBody response1) `shouldBe` Just alice
-- }}}
------------------------------------------------------------------------------
-- * reqBodySpec {{{

1
servant/servant.cabal
View file

@ -40,6 +40,7 @@ library
Servant.API.Description
Servant.API.Empty
Servant.API.Experimental.Auth
Servant.API.Fragment
Servant.API.Generic
Servant.API.Header
Servant.API.HttpVersion

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

@ -19,6 +19,8 @@ module Servant.API (
-- | Retrieving the HTTP version of the request
module Servant.API.QueryParam,
-- | Retrieving parameters from the query string of the 'URI': @'QueryParam'@
module Servant.API.Fragment,
-- | Documenting the fragment of the 'URI': @'Fragment'@
module Servant.API.ReqBody,
-- | Accessing the request body as a JSON-encoded type: @'ReqBody'@
module Servant.API.RemoteHost,
@ -93,6 +95,8 @@ import Servant.API.Empty
(EmptyAPI (..))
import Servant.API.Experimental.Auth
(AuthProtect)
import Servant.API.Fragment
(Fragment)
import Servant.API.Header
(Header, Header')
import Servant.API.HttpVersion
@ -121,21 +125,20 @@ import Servant.API.Stream
ToSourceIO (..))
import Servant.API.Sub
((:>))
import Servant.API.UVerb
(HasStatus, IsMember, StatusOf, Statuses, UVerb, Union,
Unique, WithStatus (..), inject, statusOf)
import Servant.API.Vault
(Vault)
import Servant.API.Verbs
(Delete, DeleteAccepted, DeleteNoContent,
DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,
GetNonAuthoritative, GetPartialContent, GetResetContent,
Patch, PatchAccepted, PatchNoContent, PatchNonAuthoritative,
Post, PostAccepted, PostCreated, PostNoContent,
PostNonAuthoritative, PostResetContent, Put, PutAccepted,
PutCreated, PutNoContent, PutNonAuthoritative,
ReflectMethod (reflectMethod), StdMethod (..),
Verb, NoContentVerb)
import Servant.API.UVerb
(UVerb, Union, HasStatus, StatusOf, statusOf, Statuses,
WithStatus (..), IsMember, Unique, inject)
NoContentVerb, Patch, PatchAccepted, PatchNoContent,
PatchNonAuthoritative, Post, PostAccepted, PostCreated,
PostNoContent, PostNonAuthoritative, PostResetContent, Put,
PutAccepted, PutCreated, PutNoContent, PutNonAuthoritative,
ReflectMethod (reflectMethod), StdMethod (..), Verb)
import Servant.API.WithNamedContext
(WithNamedContext)
import Servant.Links

25
servant/src/Servant/API/Fragment.hs Normal file
View file

@ -0,0 +1,25 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Fragment (Fragment) where
import Data.Typeable
(Typeable)
-- | Document the URI fragment in API. Useful in combination with 'Link'.
--
-- Example:
--
-- >>> -- /post#TRACKING
-- >>> type MyApi = "post" :> Fragment Text :> Get '[JSON] Tracking
data Fragment (a :: *)
deriving Typeable
-- $setup
-- >>> import Servant.API
-- >>> import Data.Aeson
-- >>> import Data.Text
-- >>> data Tracking
-- >>> instance ToJSON Tracking where { toJSON = undefined }

2
servant/src/Servant/API/Modifiers.hs
View file

@ -131,8 +131,6 @@ type RequestArgument mods a =
(If (FoldLenient mods) (Either Text a) a)
(Maybe (If (FoldLenient mods) (Either Text a) a))
-- | Unfold a value into a 'RequestArgument'.
unfoldRequestArgument
:: forall mods m a. (Monad m, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods))

50
servant/src/Servant/API/TypeLevel.hs
View file

@ -1,12 +1,16 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-|
This module collects utilities for manipulating @servant@ API types. The
@ -41,6 +45,9 @@ module Servant.API.TypeLevel (
-- ** Logic
Or,
And,
-- ** Fragment
FragmentUnique,
AtLeastOneFragment
) where
@ -50,6 +57,7 @@ import Servant.API.Alternative
(type (:<|>))
import Servant.API.Capture
(Capture, CaptureAll)
import Servant.API.Fragment
import Servant.API.Header
(Header)
import Servant.API.QueryParam
@ -60,6 +68,8 @@ import Servant.API.Sub
(type (:>))
import Servant.API.Verbs
(Verb)
import Servant.API.UVerb
(UVerb)
import GHC.TypeLits
(ErrorMessage (..), TypeError)
@ -128,6 +138,7 @@ type family IsElem endpoint api :: Constraint where
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
IsElem sa (Fragment x :> sb) = IsElem sa sb
IsElem (Verb m s ct typ) (Verb m s ct' typ)
= IsSubList ct ct'
IsElem e e = ()
@ -241,6 +252,43 @@ We might try to factor these our more cleanly, but the type synonyms and type
families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048).
-}
-- ** Fragment
class FragmentUnique api => AtLeastOneFragment api
-- | If fragment appeared in API endpoint twice, compile-time error would be raised.
--
-- >>> -- type FailAPI = Fragment Bool :> Fragment Int :> Get '[JSON] NoContent
-- >>> instance AtLeastOneFragment FailAPI
-- ...
-- ...Only one Fragment allowed per endpoint in api...
-- ...
-- ...In the instance declaration for...
instance AtLeastOneFragment (Verb m s ct typ)
instance AtLeastOneFragment (UVerb m cts as)
instance AtLeastOneFragment (Fragment a)
type family FragmentUnique api :: Constraint where
FragmentUnique (sa :<|> sb) = And (FragmentUnique sa) (FragmentUnique sb)
FragmentUnique (Fragment a :> sa) = FragmentNotIn sa (Fragment a :> sa)
FragmentUnique (x :> sa) = FragmentUnique sa
FragmentUnique (Fragment a) = ()
FragmentUnique x = ()
type family FragmentNotIn api orig :: Constraint where
FragmentNotIn (sa :<|> sb) orig =
And (FragmentNotIn sa orig) (FragmentNotIn sb orig)
FragmentNotIn (Fragment c :> sa) orig = TypeError (NotUniqueFragmentInApi orig)
FragmentNotIn (x :> sa) orig = FragmentNotIn sa orig
FragmentNotIn (Fragment c) orig = TypeError (NotUniqueFragmentInApi orig)
FragmentNotIn x orig = ()
type NotUniqueFragmentInApi api =
'Text "Only one Fragment allowed per endpoint in api ‘"
':<>: 'ShowType api
':<>: 'Text "’."
-- $setup
--
@ -248,6 +296,7 @@ families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048).
--
-- >>> :set -XPolyKinds
-- >>> :set -XGADTs
-- >>> :set -XTypeSynonymInstances -XFlexibleInstances
-- >>> import Data.Proxy
-- >>> import Data.Type.Equality
-- >>> import Servant.API
@ -255,4 +304,5 @@ families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048).
-- >>> instance Show (OK ctx) where show _ = "OK"
-- >>> let ok :: ctx => Proxy ctx -> OK ctx; ok _ = OK
-- >>> type SampleAPI = "hello" :> Get '[JSON] Int :<|> "bye" :> Capture "name" String :> Post '[JSON, PlainText] Bool
-- >>> type FailAPI = Fragment Bool :> Fragment Int :> Get '[JSON] NoContent
-- >>> let sampleAPI = Proxy :: Proxy SampleAPI

36
servant/src/Servant/Links.hs
View file

@ -120,6 +120,7 @@ module Servant.Links (
, Param (..)
, linkSegments
, linkQueryParams
, linkFragment
) where
import Data.List
@ -152,6 +153,8 @@ import Servant.API.Empty
(EmptyAPI (..))
import Servant.API.Experimental.Auth
(AuthProtect)
import Servant.API.Fragment
(Fragment)
import Servant.API.Generic
import Servant.API.Header
(Header')
@ -188,10 +191,13 @@ import Web.HttpApiData
data Link = Link
{ _segments :: [Escaped]
, _queryParams :: [Param]
, _fragment :: Fragment'
} deriving Show
newtype Escaped = Escaped String
type Fragment' = Maybe String
escaped :: String -> Escaped
escaped = Escaped . escapeURIString isUnreserved
@ -208,11 +214,14 @@ linkSegments = map getEscaped . _segments
linkQueryParams :: Link -> [Param]
linkQueryParams = _queryParams
linkFragment :: Link -> Fragment'
linkFragment = _fragment
instance ToHttpApiData Link where
toHeader = TE.encodeUtf8 . toUrlPiece
toUrlPiece l =
let uri = linkURI l
in Text.pack $ uriPath uri ++ uriQuery uri
in Text.pack $ uriPath uri ++ uriQuery uri ++ uriFragment uri
-- | Query parameter.
data Param
@ -228,6 +237,9 @@ addQueryParam :: Param -> Link -> Link
addQueryParam qp l =
l { _queryParams = _queryParams l <> [qp] }
addFragment :: Fragment' -> Link -> Link
addFragment fr l = l { _fragment = fr }
-- | Transform 'Link' into 'URI'.
--
-- >>> type API = "something" :> Get '[JSON] Int
@ -245,7 +257,7 @@ addQueryParam qp l =
-- >>> type SomeRoute = "abc" :> Capture "email" String :> Put '[JSON] ()
-- >>> let someRoute = Proxy :: Proxy SomeRoute
-- >>> safeLink someRoute someRoute "test@example.com"
-- Link {_segments = ["abc","test%40example.com"], _queryParams = []}
-- Link {_segments = ["abc","test%40example.com"], _queryParams = [], _fragment = Nothing}
--
-- >>> linkURI $ safeLink someRoute someRoute "test@example.com"
-- abc/test%40example.com
@ -269,11 +281,12 @@ data LinkArrayElementStyle
-- sum?x=1&x=2&x=3
--
linkURI' :: LinkArrayElementStyle -> Link -> URI
linkURI' addBrackets (Link segments q_params) =
linkURI' addBrackets (Link segments q_params mfragment) =
URI mempty -- No scheme (relative)
Nothing -- Or authority (relative)
(intercalate "/" $ map getEscaped segments)
(makeQueries q_params) mempty
(makeQueries q_params)
(makeFragment mfragment)
where
makeQueries :: [Param] -> String
makeQueries [] = ""
@ -285,6 +298,10 @@ linkURI' addBrackets (Link segments q_params) =
makeQuery (SingleParam k v) = escape k <> "=" <> escape (Text.unpack v)
makeQuery (FlagParam k) = escape k
makeFragment :: Fragment' -> String
makeFragment Nothing = ""
makeFragment (Just fr) = "#" <> escape fr
style = case addBrackets of
LinkArrayElementBracket -> "[]="
LinkArrayElementPlain -> "="
@ -310,7 +327,7 @@ safeLink'
-> Proxy api -- ^ The whole API that this endpoint is a part of
-> Proxy endpoint -- ^ The API endpoint you would like to point to
-> MkLink endpoint a
safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty)
safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty mempty)
-- | Create all links in an API.
--
@ -341,7 +358,7 @@ allLinks'
=> (Link -> a)
-> Proxy api
-> MkLink api a
allLinks' toA api = toLink toA api (Link mempty mempty)
allLinks' toA api = toLink toA api (Link mempty mempty mempty)
-------------------------------------------------------------------------------
-- Generics
@ -563,6 +580,13 @@ instance HasLink sub => HasLink (AuthProtect tag :> sub) where
type MkLink (AuthProtect tag :> sub) a = MkLink sub a
toLink = simpleToLink (Proxy :: Proxy sub)
instance (HasLink sub, ToHttpApiData v)
=> HasLink (Fragment v :> sub) where
type MkLink (Fragment v :> sub) a = v -> MkLink sub a
toLink toA _ l mv =
toLink toA (Proxy :: Proxy sub) $
addFragment ((Just . Text.unpack . toQueryParam) mv) l
-- | Helper for implementing 'toLink' for combinators not affecting link
-- structure.
simpleToLink

1
servant/src/Servant/Test/ComprehensiveAPI.hs
View file

@ -71,6 +71,7 @@ type ComprehensiveAPIWithoutStreamingOrRaw' endpoint =
:<|> "summary" :> Summary "foo" :> GET
:<|> "description" :> Description "foo" :> GET
:<|> "alternative" :> ("left" :> GET :<|> "right" :> GET)
:<|> "fragment" :> Fragment Int :> GET
:<|> endpoint
type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint

9
servant/test/Servant/LinksSpec.hs
View file

@ -13,9 +13,9 @@ import Test.Hspec
(Expectation, Spec, describe, it, shouldBe)
import Servant.API
import Servant.Links
import Servant.Test.ComprehensiveAPI
(comprehensiveAPIWithoutRaw)
import Servant.Links
type TestApi =
-- Capture and query params
@ -26,6 +26,9 @@ type TestApi =
-- Flags
:<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] NoContent
-- Fragment
:<|> "say" :> Fragment String :> Get '[JSON] NoContent
-- All of the verbs
:<|> "get" :> Get '[JSON] NoContent
:<|> "put" :> Put '[JSON] NoContent
@ -76,6 +79,10 @@ spec = describe "Servant.Links" $ do
apiLink l1 True True `shouldBeLink` "balls?bouncy&fast"
apiLink l1 False True `shouldBeLink` "balls?fast"
it "generates correct link for fragment" $ do
let l1 = Proxy :: Proxy ("say" :> Fragment String :> Get '[JSON] NoContent)
apiLink l1 "something" `shouldBeLink` "say#something"
it "generates correct links for all of the verbs" $ do
apiLink (Proxy :: Proxy ("get" :> Get '[JSON] NoContent)) `shouldBeLink` "get"
apiLink (Proxy :: Proxy ("put" :> Put '[JSON] NoContent)) `shouldBeLink` "put"