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

Merge pull request #873 from phadej/modifiers

Browse source 
Servant.API.Modifiers
This commit is contained in:
Oleg Grenrus 2018-01-25 11:12:14 +02:00 committed by GitHub
commit bf289ccd59
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
18 changed files with 421 additions and 148 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -25,7 +25,7 @@ import Data.Monoid ((<>))
import Data.Proxy (Proxy (Proxy))
import Data.Sequence (fromList)
import Data.String (fromString)
import Data.Text (pack)
import Data.Text (Text, pack)
import GHC.TypeLits (KnownSymbol, symbolVal)
import qualified Network.HTTP.Types as H
import Servant.API ((:<|>) ((:<|>)), (:>),
@ -37,16 +37,17 @@ import Servant.API ((:<|>) ((:<|>)), (:>),
Capture, CaptureAll,
Description, EmptyAPI,
FramingUnrender (..),
Header, Headers (..),
Header', Headers (..),
HttpVersion, IsSecure,
MimeRender (mimeRender),
MimeUnrender (mimeUnrender),
NoContent (NoContent),
QueryFlag, QueryParam,
QueryFlag, QueryParam',
QueryParams, Raw,
ReflectMethod (..),
RemoteHost, ReqBody,
RemoteHost, ReqBody',
ResultStream(..),
SBoolI,
Stream,
Summary, ToHttpApiData,
Vault, Verb,
@ -57,6 +58,9 @@ import Servant.API ((:<|>) ((:<|>)), (:>),
toQueryParam,
toUrlPiece)
import Servant.API.ContentTypes (contentTypes)
import Servant.API.Modifiers (FoldRequired,
RequiredArgument,
foldRequiredArgument)
import Servant.Client.Core.Internal.Auth
import Servant.Client.Core.Internal.BasicAuth
@ -325,20 +329,20 @@ instance OVERLAPPABLE_
-- > viewReferer = client myApi
-- > -- then you can just use "viewRefer" to query that endpoint
-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
=> HasClient m (Header sym a :> api) where
instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods))
=> HasClient m (Header' mods sym a :> api) where
type Client m (Header sym a :> api) =
Maybe a -> Client m api
type Client m (Header' mods sym a :> api) =
RequiredArgument mods a -> Client m api
clientWithRoute pm Proxy req mval =
clientWithRoute pm (Proxy :: Proxy api)
(maybe req
(\value -> addHeader hname value req)
mval
)
clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument
(Proxy :: Proxy mods) add (maybe req add) mval
where
hname = fromString $ symbolVal (Proxy :: Proxy sym)
where hname = fromString $ symbolVal (Proxy :: Proxy sym)
add :: a -> Request
add value = addHeader hname value req
-- | Using a 'HttpVersion' combinator in your API doesn't affect the client
-- functions.
@ -388,22 +392,22 @@ instance HasClient m api => HasClient m (Description desc :> api) where
-- > -- 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
instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
=> HasClient m (QueryParam sym a :> api) where
instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods))
=> HasClient m (QueryParam' mods sym a :> api) where
type Client m (QueryParam sym a :> api) =
Maybe a -> Client m api
type Client m (QueryParam' mods sym a :> api) =
RequiredArgument mods a -> Client m api
-- if mparam = Nothing, we don't add it to the query string
clientWithRoute pm Proxy req mparam =
clientWithRoute pm (Proxy :: Proxy api)
(maybe req
(flip (appendToQueryString pname) req . Just)
mparamText
)
clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument
(Proxy :: Proxy mods) add (maybe req add) mparam
where
add :: a -> Request
add param = appendToQueryString pname (Just $ toQueryParam param) req
where pname = pack $ symbolVal (Proxy :: Proxy sym)
mparamText = fmap toQueryParam mparam
pname :: Text
pname = pack $ symbolVal (Proxy :: Proxy sym)
-- | If you use a 'QueryParams' in one of your endpoints in your API,
-- the corresponding querying function will automatically take
@ -514,9 +518,9 @@ instance RunClient m => HasClient m Raw where
-- > addBook = client myApi
-- > -- then you can just use "addBook" to query that endpoint
instance (MimeRender ct a, HasClient m api)
=> HasClient m (ReqBody (ct ': cts) a :> api) where
=> HasClient m (ReqBody' mods (ct ': cts) a :> api) where
type Client m (ReqBody (ct ': cts) a :> api) =
type Client m (ReqBody' mods (ct ': cts) a :> api) =
a -> Client m api
clientWithRoute pm Proxy req body =

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

@ -534,7 +534,7 @@ sampleByteStrings ctypes@Proxy Proxy =
--
-- Example of an instance:
--
-- > instance ToParam (QueryParam "capital" Bool) where
-- > instance ToParam (QueryParam' mods "capital" Bool) where
-- > toParam _ =
-- > DocQueryParam "capital"
-- > ["true", "false"]
@ -859,7 +859,7 @@ instance OVERLAPPING_
p = Proxy :: Proxy a
instance (KnownSymbol sym, HasDocs api)
=> HasDocs (Header sym a :> api) where
=> HasDocs (Header' mods sym a :> api) where
docsFor Proxy (endpoint, action) =
docsFor subApiP (endpoint, action')
@ -867,14 +867,14 @@ instance (KnownSymbol sym, HasDocs api)
action' = over headers (|> headername) action
headername = T.pack $ symbolVal (Proxy :: Proxy sym)
instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs api)
=> HasDocs (QueryParam sym a :> api) where
instance (KnownSymbol sym, ToParam (QueryParam' mods sym a), HasDocs api)
=> HasDocs (QueryParam' mods sym a :> api) where
docsFor Proxy (endpoint, action) =
docsFor subApiP (endpoint, action')
where subApiP = Proxy :: Proxy api
paramP = Proxy :: Proxy (QueryParam sym a)
paramP = Proxy :: Proxy (QueryParam' mods sym a)
action' = over params (|> toParam paramP) action
instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs api)
@ -929,7 +929,7 @@ instance (KnownSymbol desc, HasDocs api)
-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
-- both are even defined) for any particular type.
instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api)
=> HasDocs (ReqBody (ct ': cts) a :> api) where
=> HasDocs (ReqBody' mods (ct ': cts) a :> api) where
docsFor Proxy (endpoint, action) opts@DocOptions{..} =
docsFor subApiP (endpoint, action') opts

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

@ -33,7 +33,9 @@ import Servant.Docs.Internal
-- This declaration simply checks that all instances are in place.
_ = docs comprehensiveAPI
instance ToParam (QueryParam "foo" Int) where
instance ToParam (QueryParam' mods "foo" Int) where
toParam = error "unused"
instance ToParam (QueryParam' mods "bar" Int) where
toParam = error "unused"
instance ToParam (QueryParams "foo" Int) where
toParam = error "unused"

9
servant-foreign/servant-foreign.cabal
View file

@ -36,10 +36,11 @@ library
exposed-modules: Servant.Foreign
, Servant.Foreign.Internal
, Servant.Foreign.Inflections
build-depends: base == 4.*
, lens == 4.*
, servant == 0.12.*
, text >= 1.2 && < 1.3
build-depends: base >= 4.7 && <4.11
, base-compat >= 0.9.3 && <0.10
, lens == 4.*
, servant == 0.12.*
, text >= 1.2 && < 1.3
, http-types
hs-source-dirs: src
default-language: Haskell2010

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

@ -20,12 +20,12 @@
-- arbitrary programming languages.
module Servant.Foreign.Internal where
import Prelude ()
import Prelude.Compat
import Control.Lens (makePrisms, makeLenses, Getter, (&), (<>~), (%~),
(.~))
import Data.Data (Data)
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
#endif
import Data.Proxy
import Data.String
import Data.Text
@ -33,10 +33,9 @@ import Data.Typeable (Typeable)
import Data.Text.Encoding (decodeUtf8)
import GHC.TypeLits
import qualified Network.HTTP.Types as HTTP
import Prelude hiding (concat)
import Servant.API
import Servant.API.TypeLevel
import Servant.API.Modifiers (RequiredArgument)
newtype FunctionName = FunctionName { unFunctionName :: [Text] }
deriving (Data, Show, Eq, Monoid, Typeable)
@ -238,9 +237,9 @@ instance (Elem JSON list, HasForeignType lang ftype a, ReflectMethod method)
method = reflectMethod (Proxy :: Proxy method)
methodLC = toLower $ decodeUtf8 method
instance (KnownSymbol sym, HasForeignType lang ftype (Maybe a), HasForeign lang ftype api)
=> HasForeign lang ftype (Header sym a :> api) where
type Foreign ftype (Header sym a :> api) = Foreign ftype api
instance (KnownSymbol sym, HasForeignType lang ftype (RequiredArgument mods a), HasForeign lang ftype api)
=> HasForeign lang ftype (Header' mods sym a :> api) where
type Foreign ftype (Header' mods sym a :> api) = Foreign ftype api
foreignFor lang Proxy Proxy req =
foreignFor lang Proxy subP $ req & reqHeaders <>~ [HeaderArg arg]
@ -248,12 +247,12 @@ instance (KnownSymbol sym, HasForeignType lang ftype (Maybe a), HasForeign lang
hname = pack . symbolVal $ (Proxy :: Proxy sym)
arg = Arg
{ _argName = PathSegment hname
, _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy (Maybe a)) }
, _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy (RequiredArgument mods a)) }
subP = Proxy :: Proxy api
instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype api)
=> HasForeign lang ftype (QueryParam sym a :> api) where
type Foreign ftype (QueryParam sym a :> api) = Foreign ftype api
instance (KnownSymbol sym, HasForeignType lang ftype (RequiredArgument mods a), HasForeign lang ftype api)
=> HasForeign lang ftype (QueryParam' mods sym a :> api) where
type Foreign ftype (QueryParam' mods sym a :> api) = Foreign ftype api
foreignFor lang Proxy Proxy req =
foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy api) $
@ -262,7 +261,7 @@ instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype ap
str = pack . symbolVal $ (Proxy :: Proxy sym)
arg = Arg
{ _argName = PathSegment str
, _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a) }
, _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy (RequiredArgument mods a)) }
instance
(KnownSymbol sym, HasForeignType lang ftype [a], HasForeign lang ftype api)
@ -299,8 +298,8 @@ instance HasForeign lang ftype Raw where
& reqMethod .~ method
instance (Elem JSON list, HasForeignType lang ftype a, HasForeign lang ftype api)
=> HasForeign lang ftype (ReqBody list a :> api) where
type Foreign ftype (ReqBody list a :> api) = Foreign ftype api
=> HasForeign lang ftype (ReqBody' mods list a :> api) where
type Foreign ftype (ReqBody' mods list a :> api) = Foreign ftype api
foreignFor lang ftype Proxy req =
foreignFor lang ftype (Proxy :: Proxy api) $

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

@ -7,9 +7,11 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
#if __GLASGOW__HASKELL < 709
{-# OPTIONS_GHC -fcontext-stack=41 #-}
#endif
#include "overlapping-compat.h"
module Servant.ForeignSpec where
@ -99,7 +101,7 @@ listFromAPISpec = describe "listFromAPI" $ do
shouldBe postReq $ defReq
{ _reqUrl = Url
[ Segment $ Static "test" ]
[ QueryArg (Arg "param" "intX") Normal ]
[ QueryArg (Arg "param" "maybe intX") Normal ]
, _reqMethod = "POST"
, _reqHeaders = []
, _reqBody = Just "listX of stringX"

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

@ -12,6 +12,7 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
#define HAS_TYPE_ERROR
@ -33,7 +34,7 @@ module Servant.Server.Internal
, module Servant.Server.Internal.ServantErr
) where
import Control.Monad (when)
import Control.Monad (join, when)
import Control.Monad.Trans (liftIO)
import Control.Monad.Trans.Resource (runResourceT)
import qualified Data.ByteString as B
@ -43,7 +44,7 @@ import qualified Data.ByteString.Lazy as BL
import Data.Maybe (fromMaybe, mapMaybe,
isNothing, maybeToList)
import Data.Either (partitionEithers)
import Data.String (fromString)
import Data.String (IsString (..))
import Data.String.Conversions (cs, (<>))
import Data.Tagged (Tagged(..), retag, untag)
import qualified Data.Text as T
@ -69,15 +70,17 @@ import Web.HttpApiData (FromHttpApiData, parseHeader,
import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture,
CaptureAll, Verb, EmptyAPI,
ReflectMethod(reflectMethod),
IsSecure(..), Header, QueryFlag,
QueryParam, QueryParams, Raw,
RemoteHost, ReqBody, Vault,
IsSecure(..), Header', QueryFlag,
QueryParam', QueryParams, Raw,
RemoteHost, ReqBody', Vault,
WithNamedContext,
Description, Summary,
Accept(..),
FramingRender(..), Stream,
StreamGenerator(..), ToStreamGenerator(..),
BoundaryStrategy(..))
BoundaryStrategy(..),
If, SBool (..), SBoolI (..))
import Servant.API.Modifiers (unfoldRequestArgument, RequestArgument, FoldRequired, FoldLenient)
import Servant.API.ContentTypes (AcceptHeader (..),
AllCTRender (..),
AllCTUnrender (..),
@ -361,29 +364,39 @@ streamRouter splitHeaders method framingproxy ctypeproxy action = leafRouter $ \
-- > server = viewReferer
-- > where viewReferer :: Referer -> Handler referer
-- > viewReferer referer = return referer
instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
=> HasServer (Header sym a :> api) context where
type ServerT (Header sym a :> api) m =
Maybe a -> ServerT api m
instance
(KnownSymbol sym, FromHttpApiData a, HasServer api context
, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
)
=> HasServer (Header' mods sym a :> api) context where
------
type ServerT (Header' mods sym a :> api) m =
RequestArgument mods a -> ServerT api m
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
route Proxy context subserver = route (Proxy :: Proxy api) context $
subserver `addHeaderCheck` withRequest headerCheck
where
headerName = symbolVal (Proxy :: Proxy sym)
headerName :: IsString n => n
headerName = fromString $ symbolVal (Proxy :: Proxy sym)
headerCheck :: Request -> DelayedIO (RequestArgument mods a)
headerCheck req =
case lookup (fromString headerName) (requestHeaders req) of
Nothing -> return Nothing
Just txt ->
case parseHeader txt of
Left e -> delayedFailFatal err400
{ errBody = cs $ "Error parsing header "
<> fromString headerName
<> " failed: " <> e
}
Right hdr -> return $ Just hdr
unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev
where
mev :: Maybe (Either T.Text a)
mev = fmap parseHeader $ lookup headerName (requestHeaders req)
errReq = delayedFailFatal err400
{ errBody = "Header " <> headerName <> " is required"
}
errSt e = delayedFailFatal err400
{ errBody = cs $ "Error parsing header "
<> headerName
<> " failed: " <> e
}
-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function
@ -406,33 +419,41 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
-- > where getBooksBy :: Maybe Text -> Handler [Book]
-- > getBooksBy Nothing = ...return all books...
-- > getBooksBy (Just author) = ...return books by the given author...
instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
=> HasServer (QueryParam sym a :> api) context where
type ServerT (QueryParam sym a :> api) m =
Maybe a -> ServerT api m
instance
( KnownSymbol sym, FromHttpApiData a, HasServer api context
, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
)
=> HasServer (QueryParam' mods sym a :> api) context where
------
type ServerT (QueryParam' mods sym a :> api) m =
RequestArgument mods a -> ServerT api m
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
route Proxy context subserver =
let querytext req = parseQueryText $ rawQueryString req
parseParam req =
case lookup paramname (querytext req) of
Nothing -> return Nothing -- param absent from the query string
Just Nothing -> return Nothing -- param present with no value -> Nothing
Just (Just v) ->
case parseQueryParam v of
Left e -> delayedFailFatal err400
{ errBody = cs $ "Error parsing query parameter "
<> paramname <> " failed: " <> e
}
paramname = cs $ symbolVal (Proxy :: Proxy sym)
parseParam :: Request -> DelayedIO (RequestArgument mods a)
parseParam req =
unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev
where
mev :: Maybe (Either T.Text a)
mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req
errReq = delayedFailFatal err400
{ errBody = cs $ "Query parameter " <> paramname <> " is required"
}
errSt e = delayedFailFatal err400
{ errBody = cs $ "Error parsing query parameter "
<> paramname <> " failed: " <> e
}
Right param -> return $ Just param
delayed = addParameterCheck subserver . withRequest $ \req ->
parseParam req
in route (Proxy :: Proxy api) context delayed
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function
@ -561,11 +582,11 @@ instance HasServer Raw context where
-- > server = postBook
-- > where postBook :: Book -> Handler Book
-- > postBook book = ...insert into your db...
instance ( AllCTUnrender list a, HasServer api context
) => HasServer (ReqBody list a :> api) context where
instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods)
) => HasServer (ReqBody' mods list a :> api) context where
type ServerT (ReqBody list a :> api) m =
a -> ServerT api m
type ServerT (ReqBody' mods list a :> api) m =
If (FoldLenient mods) (Either String a) a -> ServerT api m
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
@ -588,9 +609,11 @@ instance ( AllCTUnrender list a, HasServer api context
-- Body check, we get a body parsing functions as the first argument.
bodyCheck f = withRequest $ \ request -> do
mrqbody <- f <$> liftIO (lazyRequestBody request)
case mrqbody of
Left e -> delayedFailFatal err400 { errBody = cs e }
Right v -> return v
case sbool :: SBool (FoldLenient mods) of
STrue -> return mrqbody
SFalse -> case mrqbody of
Left e -> delayedFailFatal err400 { errBody = cs e }
Right v -> return v
-- | Make sure the incoming request starts with @"/path"@, strip it and
-- pass the rest of the request path to @api@.

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

@ -47,7 +47,7 @@ import Network.Wai.Test (defaultRequest, request,
simpleHeaders, simpleStatus)
import Servant.API ((:<|>) (..), (:>), AuthProtect,
BasicAuth, BasicAuthData(BasicAuthData),
Capture, CaptureAll, Delete, Get, Header (..),
Capture, CaptureAll, Delete, Get, Header,
Headers, HttpVersion,
IsSecure (..), JSON,
NoContent (..), Patch, PlainText,
@ -461,8 +461,8 @@ reqBodySpec = describe "Servant.API.ReqBody" $ do
------------------------------------------------------------------------------
type HeaderApi a = Header "MyHeader" a :> Delete '[JSON] NoContent
headerApi :: Proxy (HeaderApi a)
headerApi = Proxy
headerApi :: Proxy a -> Proxy (HeaderApi a)
headerApi _ = Proxy
headerSpec :: Spec
headerSpec = describe "Servant.API.Header" $ do
@ -479,19 +479,19 @@ headerSpec = describe "Servant.API.Header" $ do
return NoContent
expectsString Nothing = error "Expected a string"
with (return (serve headerApi expectsInt)) $ do
with (return (serve (headerApi (Proxy :: Proxy Int)) expectsInt)) $ do
let delete' x = THW.request methodDelete x [("MyHeader", "5")]
it "passes the header to the handler (Int)" $
delete' "/" "" `shouldRespondWith` 200
with (return (serve headerApi expectsString)) $ do
with (return (serve (headerApi (Proxy :: Proxy String)) expectsString)) $ do
let delete' x = THW.request methodDelete x [("MyHeader", "more from you")]
it "passes the header to the handler (String)" $
delete' "/" "" `shouldRespondWith` 200
with (return (serve headerApi expectsInt)) $ do
with (return (serve (headerApi (Proxy :: Proxy Int)) expectsInt)) $ do
let delete' x = THW.request methodDelete x [("MyHeader", "not a number")]
it "checks for parse errors" $

4
servant/servant.cabal
View file

@ -49,12 +49,13 @@ library
Servant.API.HttpVersion
Servant.API.Internal.Test.ComprehensiveAPI
Servant.API.IsSecure
Servant.API.Modifiers
Servant.API.QueryParam
Servant.API.Raw
Servant.API.Stream
Servant.API.RemoteHost
Servant.API.ReqBody
Servant.API.ResponseHeaders
Servant.API.Stream
Servant.API.Sub
Servant.API.TypeLevel
Servant.API.Vault
@ -77,6 +78,7 @@ library
, mmorph >= 1 && < 1.2
, tagged >= 0.7.3 && < 0.9
, text >= 1 && < 1.3
, singleton-bool >= 0.1.2.0 && <0.2
, string-conversions >= 0.3 && < 0.5
, network-uri >= 2.6 && < 2.7
, vault >= 0.3 && < 0.4

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

@ -7,6 +7,8 @@ module Servant.API (
-- | Type-level combinator for alternative endpoints: @':<|>'@
module Servant.API.Empty,
-- | Type-level combinator for an empty API: @'EmptyAPI'@
module Servant.API.Modifiers,
-- | Type-level modifiers for 'QueryParam', 'Header' and 'ReqBody'.
-- * Accessing information from the request
module Servant.API.Capture,
@ -64,6 +66,10 @@ module Servant.API (
-- * Utilities
module Servant.Utils.Links,
-- | Type-safe internal URIs
-- * Re-exports
If,
SBool (..), SBoolI (..)
) where
import Servant.API.Alternative ((:<|>) (..))
@ -77,10 +83,11 @@ import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,
import Servant.API.Description (Description, Summary)
import Servant.API.Empty (EmptyAPI (..))
import Servant.API.Experimental.Auth (AuthProtect)
import Servant.API.Header (Header (..))
import Servant.API.Header (Header, Header')
import Servant.API.HttpVersion (HttpVersion (..))
import Servant.API.IsSecure (IsSecure (..))
import Servant.API.QueryParam (QueryFlag, QueryParam,
import Servant.API.Modifiers (Required, Optional, Lenient, Strict)
import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParam',
QueryParams)
import Servant.API.Raw (Raw)
import Servant.API.Stream (Stream, StreamGet, StreamPost,
@ -93,12 +100,12 @@ import Servant.API.Stream (Stream, StreamGet, StreamPost,
NewlineFraming,
NetstringFraming)
import Servant.API.RemoteHost (RemoteHost)
import Servant.API.ReqBody (ReqBody)
import Servant.API.ReqBody (ReqBody, ReqBody')
import Servant.API.ResponseHeaders (AddHeader, addHeader, noHeader,
BuildHeadersTo (buildHeadersTo),
GetHeaders (getHeaders),
HList (..), Headers (..),
getHeadersHList, getResponse)
getHeadersHList, getResponse, ResponseHeader (..))
import Servant.API.Sub ((:>))
import Servant.API.Vault (Vault)
import Servant.API.Verbs (PostCreated, Delete, DeleteAccepted,
@ -124,3 +131,6 @@ import Servant.Utils.Links (HasLink (..), Link, IsElem, IsElem
URI (..), safeLink)
import Web.HttpApiData (FromHttpApiData (..),
ToHttpApiData (..))
import Data.Type.Bool (If)
import Data.Singletons.Bool (SBool (..), SBoolI (..))

16
servant/src/Servant/API/Header.hs
View file

@ -4,13 +4,15 @@
{-# LANGUAGE PolyKinds #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Header (
Header(..),
) where
Header, Header',
) where
import Data.ByteString (ByteString)
import Data.Typeable (Typeable)
import GHC.TypeLits (Symbol)
import Servant.API.Modifiers
-- | Extract the given header's value as a value of type @a@.
-- I.e. header sent by client, parsed by server.
--
-- Example:
--
@ -18,10 +20,10 @@ import GHC.TypeLits (Symbol)
-- >>>
-- >>> -- GET /view-my-referer
-- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer
data Header (sym :: Symbol) a = Header a
| MissingHeader
| UndecodableHeader ByteString
deriving (Typeable, Eq, Show, Functor)
type Header = Header' '[Optional, Strict]
data Header' (mods :: [*]) (sym :: Symbol) a
deriving Typeable
-- $setup
-- >>> import Servant.API

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

@ -24,13 +24,16 @@ type ComprehensiveAPIWithoutRaw =
Get '[JSON] Int :<|>
Capture "foo" Int :> GET :<|>
Header "foo" Int :> GET :<|>
Header' '[Required, Lenient] "bar" Int :> GET :<|>
HttpVersion :> GET :<|>
IsSecure :> GET :<|>
QueryParam "foo" Int :> GET :<|>
QueryParam' '[Required, Lenient] "bar" Int :> GET :<|>
QueryParams "foo" Int :> GET :<|>
QueryFlag "foo" :> GET :<|>
RemoteHost :> GET :<|>
ReqBody '[JSON] Int :> GET :<|>
ReqBody' '[Lenient] '[JSON] Int :> GET :<|>
Get '[JSON] (Headers '[Header "foo" Int] NoContent) :<|>
"foo" :> GET :<|>
Vault :> GET :<|>

150
servant/src/Servant/API/Modifiers.hs Normal file
View file

@ -0,0 +1,150 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Servant.API.Modifiers (
-- * Required / optional argument
Required, Optional,
FoldRequired, FoldRequired',
-- * Lenient / strict parsing
Lenient, Strict,
FoldLenient, FoldLenient',
-- * Utilities
RequiredArgument,
foldRequiredArgument,
unfoldRequiredArgument,
RequestArgument,
unfoldRequestArgument,
) where
import Data.Proxy (Proxy (..))
import Data.Singletons.Bool (SBool (..), SBoolI (..))
import Data.Text (Text)
import Data.Type.Bool (If)
-- | Required argument. Not wrapped.
data Required
-- | Optional argument. Wrapped in 'Maybe'.
data Optional
-- | Fold modifier list to decide whether argument is required.
--
-- >>> :kind! FoldRequired '[Required, Description "something"]
-- FoldRequired '[Required, Description "something"] :: Bool
-- = 'True
--
-- >>> :kind! FoldRequired '[Required, Optional]
-- FoldRequired '[Required, Optional] :: Bool
-- = 'False
--
-- >>> :kind! FoldRequired '[]
-- FoldRequired '[] :: Bool
-- = 'False
--
type FoldRequired mods = FoldRequired' 'False mods
-- | Implementation of 'FoldRequired'.
type family FoldRequired' (acc :: Bool) (mods :: [*]) :: Bool where
FoldRequired' acc '[] = acc
FoldRequired' acc (Required ': mods) = FoldRequired' 'True mods
FoldRequired' acc (Optional ': mods) = FoldRequired' 'False mods
FoldRequired' acc (mod ': mods) = FoldRequired' acc mods
-- | Leniently parsed argument, i.e. parsing never fail. Wrapped in @'Either' 'Text'@.
data Lenient
-- | Strictly parsed argument. Not wrapped.
data Strict
-- | Fold modifier list to decide whether argument should be parsed strictly or leniently.
--
-- >>> :kind! FoldLenient '[]
-- FoldLenient '[] :: Bool
-- = 'False
--
type FoldLenient mods = FoldLenient' 'False mods
-- | Implementation of 'FoldLenient'.
type family FoldLenient' (acc :: Bool) (mods :: [*]) :: Bool where
FoldLenient' acc '[] = acc
FoldLenient' acc (Lenient ': mods) = FoldLenient' 'True mods
FoldLenient' acc (Strict ': mods) = FoldLenient' 'False mods
FoldLenient' acc (mod ': mods) = FoldLenient' acc mods
-- | Helper type alias.
--
-- * 'Required' ↦ @a@
--
-- * 'Optional' ↦ @'Maybe' a@
--
type RequiredArgument mods a = If (FoldRequired mods) a (Maybe a)
-- | Fold a 'RequiredAgument' into a value
foldRequiredArgument
:: forall mods a r. (SBoolI (FoldRequired mods))
=> Proxy mods
-> (a -> r) -- ^ 'Required'
-> (Maybe a -> r) -- ^ 'Optional'
-> RequiredArgument mods a
-> r
foldRequiredArgument _ f g mx =
case (sbool :: SBool (FoldRequired mods), mx) of
(STrue, x) -> f x
(SFalse, x) -> g x
-- | Unfold a value into a 'RequiredArgument'.
unfoldRequiredArgument
:: forall mods m a. (Monad m, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods))
=> Proxy mods
-> m (RequiredArgument mods a) -- ^ error when argument is required
-> (Text -> m (RequiredArgument mods a)) -- ^ error when argument is strictly parsed
-> Maybe (Either Text a) -- ^ value
-> m (RequiredArgument mods a)
unfoldRequiredArgument _ errReq errSt mex =
case (sbool :: SBool (FoldRequired mods), mex) of
(STrue, Nothing) -> errReq
(SFalse, Nothing) -> return Nothing
(STrue, Just ex) -> either errSt return ex
(SFalse, Just ex) -> either errSt (return . Just) ex
-- | Helper type alias.
--
-- By default argument is 'Optional' and 'Strict'.
--
-- * 'Required', 'Strict' ↦ @a@
--
-- * 'Required', 'Lenient' ↦ @'Either' 'Text' a@
--
-- * 'Optional', 'Strict' ↦ @'Maybe' a@
--
-- * 'Optional', 'Lenient' ↦ @'Maybe' ('Either' 'Text' a)@
--
type RequestArgument mods a =
If (FoldRequired mods)
(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))
=> Proxy mods
-> m (RequestArgument mods a) -- ^ error when argument is required
-> (Text -> m (RequestArgument mods a)) -- ^ error when argument is strictly parsed
-> Maybe (Either Text a) -- ^ value
-> m (RequestArgument mods a)
unfoldRequestArgument _ errReq errSt mex =
case (sbool :: SBool (FoldRequired mods), mex, sbool :: SBool (FoldLenient mods)) of
(STrue, Nothing, _) -> errReq
(SFalse, Nothing, _) -> return Nothing
(STrue, Just ex, STrue) -> return ex
(STrue, Just ex, SFalse) -> either errSt return ex
(SFalse, Just ex, STrue) -> return (Just ex)
(SFalse, Just ex, SFalse) -> either errSt (return . Just) ex
-- $setup
-- >>> import Servant.API

9
servant/src/Servant/API/QueryParam.hs
View file

@ -3,10 +3,12 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PolyKinds #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) where
module Servant.API.QueryParam (QueryFlag, QueryParam, QueryParam', QueryParams) where
import Data.Typeable (Typeable)
import GHC.TypeLits (Symbol)
import Servant.API.Modifiers
-- | Lookup the value associated to the @sym@ query string parameter
-- and try to extract it as a value of type @a@.
--
@ -14,7 +16,10 @@ import GHC.TypeLits (Symbol)
--
-- >>> -- /books?author=<author name>
-- >>> type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]
data QueryParam (sym :: Symbol) (a :: *)
type QueryParam = QueryParam' '[Optional, Strict]
-- | 'QueryParam' which can be 'Required', 'Lenient', or modified otherwise.
data QueryParam' (mods :: [*]) (sym :: Symbol) (a :: *)
deriving Typeable
-- | Lookup the values associated to the @sym@ query string parameter

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

@ -2,16 +2,25 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE PolyKinds #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.ReqBody where
module Servant.API.ReqBody (
ReqBody, ReqBody',
) where
import Data.Typeable (Typeable)
import Servant.API.Modifiers
import Data.Typeable (Typeable)
-- | Extract the request body as a value of type @a@.
--
-- Example:
--
-- >>> -- POST /books
-- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book
data ReqBody (contentTypes :: [*]) (a :: *)
type ReqBody = ReqBody' '[Required, Strict]
-- |
--
-- /Note:/ 'ReqBody'' is always 'Required'.
data ReqBody' (mods :: [*]) (contentTypes :: [*]) (a :: *)
deriving (Typeable)
-- $setup

19
servant/src/Servant/API/ResponseHeaders.hs
View file

@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
@ -23,6 +24,7 @@
-- example above).
module Servant.API.ResponseHeaders
( Headers(..)
, ResponseHeader (..)
, AddHeader
, addHeader
, noHeader
@ -32,15 +34,16 @@ module Servant.API.ResponseHeaders
, HList(..)
) where
import Data.ByteString.Char8 as BS (pack, unlines, init)
import Data.ByteString.Char8 as BS (ByteString, pack, unlines, init)
import Data.Typeable (Typeable)
import Web.HttpApiData (ToHttpApiData, toHeader,
FromHttpApiData, parseHeader)
import qualified Data.CaseInsensitive as CI
import Data.Proxy
import GHC.TypeLits (KnownSymbol, symbolVal)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import qualified Network.HTTP.Types.Header as HTTP
import Servant.API.Header (Header (..))
import Servant.API.Header (Header)
import Prelude ()
import Prelude.Compat
@ -52,9 +55,15 @@ data Headers ls a = Headers { getResponse :: a
-- ^ HList of headers.
} deriving (Functor)
data ResponseHeader (sym :: Symbol) a
= Header a
| MissingHeader
| UndecodableHeader ByteString
deriving (Typeable, Eq, Show, Functor)
data HList a where
HNil :: HList '[]
HCons :: Header h x -> HList xs -> HList (Header h x ': xs)
HCons :: ResponseHeader h x -> HList xs -> HList (Header h x ': xs)
type family HeaderValMap (f :: * -> *) (xs :: [*]) where
HeaderValMap f '[] = '[]
@ -110,7 +119,7 @@ instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToHttpApiData v
-- We need all these fundeps to save type inference
class AddHeader h v orig new
| h v orig -> new, new -> h, new -> v, new -> orig where
addOptionalHeader :: Header h v -> orig -> new -- ^ N.B.: The same header can't be added multiple times
addOptionalHeader :: ResponseHeader h v -> orig -> new -- ^ N.B.: The same header can't be added multiple times
instance OVERLAPPING_ ( KnownSymbol h, ToHttpApiData v )

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

@ -1,11 +1,13 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-}
-- | Type safe generation of internal links.
@ -101,8 +103,10 @@ module Servant.Utils.Links (
import Data.List
import Data.Monoid.Compat ( (<>) )
import Data.Proxy ( Proxy(..) )
import Data.Singletons.Bool ( SBool (..), SBoolI (..) )
import qualified Data.Text as Text
import qualified Data.Text.Encoding as TE
import Data.Type.Bool (If)
import GHC.TypeLits ( KnownSymbol, symbolVal )
import Network.URI ( URI(..), escapeURIString, isUnreserved )
import Prelude ()
@ -112,15 +116,22 @@ import Web.HttpApiData
import Servant.API.Alternative ( (:<|>)((:<|>)) )
import Servant.API.BasicAuth ( BasicAuth )
import Servant.API.Capture ( Capture, CaptureAll )
import Servant.API.ReqBody ( ReqBody )
import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag )
import Servant.API.Header ( Header )
import Servant.API.ReqBody ( ReqBody' )
import Servant.API.QueryParam ( QueryParam', QueryParams, QueryFlag )
import Servant.API.Header ( Header' )
import Servant.API.HttpVersion (HttpVersion)
import Servant.API.RemoteHost ( RemoteHost )
import Servant.API.IsSecure (IsSecure)
import Servant.API.Empty (EmptyAPI (..))
import Servant.API.Verbs ( Verb )
import Servant.API.Sub ( type (:>) )
import Servant.API.Raw ( Raw )
import Servant.API.Stream ( Stream )
import Servant.API.TypeLevel
import Servant.API.Modifiers (FoldRequired)
import Servant.API.Description (Description, Summary)
import Servant.API.Vault (Vault)
import Servant.API.WithNamedContext (WithNamedContext)
import Servant.API.Experimental.Auth ( AuthProtect )
-- | A safe link datatype.
@ -282,14 +293,15 @@ instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where
where
seg = symbolVal (Proxy :: Proxy sym)
-- QueryParam instances
instance (KnownSymbol sym, ToHttpApiData v, HasLink sub)
=> HasLink (QueryParam sym v :> sub) where
type MkLink (QueryParam sym v :> sub) = Maybe v -> MkLink sub
instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mods))
=> HasLink (QueryParam' mods sym v :> sub) where
type MkLink (QueryParam' mods sym v :> sub) = If (FoldRequired mods) v (Maybe v) -> MkLink sub
toLink _ l mv =
toLink (Proxy :: Proxy sub) $
maybe id (addQueryParam . SingleParam k . toQueryParam) mv l
case sbool :: SBool (FoldRequired mods) of
STrue -> (addQueryParam . SingleParam k . toQueryParam) mv l
SFalse -> maybe id (addQueryParam . SingleParam k . toQueryParam) mv l
where
k :: String
k = symbolVal (Proxy :: Proxy sym)
@ -319,8 +331,8 @@ instance (HasLink a, HasLink b) => HasLink (a :<|> b) where
toLink _ l = toLink (Proxy :: Proxy a) l :<|> toLink (Proxy :: Proxy b) l
-- Misc instances
instance HasLink sub => HasLink (ReqBody ct a :> sub) where
type MkLink (ReqBody ct a :> sub) = MkLink sub
instance HasLink sub => HasLink (ReqBody' mods ct a :> sub) where
type MkLink (ReqBody' mods ct a :> sub) = MkLink sub
toLink _ = toLink (Proxy :: Proxy sub)
instance (ToHttpApiData v, HasLink sub)
@ -337,8 +349,32 @@ instance (ToHttpApiData v, HasLink sub)
toLink (Proxy :: Proxy sub) $
foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs
instance HasLink sub => HasLink (Header sym a :> sub) where
type MkLink (Header sym a :> sub) = MkLink sub
instance HasLink sub => HasLink (Header' mods sym a :> sub) where
type MkLink (Header' mods sym a :> sub) = MkLink sub
toLink _ = toLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (Vault :> sub) where
type MkLink (Vault :> sub) = MkLink sub
toLink _ = toLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (Description s :> sub) where
type MkLink (Description s :> sub) = MkLink sub
toLink _ = toLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (Summary s :> sub) where
type MkLink (Summary s :> sub) = MkLink sub
toLink _ = toLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (HttpVersion :> sub) where
type MkLink (HttpVersion:> sub) = MkLink sub
toLink _ = toLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (IsSecure :> sub) where
type MkLink (IsSecure :> sub) = MkLink sub
toLink _ = toLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (WithNamedContext name context sub) where
type MkLink (WithNamedContext name context sub) = MkLink sub
toLink _ = toLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (RemoteHost :> sub) where
@ -349,6 +385,10 @@ instance HasLink sub => HasLink (BasicAuth realm a :> sub) where
type MkLink (BasicAuth realm a :> sub) = MkLink sub
toLink _ = toLink (Proxy :: Proxy sub)
instance HasLink EmptyAPI where
type MkLink EmptyAPI = EmptyAPI
toLink _ _ = EmptyAPI
-- Verb (terminal) instances
instance HasLink (Verb m s ct a) where
type MkLink (Verb m s ct a) = Link

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

@ -1,8 +1,12 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
#if __GLASGOW__HASKELL < 709
{-# OPTIONS_GHC -fcontext-stack=41 #-}
#endif
module Servant.Utils.LinksSpec where
import Data.Proxy (Proxy (..))
@ -11,11 +15,13 @@ import Test.Hspec (Expectation, Spec, describe, it,
import Data.String (fromString)
import Servant.API
import Servant.Utils.Links (allLinks)
import Servant.Utils.Links (allLinks, linkURI)
import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw)
type TestApi =
-- Capture and query params
"hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete '[JSON] NoContent
:<|> "hi" :> Capture "name" String :> QueryParam' '[Required] "capital" Bool :> Delete '[JSON] NoContent
:<|> "all" :> CaptureAll "names" String :> Get '[JSON] NoContent
-- Flags
@ -55,6 +61,11 @@ spec = describe "Servant.Utils.Links" $ do
:> Delete '[JSON] NoContent)
apiLink l2 "bye" (Just True) `shouldBeLink` "hello/bye?capital=true"
let l4 = Proxy :: Proxy ("hi" :> Capture "name" String
:> QueryParam' '[Required] "capital" Bool
:> Delete '[JSON] NoContent)
apiLink l4 "privet" False `shouldBeLink` "hi/privet?capital=false"
it "generates correct links for CaptureAll" $ do
apiLink (Proxy :: Proxy ("all" :> CaptureAll "names" String :> Get '[JSON] NoContent))
["roads", "lead", "to", "rome"]
@ -75,11 +86,12 @@ spec = describe "Servant.Utils.Links" $ do
it "can generate all links for an API that has only linkable endpoints" $ do
let (allNames :<|> simple) = allLinks (Proxy :: Proxy LinkableApi)
simple
`shouldBeLink` "get"
allNames ["Seneca", "Aurelius"]
`shouldBeLink` "all/Seneca/Aurelius"
simple `shouldBeLink` "get"
allNames ["Seneca", "Aurelius"] `shouldBeLink` "all/Seneca/Aurelius"
it "can generate all links for ComprehensiveAPIWithoutRaw" $ do
let (firstLink :<|> _) = allLinks comprehensiveAPIWithoutRaw
firstLink `shouldBeLink` ""
-- |
-- Before https://github.com/CRogers/should-not-typecheck/issues/5 is fixed,
@ -112,9 +124,9 @@ spec = describe "Servant.Utils.Links" $ do
-- ...Could not deduce...
-- ...
--
-- >>> apiLink (Proxy :: Proxy NoEndpoint)
-- >>> linkURI $ apiLink (Proxy :: Proxy NoEndpoint)
-- ...
-- ...No instance for...
-- <interactive>...
-- ...
--
-- sanity check