module WebGear.Middlewares.Params
(
QueryParam
, QueryParam'
, ParamNotFound (..)
, ParamParseError (..)
, queryParam
, optionalQueryParam
, lenientQueryParam
, optionalLenientQueryParam
) where
import Control.Arrow (Kleisli (..))
import Control.Monad ((>=>))
import Data.List (find)
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 (queryToQueryText)
import Text.Printf (printf)
import Web.HttpApiData (FromHttpApiData (..))
import WebGear.Modifiers (Existence (..), ParseStyle (..))
import WebGear.Trait (Result (..), Trait (..), probe)
import WebGear.Types (MonadRouter (..), Request, RequestMiddleware', Response (..), badRequest400,
queryString)
import qualified Data.ByteString.Lazy as LBS
type QueryParam (name :: Symbol) val = QueryParam' Required Strict name val
data QueryParam' (e :: Existence) (p :: ParseStyle) (name :: Symbol) val
data ParamNotFound = ParamNotFound
deriving stock (Read, Show, Eq)
newtype ParamParseError = ParamParseError Text
deriving stock (Read, Show, Eq)
deriveRequestParam :: (KnownSymbol name, FromHttpApiData val)
=> Proxy name -> Request -> (Maybe (Either Text val) -> r) -> r
deriveRequestParam proxy req cont =
let name = fromString $ symbolVal proxy
params = queryToQueryText $ queryString req
in cont $ parseQueryParam <$> (find ((== name) . fst) params >>= snd)
instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (QueryParam' Required Strict name val) Request m where
type Attribute (QueryParam' Required Strict name val) Request = val
type Absence (QueryParam' Required Strict name val) Request = Either ParamNotFound ParamParseError
toAttribute :: Request -> m (Result (QueryParam' Required Strict name val) Request)
toAttribute r = pure $ deriveRequestParam (Proxy @name) r $ \case
Nothing -> NotFound (Left ParamNotFound)
Just (Left e) -> NotFound (Right $ ParamParseError e)
Just (Right x) -> Found x
instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (QueryParam' Optional Strict name val) Request m where
type Attribute (QueryParam' Optional Strict name val) Request = Maybe val
type Absence (QueryParam' Optional Strict name val) Request = ParamParseError
toAttribute :: Request -> m (Result (QueryParam' Optional Strict name val) Request)
toAttribute r = pure $ deriveRequestParam (Proxy @name) r $ \case
Nothing -> Found Nothing
Just (Left e) -> NotFound $ ParamParseError e
Just (Right x) -> Found (Just x)
instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (QueryParam' Required Lenient name val) Request m where
type Attribute (QueryParam' Required Lenient name val) Request = Either Text val
type Absence (QueryParam' Required Lenient name val) Request = ParamNotFound
toAttribute :: Request -> m (Result (QueryParam' Required Lenient name val) Request)
toAttribute r = pure $ deriveRequestParam (Proxy @name) r $ \case
Nothing -> NotFound ParamNotFound
Just (Left e) -> Found (Left e)
Just (Right x) -> Found (Right x)
instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (QueryParam' Optional Lenient name val) Request m where
type Attribute (QueryParam' Optional Lenient name val) Request = Maybe (Either Text val)
type Absence (QueryParam' Optional Lenient name val) Request = Void
toAttribute :: Request -> m (Result (QueryParam' Optional Lenient name val) Request)
toAttribute r = pure $ deriveRequestParam (Proxy @name) r $ \case
Nothing -> Found Nothing
Just (Left e) -> Found (Just (Left e))
Just (Right x) -> Found (Just (Right x))
queryParam :: forall name val m req a. (KnownSymbol name, FromHttpApiData val, MonadRouter m)
=> RequestMiddleware' m req (QueryParam name val:req) a
queryParam handler = Kleisli $ probe @(QueryParam name val) >=> either (errorResponse . mkError) (runKleisli handler)
where
paramName :: String
paramName = symbolVal $ Proxy @name
mkError :: Either ParamNotFound ParamParseError -> Response LBS.ByteString
mkError err = badRequest400 $ fromString $
case err of
Left ParamNotFound -> printf "Could not find query parameter %s" paramName
Right (ParamParseError _) -> printf "Invalid value for query parameter %s" paramName
optionalQueryParam :: forall name val m req a. (KnownSymbol name, FromHttpApiData val, MonadRouter m)
=> RequestMiddleware' m req (QueryParam' Optional Strict name val:req) a
optionalQueryParam handler = Kleisli $ probe @(QueryParam' Optional Strict name val) >=> either (errorResponse . mkError) (runKleisli handler)
where
paramName :: String
paramName = symbolVal $ Proxy @name
mkError :: ParamParseError -> Response LBS.ByteString
mkError _ = badRequest400 $ fromString $ printf "Invalid value for query parameter %s" paramName
lenientQueryParam :: forall name val m req a. (KnownSymbol name, FromHttpApiData val, MonadRouter m)
=> RequestMiddleware' m req (QueryParam' Required Lenient name val:req) a
lenientQueryParam handler = Kleisli $
probe @(QueryParam' Required Lenient name val) >=> either (errorResponse . mkError) (runKleisli handler)
where
paramName :: String
paramName = symbolVal $ Proxy @name
mkError :: ParamNotFound -> Response LBS.ByteString
mkError ParamNotFound = badRequest400 $ fromString $ printf "Could not find query parameter %s" paramName
optionalLenientQueryParam :: forall name val m req a. (KnownSymbol name, FromHttpApiData val, MonadRouter m)
=> RequestMiddleware' m req (QueryParam' Optional Lenient name val:req) a
optionalLenientQueryParam handler = Kleisli $
probe @(QueryParam' Optional Lenient name val) >=> either absurd (runKleisli handler)