From c3fb0ddec0a8c52cb49eb87de9eb9cd8d645294c 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-foreign.cabal | 9 +++++---- src/Servant/Foreign/Internal.hs | 29 ++++++++++++++--------------- test/Servant/ForeignSpec.hs | 6 ++++-- 3 files changed, 23 insertions(+), 21 deletions(-) diff --git a/servant-foreign.cabal b/servant-foreign.cabal index 64eb98e..454701e 100644 --- a/servant-foreign.cabal +++ b/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/src/Servant/Foreign/Internal.hs b/src/Servant/Foreign/Internal.hs index a06ec46..87892b6 100644 --- a/src/Servant/Foreign/Internal.hs +++ b/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/test/Servant/ForeignSpec.hs b/test/Servant/ForeignSpec.hs index 18e4985..3c48c3f 100644 --- a/test/Servant/ForeignSpec.hs +++ b/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"