Add Servant.API.Modifiers to servant

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

First step to implement
haskell-servant#856
Only adjust Links implementation.

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

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,
@@ -77,10 +79,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)
 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,
@@ -98,7 +101,7 @@ 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,

servant/src/Servant/API/Header.hs

@@ -4,24 +4,25 @@
 {-# 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)
+
 -- | Extract the given header's value as a value of type @a@.
+-- I.e. header sent by client, parsed by server.
 --
 -- Example:
 --
 -- >>> newtype Referer = Referer Text deriving (Eq, Show)
 -- >>>
 -- >>>            -- 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' '[]
+
+data Header' (mods :: [*]) (sym :: Symbol) a
+    deriving Typeable
 
 -- $setup
 -- >>> import Servant.API

servant/src/Servant/API/Modifiers.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE DataKinds      #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE TypeFamilies   #-}
+{-# LANGUAGE TypeOperators  #-}
+module Servant.API.Modifiers (
+    -- * Required / optional argument
+    Required, Optional,
+    FoldRequired, FoldRequired',
+    -- * Lenient / strict parsing
+    Lenient, Strict,
+    FoldLenient, FoldLenient',
+    ) where
+
+-- | 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
+
+-- $setup
+-- >>> import Servant.API

servant/src/Servant/API/QueryParam.hs

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

servant/src/Servant/API/ResponseHeaders.hs

@@ -23,6 +23,7 @@
 -- example above).
 module Servant.API.ResponseHeaders
     ( Headers(..)
+    , ResponseHeader (..)
     , AddHeader
     , addHeader
     , noHeader
@@ -32,15 +33,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 +54,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 +118,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,16 @@ 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.RemoteHost ( RemoteHost )
 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.Experimental.Auth ( AuthProtect )
 
 -- | A safe link datatype.
@@ -262,14 +267,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)
@@ -299,8 +305,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)
@@ -317,8 +323,8 @@ instance (ToHttpApiData v, HasLink sub)
         toLink (Proxy :: Proxy sub) $
             foldl' (flip $ addSegment . escape . 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 (RemoteHost :> sub) where

servant/test/Servant/Utils/LinksSpec.hs

@@ -16,6 +16,7 @@ import           Servant.Utils.Links     (allLinks)
 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 +56,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"]