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,
@@ -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,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,109 @@
+{-# 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
+    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.
+--
+-- 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 value into '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,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,16 +2,24 @@
 {-# 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 Data.Typeable (Typeable)
+import Servant.API.Modifiers (Required)
 -- | 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' '[]
+
+-- | 
+--
+-- /Note:/ 'ReqBody'' is always 'Required'.
+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 )