Merge pull request #873 from phadej/modifiers

Servant.API.Modifiers

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)
+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 :: 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
 -- 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)
+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
   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,
 -- 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 =

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)
+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 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

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"

servant-foreign/servant-foreign.cabal

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

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)
+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 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)
+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 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
+      => 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 :: Proxy api) $

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"

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,
+                                              IsSecure(..), Header', QueryFlag,
-                                              QueryParam, QueryParams, Raw,
+                                              QueryParam', QueryParams, Raw,
-                                              RemoteHost, ReqBody, Vault,
+                                              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)
+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
 
   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
+          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 "
-                                   <> fromString headerName
+                               <> headerName
                                <> " failed: " <> e
               }
-              Right hdr -> return $ Just hdr
 
 -- | 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)
+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
 
   route Proxy context subserver =
     let querytext req = parseQueryText $ rawQueryString req
+        paramname = cs $ symbolVal (Proxy :: Proxy sym)
+
+        parseParam :: Request -> DelayedIO (RequestArgument mods a)
         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 "
                                <> 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
+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
 
@@ -588,7 +609,9 @@ 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
+        case sbool :: SBool (FoldLenient mods) of
+          STrue -> return mrqbody
+          SFalse -> case mrqbody of
             Left e  -> delayedFailFatal err400 { errBody = cs e }
             Right v -> return v
 

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 a -> Proxy (HeaderApi a)
-headerApi = Proxy
+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" $

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

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 (..))

servant/src/Servant/API/Header.hs

@@ -4,13 +4,15 @@
 {-# LANGUAGE PolyKinds          #-}
 {-# OPTIONS_HADDOCK not-home    #-}
 module Servant.API.Header (
-  Header(..),
+    Header, Header',
-) where
+    ) 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
+type Header = Header' '[Optional, Strict]
-                              | MissingHeader
+
-                              | UndecodableHeader ByteString
+data Header' (mods :: [*]) (sym :: Symbol) a
-    deriving (Typeable, Eq, Show, Functor)
+    deriving Typeable
 
 -- $setup
 -- >>> import Servant.API

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 :<|>

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

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=<author name>
 -- >>> type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]
-data QueryParam (sym :: Symbol) (a :: *)
+type QueryParam = QueryParam' '[Optional, Strict]
+
+-- | 'QueryParam' which can be 'Required', 'Lenient', or modified otherwise.
+data QueryParam' (mods :: [*]) (sym :: Symbol) (a :: *)
     deriving Typeable
 
 -- | Lookup the values associated to the @sym@ query string parameter

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
+
 -- | 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

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 )

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.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.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)
+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 (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
+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)
 
 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
+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)
 
 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

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
+        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,
@@ -112,9 +124,9 @@ spec = describe "Servant.Utils.Links" $ do
 -- ...Could not deduce...
 -- ...
 --
--- >>> apiLink (Proxy :: Proxy NoEndpoint)
+-- >>> linkURI $ apiLink (Proxy :: Proxy NoEndpoint)
 -- ...
--- ...No instance for...
+-- <interactive>...
 -- ...
 --
 -- sanity check