module WebGear.Middlewares.Header
(
Header
, Header'
, HeaderNotFound (..)
, HeaderParseError (..)
, HeaderMatch
, HeaderMatch'
, HeaderMismatch (..)
, header
, optionalHeader
, lenientHeader
, optionalLenientHeader
, headerMatch
, optionalHeaderMatch
, requestContentTypeHeader
, addResponseHeader
) where
import Control.Arrow (Kleisli (..))
import Control.Monad ((>=>))
import Data.ByteString (ByteString)
import Data.Kind (Type)
import Data.Proxy (Proxy (..))
import Data.String (fromString)
import Data.Text (Text)
import Data.Void (Void, absurd)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Network.HTTP.Types (HeaderName)
import Text.Printf (printf)
import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..))
import WebGear.Modifiers (Existence (..), ParseStyle (..))
import WebGear.Trait (Result (..), Trait (..), probe)
import WebGear.Types (MonadRouter (..), Request, RequestMiddleware', Response (..),
ResponseMiddleware', badRequest400, requestHeader, responseHeader,
setResponseHeader)
import qualified Data.ByteString.Lazy as LBS
data Header' (e :: Existence) (p :: ParseStyle) (name :: Symbol) (val :: Type)
type Header (name :: Symbol) (val :: Type) = Header' Required Strict name val
data HeaderNotFound = HeaderNotFound
deriving stock (Read, Show, Eq)
newtype HeaderParseError = HeaderParseError Text
deriving stock (Read, Show, Eq)
deriveRequestHeader :: (KnownSymbol name, FromHttpApiData val)
=> Proxy name -> Request -> (Maybe (Either Text val) -> r) -> r
deriveRequestHeader proxy req cont =
let s = fromString $ symbolVal proxy
in cont $ parseHeader <$> requestHeader s req
deriveResponseHeader :: (KnownSymbol name, FromHttpApiData val)
=> Proxy name -> Response a -> (Maybe (Either Text val) -> r) -> r
deriveResponseHeader proxy res cont =
let s = fromString $ symbolVal proxy
in cont $ parseHeader <$> responseHeader s res
instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Required Strict name val) Request m where
type Attribute (Header' Required Strict name val) Request = val
type Absence (Header' Required Strict name val) Request = Either HeaderNotFound HeaderParseError
toAttribute :: Request -> m (Result (Header' Required Strict name val) Request)
toAttribute r = pure $ deriveRequestHeader (Proxy @name) r $ \case
Nothing -> NotFound (Left HeaderNotFound)
Just (Left e) -> NotFound (Right $ HeaderParseError e)
Just (Right x) -> Found x
instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Optional Strict name val) Request m where
type Attribute (Header' Optional Strict name val) Request = Maybe val
type Absence (Header' Optional Strict name val) Request = HeaderParseError
toAttribute :: Request -> m (Result (Header' Optional Strict name val) Request)
toAttribute r = pure $ deriveRequestHeader (Proxy @name) r $ \case
Nothing -> Found Nothing
Just (Left e) -> NotFound $ HeaderParseError e
Just (Right x) -> Found (Just x)
instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Required Lenient name val) Request m where
type Attribute (Header' Required Lenient name val) Request = Either Text val
type Absence (Header' Required Lenient name val) Request = HeaderNotFound
toAttribute :: Request -> m (Result (Header' Required Lenient name val) Request)
toAttribute r = pure $ deriveRequestHeader (Proxy @name) r $ \case
Nothing -> NotFound HeaderNotFound
Just (Left e) -> Found (Left e)
Just (Right x) -> Found (Right x)
instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Optional Lenient name val) Request m where
type Attribute (Header' Optional Lenient name val) Request = Maybe (Either Text val)
type Absence (Header' Optional Lenient name val) Request = Void
toAttribute :: Request -> m (Result (Header' Optional Lenient name val) Request)
toAttribute r = pure $ deriveRequestHeader (Proxy @name) r $ \case
Nothing -> Found Nothing
Just (Left e) -> Found (Just (Left e))
Just (Right x) -> Found (Just (Right x))
instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Required Strict name val) (Response a) m where
type Attribute (Header' Required Strict name val) (Response a) = val
type Absence (Header' Required Strict name val) (Response a) = Either HeaderNotFound HeaderParseError
toAttribute :: Response a -> m (Result (Header' Required Strict name val) (Response a))
toAttribute r = pure $ deriveResponseHeader (Proxy @name) r $ \case
Nothing -> NotFound (Left HeaderNotFound)
Just (Left e) -> NotFound (Right $ HeaderParseError e)
Just (Right x) -> Found x
instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Optional Strict name val) (Response a) m where
type Attribute (Header' Optional Strict name val) (Response a) = Maybe val
type Absence (Header' Optional Strict name val) (Response a) = HeaderParseError
toAttribute :: Response a -> m (Result (Header' Optional Strict name val) (Response a))
toAttribute r = pure $ deriveResponseHeader (Proxy @name) r $ \case
Nothing -> Found Nothing
Just (Left e) -> NotFound $ HeaderParseError e
Just (Right x) -> Found (Just x)
instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Required Lenient name val) (Response a) m where
type Attribute (Header' Required Lenient name val) (Response a) = Either Text val
type Absence (Header' Required Lenient name val) (Response a) = HeaderNotFound
toAttribute :: Response a -> m (Result (Header' Required Lenient name val) (Response a))
toAttribute r = pure $ deriveResponseHeader (Proxy @name) r $ \case
Nothing -> NotFound HeaderNotFound
Just (Left e) -> Found (Left e)
Just (Right x) -> Found (Right x)
instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Optional Lenient name val) (Response a) m where
type Attribute (Header' Optional Lenient name val) (Response a) = Maybe (Either Text val)
type Absence (Header' Optional Lenient name val) (Response a) = ()
toAttribute :: Response a -> m (Result (Header' Optional Lenient name val) (Response a))
toAttribute r = pure $ deriveResponseHeader (Proxy @name) r $ \case
Nothing -> Found Nothing
Just (Left e) -> Found (Just (Left e))
Just (Right x) -> Found (Just (Right x))
data HeaderMatch' (e :: Existence) (name :: Symbol) (val :: Symbol)
type HeaderMatch (name :: Symbol) (val :: Symbol) = HeaderMatch' Required name val
data HeaderMismatch = HeaderMismatch
{ expectedHeader :: ByteString
, actualHeader :: ByteString
}
deriving stock (Eq, Read, Show)
instance (KnownSymbol name, KnownSymbol val, Monad m) => Trait (HeaderMatch' Required name val) Request m where
type Attribute (HeaderMatch' Required name val) Request = ()
type Absence (HeaderMatch' Required name val) Request = Maybe HeaderMismatch
toAttribute :: Request -> m (Result (HeaderMatch' Required name val) Request)
toAttribute r = pure $
let
name = fromString $ symbolVal (Proxy @name)
expected = fromString $ symbolVal (Proxy @val)
in
case requestHeader name r of
Nothing -> NotFound Nothing
Just hv | hv == expected -> Found ()
| otherwise -> NotFound $ Just HeaderMismatch {expectedHeader = expected, actualHeader = hv}
instance (KnownSymbol name, KnownSymbol val, Monad m) => Trait (HeaderMatch' Optional name val) Request m where
type Attribute (HeaderMatch' Optional name val) Request = Maybe ()
type Absence (HeaderMatch' Optional name val) Request = HeaderMismatch
toAttribute :: Request -> m (Result (HeaderMatch' Optional name val) Request)
toAttribute r = pure $
let
name = fromString $ symbolVal (Proxy @name)
expected = fromString $ symbolVal (Proxy @val)
in
case requestHeader name r of
Nothing -> Found Nothing
Just hv | hv == expected -> Found (Just ())
| otherwise -> NotFound HeaderMismatch {expectedHeader = expected, actualHeader = hv}
header :: forall name val m req a.
(KnownSymbol name, FromHttpApiData val, MonadRouter m)
=> RequestMiddleware' m req (Header name val:req) a
header handler = Kleisli $
probe @(Header name val) >=> either (errorResponse . mkError) (runKleisli handler)
where
headerName :: String
headerName = symbolVal $ Proxy @name
mkError :: Either HeaderNotFound HeaderParseError -> Response LBS.ByteString
mkError (Left HeaderNotFound) = badRequest400 $ fromString $ printf "Could not find header %s" headerName
mkError (Right (HeaderParseError _)) = badRequest400 $ fromString $
printf "Invalid value for header %s" headerName
optionalHeader :: forall name val m req a.
(KnownSymbol name, FromHttpApiData val, MonadRouter m)
=> RequestMiddleware' m req (Header' Optional Strict name val:req) a
optionalHeader handler = Kleisli $
probe @(Header' Optional Strict name val) >=> either (errorResponse . mkError) (runKleisli handler)
where
headerName :: String
headerName = symbolVal $ Proxy @name
mkError :: HeaderParseError -> Response LBS.ByteString
mkError (HeaderParseError _) = badRequest400 $ fromString $
printf "Invalid value for header %s" headerName
lenientHeader :: forall name val m req a.
(KnownSymbol name, FromHttpApiData val, MonadRouter m)
=> RequestMiddleware' m req (Header' Required Lenient name val:req) a
lenientHeader handler = Kleisli $
probe @(Header' Required Lenient name val) >=> either (errorResponse . mkError) (runKleisli handler)
where
headerName :: String
headerName = symbolVal $ Proxy @name
mkError :: HeaderNotFound -> Response LBS.ByteString
mkError HeaderNotFound = badRequest400 $ fromString $ printf "Could not find header %s" headerName
optionalLenientHeader :: forall name val m req a.
(KnownSymbol name, FromHttpApiData val, MonadRouter m)
=> RequestMiddleware' m req (Header' Optional Lenient name val:req) a
optionalLenientHeader handler = Kleisli $
probe @(Header' Optional Lenient name val) >=> either absurd (runKleisli handler)
headerMatch :: forall name val m req a.
(KnownSymbol name, KnownSymbol val, MonadRouter m)
=> RequestMiddleware' m req (HeaderMatch name val:req) a
headerMatch handler = Kleisli $
probe @(HeaderMatch name val) >=> either (errorResponse . mkError) (runKleisli handler)
where
headerName :: String
headerName = symbolVal $ Proxy @name
mkError :: Maybe HeaderMismatch -> Response LBS.ByteString
mkError Nothing = badRequest400 $ fromString $ printf "Could not find header %s" headerName
mkError (Just e) = badRequest400 $ fromString $
printf "Expected header %s to have value %s but found %s" headerName (show $ expectedHeader e) (show $ actualHeader e)
optionalHeaderMatch :: forall name val m req a.
(KnownSymbol name, KnownSymbol val, MonadRouter m)
=> RequestMiddleware' m req (HeaderMatch' Optional name val:req) a
optionalHeaderMatch handler = Kleisli $
probe @(HeaderMatch' Optional name val) >=> either (errorResponse . mkError) (runKleisli handler)
where
headerName :: String
headerName = symbolVal $ Proxy @name
mkError :: HeaderMismatch -> Response LBS.ByteString
mkError e = badRequest400 $ fromString $
printf "Expected header %s to have value %s but found %s" headerName (show $ expectedHeader e) (show $ actualHeader e)
requestContentTypeHeader :: forall val m req a. (KnownSymbol val, MonadRouter m)
=> RequestMiddleware' m req (HeaderMatch "Content-Type" val:req) a
requestContentTypeHeader = headerMatch @"Content-Type" @val
addResponseHeader :: forall t m req a. (ToHttpApiData t, Monad m)
=> HeaderName -> t -> ResponseMiddleware' m req a a
addResponseHeader name val handler = Kleisli $ runKleisli handler >=> pure . setResponseHeader name (toHeader val)