From bc3f61d61561363af60eb14b1b3d5fb313124e40 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sun, 10 Dec 2017 14:25:14 +0200 Subject: [PATCH] Add Servant.API.Modifiers to servant 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). --- .../Servant/Client/Core/Internal/HasClient.hs | 58 +++---- servant-docs/src/Servant/Docs/Internal.hs | 12 +- servant-docs/test/Servant/DocsSpec.hs | 4 +- servant-foreign/servant-foreign.cabal | 9 +- .../src/Servant/Foreign/Internal.hs | 29 ++-- servant-foreign/test/Servant/ForeignSpec.hs | 6 +- servant-server/src/Servant/Server/Internal.hs | 115 ++++++++------ servant-server/test/Servant/ServerSpec.hs | 12 +- servant/servant.cabal | 4 +- servant/src/Servant/API.hs | 18 ++- servant/src/Servant/API/Header.hs | 16 +- .../API/Internal/Test/ComprehensiveAPI.hs | 3 + servant/src/Servant/API/Modifiers.hs | 150 ++++++++++++++++++ servant/src/Servant/API/QueryParam.hs | 9 +- servant/src/Servant/API/ReqBody.hs | 15 +- servant/src/Servant/API/ResponseHeaders.hs | 19 ++- servant/src/Servant/Utils/Links.hs | 64 ++++++-- servant/test/Servant/Utils/LinksSpec.hs | 26 ++- 18 files changed, 421 insertions(+), 148 deletions(-) create mode 100644 servant/src/Servant/API/Modifiers.hs diff --git a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs index ef5bdce4..cf2ec85d 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs @@ -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 = diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index f71430d6..26da3a1c 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -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 diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index 370e2306..eedc18a9 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/servant-docs/test/Servant/DocsSpec.hs @@ -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" diff --git a/servant-foreign/servant-foreign.cabal b/servant-foreign/servant-foreign.cabal index 64eb98ef..454701e8 100644 --- a/servant-foreign/servant-foreign.cabal +++ b/servant-foreign/servant-foreign.cabal @@ -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 diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index a06ec46c..87892b69 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -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) $ diff --git a/servant-foreign/test/Servant/ForeignSpec.hs b/servant-foreign/test/Servant/ForeignSpec.hs index 18e4985c..3c48c3f7 100644 --- a/servant-foreign/test/Servant/ForeignSpec.hs +++ b/servant-foreign/test/Servant/ForeignSpec.hs @@ -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" diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index ba005ff0..aa37eaf1 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -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@. diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index f2d86785..0073c7cb 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -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" $ diff --git a/servant/servant.cabal b/servant/servant.cabal index 15ea3e80..0674f7bc 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -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 diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 84f3d861..9e9af80a 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -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 (..)) diff --git a/servant/src/Servant/API/Header.hs b/servant/src/Servant/API/Header.hs index 2f46f160..a10dbd03 100644 --- a/servant/src/Servant/API/Header.hs +++ b/servant/src/Servant/API/Header.hs @@ -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 diff --git a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs index cf3e1213..b628e88b 100644 --- a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs +++ b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs @@ -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 :<|> diff --git a/servant/src/Servant/API/Modifiers.hs b/servant/src/Servant/API/Modifiers.hs new file mode 100644 index 00000000..f34f5bf9 --- /dev/null +++ b/servant/src/Servant/API/Modifiers.hs @@ -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 diff --git a/servant/src/Servant/API/QueryParam.hs b/servant/src/Servant/API/QueryParam.hs index c05e9206..ffa66051 100644 --- a/servant/src/Servant/API/QueryParam.hs +++ b/servant/src/Servant/API/QueryParam.hs @@ -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= -- >>> 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 diff --git a/servant/src/Servant/API/ReqBody.hs b/servant/src/Servant/API/ReqBody.hs index 36393601..512b77ce 100644 --- a/servant/src/Servant/API/ReqBody.hs +++ b/servant/src/Servant/API/ReqBody.hs @@ -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 diff --git a/servant/src/Servant/API/ResponseHeaders.hs b/servant/src/Servant/API/ResponseHeaders.hs index 42e15678..41880aec 100644 --- a/servant/src/Servant/API/ResponseHeaders.hs +++ b/servant/src/Servant/API/ResponseHeaders.hs @@ -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 ) diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index a7d8a6ea..44921d1e 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/src/Servant/Utils/Links.hs @@ -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 diff --git a/servant/test/Servant/Utils/LinksSpec.hs b/servant/test/Servant/Utils/LinksSpec.hs index 7215c0b7..db900942 100644 --- a/servant/test/Servant/Utils/LinksSpec.hs +++ b/servant/test/Servant/Utils/LinksSpec.hs @@ -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... +-- ... -- ... -- -- sanity check