Add URI fragment as a separate combinator (#1324)
This commit is contained in:
Andrey Prokopenko
GitHub
parent
339eec6a90
commit
da0c83d318
19 changed files with 418 additions and 120 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,18 +1,18 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -freduction-depth=100 #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||
|
|
@ -27,20 +27,22 @@ import Control.Concurrent
|
|||
import Control.Monad.Error.Class
|
||||
(throwError)
|
||||
import Data.Aeson
|
||||
import qualified Data.ByteString.Lazy as LazyByteString
|
||||
import qualified Data.ByteString.Lazy as LazyByteString
|
||||
import Data.Char
|
||||
(chr, isPrint)
|
||||
import Data.Monoid ()
|
||||
import Data.Proxy
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
|
||||
import Data.Text
|
||||
(Text)
|
||||
import qualified Data.Text as Text
|
||||
import Data.Text.Encoding
|
||||
(decodeUtf8, encodeUtf8)
|
||||
import GHC.Generics
|
||||
(Generic)
|
||||
import qualified Network.HTTP.Client as C
|
||||
import qualified Network.HTTP.Types as HTTP
|
||||
import qualified Network.HTTP.Client as C
|
||||
import qualified Network.HTTP.Types as HTTP
|
||||
import Network.Socket
|
||||
import qualified Network.Wai as Wai
|
||||
import qualified Network.Wai as Wai
|
||||
import Network.Wai.Handler.Warp
|
||||
import System.IO.Unsafe
|
||||
(unsafePerformIO)
|
||||
|
|
@ -50,15 +52,14 @@ 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 qualified Servant.Client.Core.Auth as Auth
|
||||
import Servant.Server
|
||||
import Servant.Server.Experimental.Auth
|
||||
import Servant.Test.ComprehensiveAPI
|
||||
|
|
@ -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")
|
||||
|
|
|
|||
|
|
@ -1,17 +1,17 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -freduction-depth=100 #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||
|
|
@ -34,20 +34,21 @@ import Data.Maybe
|
|||
import Data.Monoid ()
|
||||
import Data.Text
|
||||
(Text)
|
||||
import qualified Network.HTTP.Client as C
|
||||
import qualified Network.HTTP.Types as HTTP
|
||||
import qualified Network.HTTP.Client as C
|
||||
import qualified Network.HTTP.Types as HTTP
|
||||
import Test.Hspec
|
||||
import Test.Hspec.QuickCheck
|
||||
import Test.HUnit
|
||||
import Test.QuickCheck
|
||||
|
||||
import Servant.API
|
||||
(NoContent (NoContent), WithStatus(WithStatus), getHeaders)
|
||||
(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 qualified Servant.Client.Core.Request as Req
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -64,7 +64,7 @@ import Servant.API
|
|||
import Servant.API.ContentTypes
|
||||
import Servant.API.TypeLevel
|
||||
|
||||
import qualified Data.Universe.Helpers as U
|
||||
import qualified Data.Universe.Helpers as U
|
||||
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.Text as T
|
||||
|
|
@ -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) _ =
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ module Servant.Server.Internal.RoutingApplicationSpec (spec) where
|
|||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Control.Exception hiding
|
||||
import Control.Exception hiding
|
||||
(Handler)
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Resource
|
||||
|
|
@ -28,7 +28,7 @@ import Test.Hspec
|
|||
import Test.Hspec.Wai
|
||||
(request, shouldRespondWith, with)
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text as T
|
||||
|
||||
import System.IO.Unsafe
|
||||
(unsafePerformIO)
|
||||
|
|
|
|||
|
|
@ -1,12 +1,12 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# OPTIONS_GHC -freduction-depth=100 #-}
|
||||
|
||||
module Servant.ServerSpec where
|
||||
|
|
@ -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 {{{
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
25
servant/src/Servant/API/Fragment.hs
Normal 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 }
|
||||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -1,12 +1,16 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
Loading…
Reference in a new issue