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

Add Servant.API.Modifiers to servant

Browse source 
Changes Header, ReqBody and QueryParam to take a modifier list.

Resolves https://github.com/haskell-servant/servant/issues/856

ResponseHeader story turns to be somewhat ugly, but it can be made
elegant when https://github.com/haskell-servant/servant/issues/841 is
implemnted, then we can omit HList aka Header Heterogenous List
implementation.

- servant-server changes:

  Writing server side intepretations is quite simple using
  `unfoldRequestArgument`, which makes Header and QueryParam look quite
  the same.

  `ReqBody` cannot be easily made optional with current design (what that
  would mean: No Content-Type Header?), so that dimensions isn't used
  there.

- Add HasLink for all the rest ComprehensiveAPI combinators
- Add 'tricky' Header', QueryParam' endpoints to ComprehensiveAPI
- servant-docs: Quick'n'dirty implementation. Don't use modifiers information (yet).
This commit is contained in:
Oleg Grenrus 2017-12-10 14:25:14 +02:00
parent 0a50e7582e
commit bc3f61d615
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.Proxy (Proxy (Proxy))
import Data.Sequence (fromList) import Data.Sequence (fromList)
import Data.String (fromString) import Data.String (fromString)
import Data.Text (pack) import Data.Text (Text, pack)
import GHC.TypeLits (KnownSymbol, symbolVal) import GHC.TypeLits (KnownSymbol, symbolVal)
import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types as H
import Servant.API ((:<|>) ((:<|>)), (:>), import Servant.API ((:<|>) ((:<|>)), (:>),
@ -37,16 +37,17 @@ import Servant.API ((:<|>) ((:<|>)), (:>),
Capture, CaptureAll, Capture, CaptureAll,
Description, EmptyAPI, Description, EmptyAPI,
FramingUnrender (..), FramingUnrender (..),
Header, Headers (..), Header', Headers (..),
HttpVersion, IsSecure, HttpVersion, IsSecure,
MimeRender (mimeRender), MimeRender (mimeRender),
MimeUnrender (mimeUnrender), MimeUnrender (mimeUnrender),
NoContent (NoContent), NoContent (NoContent),
QueryFlag, QueryParam, QueryFlag, QueryParam',
QueryParams, Raw, QueryParams, Raw,
ReflectMethod (..), ReflectMethod (..),
RemoteHost, ReqBody, RemoteHost, ReqBody',
ResultStream(..), ResultStream(..),
SBoolI,
Stream, Stream,
Summary, ToHttpApiData, Summary, ToHttpApiData,
Vault, Verb, Vault, Verb,
@ -57,6 +58,9 @@ import Servant.API ((:<|>) ((:<|>)), (:>),
toQueryParam, toQueryParam,
toUrlPiece) toUrlPiece)
import Servant.API.ContentTypes (contentTypes) import Servant.API.ContentTypes (contentTypes)
import Servant.API.Modifiers (FoldRequired,
RequiredArgument,
foldRequiredArgument)
import Servant.Client.Core.Internal.Auth import Servant.Client.Core.Internal.Auth
import Servant.Client.Core.Internal.BasicAuth import Servant.Client.Core.Internal.BasicAuth
@ -325,20 +329,20 @@ instance OVERLAPPABLE_
-- > viewReferer = client myApi -- > viewReferer = client myApi
-- > -- then you can just use "viewRefer" to query that endpoint -- > -- then you can just use "viewRefer" to query that endpoint
-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments -- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
instance (KnownSymbol sym, ToHttpApiData a, HasClient m api) instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods))
=> HasClient m (Header sym a :> api) where => HasClient m (Header' mods sym a :> api) where
type Client m (Header sym a :> api) = type Client m (Header' mods sym a :> api) =
Maybe a -> Client m api RequiredArgument mods a -> Client m api
clientWithRoute pm Proxy req mval = clientWithRoute pm Proxy req mval =
clientWithRoute pm (Proxy :: Proxy api) clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument
(maybe req (Proxy :: Proxy mods) add (maybe req add) mval
(\value -> addHeader hname value req) where
mval 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 -- | Using a 'HttpVersion' combinator in your API doesn't affect the client
-- functions. -- 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. -- > -- then you can just use "getBooksBy" to query that endpoint.
-- > -- 'getBooksBy Nothing' for all books -- > -- 'getBooksBy Nothing' for all books
-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov -- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
instance (KnownSymbol sym, ToHttpApiData a, HasClient m api) instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods))
=> HasClient m (QueryParam sym a :> api) where => HasClient m (QueryParam' mods sym a :> api) where
type Client m (QueryParam sym a :> api) = type Client m (QueryParam' mods sym a :> api) =
Maybe a -> Client m api RequiredArgument mods a -> Client m api
-- if mparam = Nothing, we don't add it to the query string -- if mparam = Nothing, we don't add it to the query string
clientWithRoute pm Proxy req mparam = clientWithRoute pm Proxy req mparam =
clientWithRoute pm (Proxy :: Proxy api) clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument
(maybe req (Proxy :: Proxy mods) add (maybe req add) mparam
(flip (appendToQueryString pname) req . Just) where
mparamText add :: a -> Request
) add param = appendToQueryString pname (Just $ toQueryParam param) req
where pname = pack $ symbolVal (Proxy :: Proxy sym) pname :: Text
mparamText = fmap toQueryParam mparam pname = pack $ symbolVal (Proxy :: Proxy sym)
-- | If you use a 'QueryParams' in one of your endpoints in your API, -- | If you use a 'QueryParams' in one of your endpoints in your API,
-- the corresponding querying function will automatically take -- the corresponding querying function will automatically take
@ -514,9 +518,9 @@ instance RunClient m => HasClient m Raw where
-- > addBook = client myApi -- > addBook = client myApi
-- > -- then you can just use "addBook" to query that endpoint -- > -- then you can just use "addBook" to query that endpoint
instance (MimeRender ct a, HasClient m api) 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 a -> Client m api
clientWithRoute pm Proxy req body = 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: -- Example of an instance:
-- --
-- > instance ToParam (QueryParam "capital" Bool) where -- > instance ToParam (QueryParam' mods "capital" Bool) where
-- > toParam _ = -- > toParam _ =
-- > DocQueryParam "capital" -- > DocQueryParam "capital"
-- > ["true", "false"] -- > ["true", "false"]
@ -859,7 +859,7 @@ instance OVERLAPPING_
p = Proxy :: Proxy a p = Proxy :: Proxy a
instance (KnownSymbol sym, HasDocs api) instance (KnownSymbol sym, HasDocs api)
=> HasDocs (Header sym a :> api) where => HasDocs (Header' mods sym a :> api) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) =
docsFor subApiP (endpoint, action') docsFor subApiP (endpoint, action')
@ -867,14 +867,14 @@ instance (KnownSymbol sym, HasDocs api)
action' = over headers (|> headername) action action' = over headers (|> headername) action
headername = T.pack $ symbolVal (Proxy :: Proxy sym) headername = T.pack $ symbolVal (Proxy :: Proxy sym)
instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs api) instance (KnownSymbol sym, ToParam (QueryParam' mods sym a), HasDocs api)
=> HasDocs (QueryParam sym a :> api) where => HasDocs (QueryParam' mods sym a :> api) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) =
docsFor subApiP (endpoint, action') docsFor subApiP (endpoint, action')
where subApiP = Proxy :: Proxy api where subApiP = Proxy :: Proxy api
paramP = Proxy :: Proxy (QueryParam sym a) paramP = Proxy :: Proxy (QueryParam' mods sym a)
action' = over params (|> toParam paramP) action action' = over params (|> toParam paramP) action
instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs api) 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 -- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
-- both are even defined) for any particular type. -- both are even defined) for any particular type.
instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api) 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 Proxy (endpoint, action) opts@DocOptions{..} =
docsFor subApiP (endpoint, action') opts 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. -- This declaration simply checks that all instances are in place.
_ = docs comprehensiveAPI _ = 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" toParam = error "unused"
instance ToParam (QueryParams "foo" Int) where instance ToParam (QueryParams "foo" Int) where
toParam = error "unused" toParam = error "unused"

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

@ -36,7 +36,8 @@ library
exposed-modules: Servant.Foreign exposed-modules: Servant.Foreign
, Servant.Foreign.Internal , Servant.Foreign.Internal
, Servant.Foreign.Inflections , Servant.Foreign.Inflections
build-depends: base == 4.* build-depends: base >= 4.7 && <4.11
, base-compat >= 0.9.3 && <0.10
, lens == 4.* , lens == 4.*
, servant == 0.12.* , servant == 0.12.*
, text >= 1.2 && < 1.3 , text >= 1.2 && < 1.3

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

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

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

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

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

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

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

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

4
servant/servant.cabal
View file

@ -49,12 +49,13 @@ library
Servant.API.HttpVersion Servant.API.HttpVersion
Servant.API.Internal.Test.ComprehensiveAPI Servant.API.Internal.Test.ComprehensiveAPI
Servant.API.IsSecure Servant.API.IsSecure
Servant.API.Modifiers
Servant.API.QueryParam Servant.API.QueryParam
Servant.API.Raw Servant.API.Raw
Servant.API.Stream
Servant.API.RemoteHost Servant.API.RemoteHost
Servant.API.ReqBody Servant.API.ReqBody
Servant.API.ResponseHeaders Servant.API.ResponseHeaders
Servant.API.Stream
Servant.API.Sub Servant.API.Sub
Servant.API.TypeLevel Servant.API.TypeLevel
Servant.API.Vault Servant.API.Vault
@ -77,6 +78,7 @@ library
, mmorph >= 1 && < 1.2 , mmorph >= 1 && < 1.2
, tagged >= 0.7.3 && < 0.9 , tagged >= 0.7.3 && < 0.9
, text >= 1 && < 1.3 , text >= 1 && < 1.3
, singleton-bool >= 0.1.2.0 && <0.2
, string-conversions >= 0.3 && < 0.5 , string-conversions >= 0.3 && < 0.5
, network-uri >= 2.6 && < 2.7 , network-uri >= 2.6 && < 2.7
, vault >= 0.3 && < 0.4 , 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: @':<|>'@ -- | Type-level combinator for alternative endpoints: @':<|>'@
module Servant.API.Empty, module Servant.API.Empty,
-- | Type-level combinator for an empty API: @'EmptyAPI'@ -- | 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 -- * Accessing information from the request
module Servant.API.Capture, module Servant.API.Capture,
@ -64,6 +66,10 @@ module Servant.API (
-- * Utilities -- * Utilities
module Servant.Utils.Links, module Servant.Utils.Links,
-- | Type-safe internal URIs -- | Type-safe internal URIs
-- * Re-exports
If,
SBool (..), SBoolI (..)
) where ) where
import Servant.API.Alternative ((:<|>) (..)) import Servant.API.Alternative ((:<|>) (..))
@ -77,10 +83,11 @@ import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,
import Servant.API.Description (Description, Summary) import Servant.API.Description (Description, Summary)
import Servant.API.Empty (EmptyAPI (..)) import Servant.API.Empty (EmptyAPI (..))
import Servant.API.Experimental.Auth (AuthProtect) 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.HttpVersion (HttpVersion (..))
import Servant.API.IsSecure (IsSecure (..)) 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) QueryParams)
import Servant.API.Raw (Raw) import Servant.API.Raw (Raw)
import Servant.API.Stream (Stream, StreamGet, StreamPost, import Servant.API.Stream (Stream, StreamGet, StreamPost,
@ -93,12 +100,12 @@ import Servant.API.Stream (Stream, StreamGet, StreamPost,
NewlineFraming, NewlineFraming,
NetstringFraming) NetstringFraming)
import Servant.API.RemoteHost (RemoteHost) import Servant.API.RemoteHost (RemoteHost)
import Servant.API.ReqBody (ReqBody) import Servant.API.ReqBody (ReqBody, ReqBody')
import Servant.API.ResponseHeaders (AddHeader, addHeader, noHeader, import Servant.API.ResponseHeaders (AddHeader, addHeader, noHeader,
BuildHeadersTo (buildHeadersTo), BuildHeadersTo (buildHeadersTo),
GetHeaders (getHeaders), GetHeaders (getHeaders),
HList (..), Headers (..), HList (..), Headers (..),
getHeadersHList, getResponse) getHeadersHList, getResponse, ResponseHeader (..))
import Servant.API.Sub ((:>)) import Servant.API.Sub ((:>))
import Servant.API.Vault (Vault) import Servant.API.Vault (Vault)
import Servant.API.Verbs (PostCreated, Delete, DeleteAccepted, import Servant.API.Verbs (PostCreated, Delete, DeleteAccepted,
@ -124,3 +131,6 @@ import Servant.Utils.Links (HasLink (..), Link, IsElem, IsElem
URI (..), safeLink) URI (..), safeLink)
import Web.HttpApiData (FromHttpApiData (..), import Web.HttpApiData (FromHttpApiData (..),
ToHttpApiData (..)) ToHttpApiData (..))
import Data.Type.Bool (If)
import Data.Singletons.Bool (SBool (..), SBoolI (..))

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

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

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

@ -24,13 +24,16 @@ type ComprehensiveAPIWithoutRaw =
Get '[JSON] Int :<|> Get '[JSON] Int :<|>
Capture "foo" Int :> GET :<|> Capture "foo" Int :> GET :<|>
Header "foo" Int :> GET :<|> Header "foo" Int :> GET :<|>
Header' '[Required, Lenient] "bar" Int :> GET :<|>
HttpVersion :> GET :<|> HttpVersion :> GET :<|>
IsSecure :> GET :<|> IsSecure :> GET :<|>
QueryParam "foo" Int :> GET :<|> QueryParam "foo" Int :> GET :<|>
QueryParam' '[Required, Lenient] "bar" Int :> GET :<|>
QueryParams "foo" Int :> GET :<|> QueryParams "foo" Int :> GET :<|>
QueryFlag "foo" :> GET :<|> QueryFlag "foo" :> GET :<|>
RemoteHost :> GET :<|> RemoteHost :> GET :<|>
ReqBody '[JSON] Int :> GET :<|> ReqBody '[JSON] Int :> GET :<|>
ReqBody' '[Lenient] '[JSON] Int :> GET :<|>
Get '[JSON] (Headers '[Header "foo" Int] NoContent) :<|> Get '[JSON] (Headers '[Header "foo" Int] NoContent) :<|>
"foo" :> GET :<|> "foo" :> GET :<|>
Vault :> 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 TypeOperators #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# OPTIONS_HADDOCK not-home #-} {-# 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 Data.Typeable (Typeable)
import GHC.TypeLits (Symbol) import GHC.TypeLits (Symbol)
import Servant.API.Modifiers
-- | Lookup the value associated to the @sym@ query string parameter -- | Lookup the value associated to the @sym@ query string parameter
-- and try to extract it as a value of type @a@. -- and try to extract it as a value of type @a@.
-- --
@ -14,7 +16,10 @@ import GHC.TypeLits (Symbol)
-- --
-- >>> -- /books?author=<author name> -- >>> -- /books?author=<author name>
-- >>> type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book] -- >>> 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 deriving Typeable
-- | Lookup the values associated to the @sym@ query string parameter -- | Lookup the values associated to the @sym@ query string parameter

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

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

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

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

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

@ -1,11 +1,13 @@
{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-} {-# OPTIONS_HADDOCK not-home #-}
-- | Type safe generation of internal links. -- | Type safe generation of internal links.
@ -101,8 +103,10 @@ module Servant.Utils.Links (
import Data.List import Data.List
import Data.Monoid.Compat ( (<>) ) import Data.Monoid.Compat ( (<>) )
import Data.Proxy ( Proxy(..) ) import Data.Proxy ( Proxy(..) )
import Data.Singletons.Bool ( SBool (..), SBoolI (..) )
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding as TE
import Data.Type.Bool (If)
import GHC.TypeLits ( KnownSymbol, symbolVal ) import GHC.TypeLits ( KnownSymbol, symbolVal )
import Network.URI ( URI(..), escapeURIString, isUnreserved ) import Network.URI ( URI(..), escapeURIString, isUnreserved )
import Prelude () import Prelude ()
@ -112,15 +116,22 @@ import Web.HttpApiData
import Servant.API.Alternative ( (:<|>)((:<|>)) ) import Servant.API.Alternative ( (:<|>)((:<|>)) )
import Servant.API.BasicAuth ( BasicAuth ) import Servant.API.BasicAuth ( BasicAuth )
import Servant.API.Capture ( Capture, CaptureAll ) import Servant.API.Capture ( Capture, CaptureAll )
import Servant.API.ReqBody ( ReqBody ) import Servant.API.ReqBody ( ReqBody' )
import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag ) import Servant.API.QueryParam ( QueryParam', QueryParams, QueryFlag )
import Servant.API.Header ( Header ) import Servant.API.Header ( Header' )
import Servant.API.HttpVersion (HttpVersion)
import Servant.API.RemoteHost ( RemoteHost ) import Servant.API.RemoteHost ( RemoteHost )
import Servant.API.IsSecure (IsSecure)
import Servant.API.Empty (EmptyAPI (..))
import Servant.API.Verbs ( Verb ) import Servant.API.Verbs ( Verb )
import Servant.API.Sub ( type (:>) ) import Servant.API.Sub ( type (:>) )
import Servant.API.Raw ( Raw ) import Servant.API.Raw ( Raw )
import Servant.API.Stream ( Stream ) import Servant.API.Stream ( Stream )
import Servant.API.TypeLevel 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 ) import Servant.API.Experimental.Auth ( AuthProtect )
-- | A safe link datatype. -- | A safe link datatype.
@ -282,14 +293,15 @@ instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where
where where
seg = symbolVal (Proxy :: Proxy sym) seg = symbolVal (Proxy :: Proxy sym)
-- QueryParam instances -- QueryParam instances
instance (KnownSymbol sym, ToHttpApiData v, HasLink sub) instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mods))
=> HasLink (QueryParam sym v :> sub) where => HasLink (QueryParam' mods sym v :> sub) where
type MkLink (QueryParam sym v :> sub) = Maybe v -> MkLink sub type MkLink (QueryParam' mods sym v :> sub) = If (FoldRequired mods) v (Maybe v) -> MkLink sub
toLink _ l mv = toLink _ l mv =
toLink (Proxy :: Proxy sub) $ 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 where
k :: String k :: String
k = symbolVal (Proxy :: Proxy sym) 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 toLink _ l = toLink (Proxy :: Proxy a) l :<|> toLink (Proxy :: Proxy b) l
-- Misc instances -- Misc instances
instance HasLink sub => HasLink (ReqBody ct a :> sub) where instance HasLink sub => HasLink (ReqBody' mods ct a :> sub) where
type MkLink (ReqBody ct a :> sub) = MkLink sub type MkLink (ReqBody' mods ct a :> sub) = MkLink sub
toLink _ = toLink (Proxy :: Proxy sub) toLink _ = toLink (Proxy :: Proxy sub)
instance (ToHttpApiData v, HasLink sub) instance (ToHttpApiData v, HasLink sub)
@ -337,8 +349,32 @@ instance (ToHttpApiData v, HasLink sub)
toLink (Proxy :: Proxy sub) $ toLink (Proxy :: Proxy sub) $
foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs
instance HasLink sub => HasLink (Header sym a :> sub) where instance HasLink sub => HasLink (Header' mods sym a :> sub) where
type MkLink (Header sym a :> sub) = MkLink sub 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) toLink _ = toLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (RemoteHost :> sub) where 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 type MkLink (BasicAuth realm a :> sub) = MkLink sub
toLink _ = toLink (Proxy :: Proxy sub) toLink _ = toLink (Proxy :: Proxy sub)
instance HasLink EmptyAPI where
type MkLink EmptyAPI = EmptyAPI
toLink _ _ = EmptyAPI
-- Verb (terminal) instances -- Verb (terminal) instances
instance HasLink (Verb m s ct a) where instance HasLink (Verb m s ct a) where
type MkLink (Verb m s ct a) = Link 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 ConstraintKinds #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
#if __GLASGOW__HASKELL < 709
{-# OPTIONS_GHC -fcontext-stack=41 #-}
#endif
module Servant.Utils.LinksSpec where module Servant.Utils.LinksSpec where
import Data.Proxy (Proxy (..)) import Data.Proxy (Proxy (..))
@ -11,11 +15,13 @@ import Test.Hspec (Expectation, Spec, describe, it,
import Data.String (fromString) import Data.String (fromString)
import Servant.API import Servant.API
import Servant.Utils.Links (allLinks) import Servant.Utils.Links (allLinks, linkURI)
import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw)
type TestApi = type TestApi =
-- Capture and query params -- Capture and query params
"hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete '[JSON] NoContent "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 :<|> "all" :> CaptureAll "names" String :> Get '[JSON] NoContent
-- Flags -- Flags
@ -55,6 +61,11 @@ spec = describe "Servant.Utils.Links" $ do
:> Delete '[JSON] NoContent) :> Delete '[JSON] NoContent)
apiLink l2 "bye" (Just True) `shouldBeLink` "hello/bye?capital=true" 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 it "generates correct links for CaptureAll" $ do
apiLink (Proxy :: Proxy ("all" :> CaptureAll "names" String :> Get '[JSON] NoContent)) apiLink (Proxy :: Proxy ("all" :> CaptureAll "names" String :> Get '[JSON] NoContent))
["roads", "lead", "to", "rome"] ["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 it "can generate all links for an API that has only linkable endpoints" $ do
let (allNames :<|> simple) = allLinks (Proxy :: Proxy LinkableApi) let (allNames :<|> simple) = allLinks (Proxy :: Proxy LinkableApi)
simple simple `shouldBeLink` "get"
`shouldBeLink` "get" allNames ["Seneca", "Aurelius"] `shouldBeLink` "all/Seneca/Aurelius"
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, -- 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... -- ...Could not deduce...
-- ... -- ...
-- --
-- >>> apiLink (Proxy :: Proxy NoEndpoint) -- >>> linkURI $ apiLink (Proxy :: Proxy NoEndpoint)
-- ... -- ...
-- ...No instance for... -- <interactive>...
-- ... -- ...
-- --
-- sanity check -- sanity check