{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts, AllowAmbiguousTypes, FlexibleInstances, IncoherentInstances, UndecidableInstances, PolyKinds, BlockArguments, DataKinds #-}

{-|
Module: IHP.Controller.Param
Description: Accessing query parameters and the request body
Copyright: (c) digitally induced GmbH, 2020
-}
module IHP.Controller.Param where

import IHP.Prelude
import qualified Data.Either as Either
import IHP.Controller.RequestContext
import qualified Network.Wai as Wai
import qualified Data.UUID as UUID
import qualified IHP.ModelSupport as ModelSupport
import qualified Data.ByteString.Char8 as Char8
import IHP.ValidationSupport
import GHC.TypeLits
import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec
import qualified GHC.Float as Float
import qualified Control.Exception as Exception
import IHP.Controller.Context
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.KeyMap as Aeson
import qualified Data.Aeson.Key as Aeson
import qualified Data.Scientific as Scientific
import qualified Data.Vector as Vector
import qualified Control.DeepSeq as DeepSeq
import Text.Read (readMaybe)

-- | Returns a query or body parameter from the current request. The raw string
-- value is parsed before returning it. So the return value type depends on what
-- you expect (e.g. can be Int, Text, UUID, Bool, some custom type).
--
-- When the parameter is missing or cannot be parsed, an exception is thrown and
-- the current action is aborted. Use 'paramOrDefault' when you want to get a
-- default value instead of an exception, or 'paramOrNothing' to get @Nothing@
-- when the parameter is missing.
--
-- You can define a custom parameter parser by defining a 'ParamReader' instance.
--
-- __Example:__ Accessing a query parameter.
--
-- Let's say the request is:
--
-- > GET /UsersAction?maxItems=50
--
-- We can read @maxItems@ like this:
--
-- > action UsersAction = do
-- >     let maxItems :: Int = param "maxItems"
--
--
-- __Example:__ Working with forms (Accessing a body parameter).
--
-- Let's say we have the following html form:
--
-- > <form method="POST" action="/HelloWorld"
-- >     <input type="text" name="firstname" placeholder="Your firstname" />
-- >     <button type="submit">Send</button>
-- > </form>
--
-- The form has firstname text field and a send button.
-- When the form is submitted, it's send to @/HelloWorld@.
--
-- The following action reads the value of the submitted firstname and prints out @Hello firstname@:
--
-- > action HelloWorldAction = do
-- >     let firstname = param "firstname"
-- >     renderPlain ("Hello " <> firstname)
--
--
-- __Example:__ Missing parameters
--
-- Let's say the request is:
--
-- > GET /HelloWorldAction
--
-- But the action requires us to provide a firstname, like:
--
-- > action HelloWorldAction = do
-- >     let firstname = param "firstname"
-- >     renderPlain ("Hello " <> firstname)
--
-- Running the request @GET /HelloWorldAction@ without the firstname parameter will cause an
-- 'ParamNotFoundException' to be thrown with:
--
-- > param: Parameter 'firstname' not found
param :: (?context :: ControllerContext) => (ParamReader valueType) => ByteString -> valueType
param :: forall valueType.
(?context::ControllerContext, ParamReader valueType) =>
ByteString -> valueType
param !ByteString
name = case ByteString -> Either ParamException valueType
forall paramType.
(?context::ControllerContext, ParamReader paramType) =>
ByteString -> Either ParamException paramType
paramOrError ByteString
name of
        Left ParamException
exception -> ParamException -> valueType
forall a e. Exception e => e -> a
Exception.throw ParamException
exception
        Right valueType
value -> valueType
value
{-# INLINABLE param #-}

-- | Similiar to 'param' but works with multiple params. Useful when working with checkboxes.
--
-- Given a query like:
--
-- > ingredients=milk&ingredients=egg
--
-- This will return:
--
-- >>> paramList @Text "ingredients"
-- ["milk", "egg"]
--
-- When no parameter with the name is given, an empty list is returned:
--
-- >>> paramList @Text "not_given_in_url"
-- []
--
-- When a value cannot be parsed, this function will fail similiar to 'param'.
--
-- Related: https://stackoverflow.com/questions/63875081/how-can-i-pass-list-params-in-ihp-forms/63879113
paramList :: forall valueType. (?context :: ControllerContext, DeepSeq.NFData valueType, ParamReader valueType) => ByteString -> [valueType]
paramList :: forall valueType.
(?context::ControllerContext, NFData valueType,
 ParamReader valueType) =>
ByteString -> [valueType]
paramList ByteString
name =
    [(ByteString, Maybe ByteString)]
(?context::ControllerContext) => [(ByteString, Maybe ByteString)]
allParams
    [(ByteString, Maybe ByteString)]
-> ([(ByteString, Maybe ByteString)]
    -> [(ByteString, Maybe ByteString)])
-> [(ByteString, Maybe ByteString)]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> ((ByteString, Maybe ByteString) -> Bool)
-> [(ByteString, Maybe ByteString)]
-> [(ByteString, Maybe ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(ByteString
paramName, Maybe ByteString
paramValue) -> ByteString
paramName ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
name)
    [(ByteString, Maybe ByteString)]
-> ([(ByteString, Maybe ByteString)] -> [ByteString])
-> [ByteString]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> ((ByteString, Maybe ByteString) -> Maybe ByteString)
-> [(ByteString, Maybe ByteString)] -> [ByteString]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(ByteString
paramName, Maybe ByteString
paramValue) -> Maybe ByteString
paramValue)
    [ByteString]
-> ([ByteString] -> [Either ByteString valueType])
-> [Either ByteString valueType]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (ByteString -> Either ByteString valueType)
-> [ByteString] -> [Either ByteString valueType]
forall a b. (a -> b) -> [a] -> [b]
map (forall a. ParamReader a => ByteString -> Either ByteString a
readParameter @valueType)
    [Either ByteString valueType]
-> ([Either ByteString valueType] -> [valueType]) -> [valueType]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Either ByteString valueType -> valueType)
-> [Either ByteString valueType] -> [valueType]
forall a b. (a -> b) -> [a] -> [b]
map (valueType -> Either ByteString valueType -> valueType
forall b a. b -> Either a b -> b
Either.fromRight (Text -> valueType
forall a. Text -> a
error (ByteString -> Text
forall {a} {a}.
(Semigroup a, IsString a, ConvertibleStrings a a) =>
a -> a
paramParserErrorMessage ByteString
name)))
    [valueType] -> ([valueType] -> [valueType]) -> [valueType]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> [valueType] -> [valueType]
forall a. NFData a => a -> a
DeepSeq.force
{-# INLINABLE paramList #-}

-- | Similiar to 'paramOrNothing' but works with multiple params. This is useful when submitting multiple
-- input fields with the same name, and some may be empty.
--
-- Given a query like (note the `ingredients` in the middle that has no value):
--
-- > ingredients=milk&ingredients&ingredients=egg
--
-- This will return:
--
-- >>> paramListOrNothing @Text "ingredients"
-- [Just "milk", Nothing, Just "egg"]
--
-- When no parameter with the name is given, an empty list is returned:
--
-- >>> paramListOrNothing @Text "not_given_in_url"
-- []
--
--
paramListOrNothing :: forall valueType. (?context :: ControllerContext, DeepSeq.NFData valueType, ParamReader valueType) => ByteString -> [Maybe valueType]
paramListOrNothing :: forall valueType.
(?context::ControllerContext, NFData valueType,
 ParamReader valueType) =>
ByteString -> [Maybe valueType]
paramListOrNothing ByteString
name =
    [(ByteString, Maybe ByteString)]
(?context::ControllerContext) => [(ByteString, Maybe ByteString)]
allParams
    [(ByteString, Maybe ByteString)]
-> ([(ByteString, Maybe ByteString)]
    -> [(ByteString, Maybe ByteString)])
-> [(ByteString, Maybe ByteString)]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> ((ByteString, Maybe ByteString) -> Bool)
-> [(ByteString, Maybe ByteString)]
-> [(ByteString, Maybe ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(ByteString
paramName, Maybe ByteString
paramValue) -> ByteString
paramName ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
name)
    [(ByteString, Maybe ByteString)]
-> ([(ByteString, Maybe ByteString)] -> [ByteString])
-> [ByteString]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> ((ByteString, Maybe ByteString) -> Maybe ByteString)
-> [(ByteString, Maybe ByteString)] -> [ByteString]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(ByteString
paramName, Maybe ByteString
paramValue) -> Maybe ByteString
paramValue)
    [ByteString]
-> ([ByteString] -> [Either ByteString valueType])
-> [Either ByteString valueType]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (ByteString -> Either ByteString valueType)
-> [ByteString] -> [Either ByteString valueType]
forall a b. (a -> b) -> [a] -> [b]
map (\ByteString
paramValue -> if ByteString
paramValue ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"" then ByteString -> Either ByteString valueType
forall a b. a -> Either a b
Left ByteString
"Empty ByteString" else forall a. ParamReader a => ByteString -> Either ByteString a
readParameter @valueType ByteString
paramValue)
    [Either ByteString valueType]
-> ([Either ByteString valueType] -> [Maybe valueType])
-> [Maybe valueType]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Either ByteString valueType -> Maybe valueType)
-> [Either ByteString valueType] -> [Maybe valueType]
forall a b. (a -> b) -> [a] -> [b]
map (\Either ByteString valueType
value -> case Either ByteString valueType
value of
            Left ByteString
_ -> Maybe valueType
forall a. Maybe a
Nothing
            Right valueType
val -> valueType -> Maybe valueType
forall a. a -> Maybe a
Just valueType
val
        )
    [Maybe valueType]
-> ([Maybe valueType] -> [Maybe valueType]) -> [Maybe valueType]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> [Maybe valueType] -> [Maybe valueType]
forall a. NFData a => a -> a
DeepSeq.force
{-# INLINABLE paramListOrNothing #-}

paramParserErrorMessage :: a -> a
paramParserErrorMessage a
name = a
"param: Parameter '" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a -> a
forall a b. ConvertibleStrings a b => a -> b
cs a
name a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"' is invalid"

-- | Thrown when a parameter is missing when calling 'param "myParam"' or related functions
data ParamException
    = ParamNotFoundException { ParamException -> ByteString
name :: ByteString }
    | ParamCouldNotBeParsedException { name :: ByteString, ParamException -> ByteString
parserError :: ByteString }
    deriving (Int -> ParamException -> ShowS
[ParamException] -> ShowS
ParamException -> String
(Int -> ParamException -> ShowS)
-> (ParamException -> String)
-> ([ParamException] -> ShowS)
-> Show ParamException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParamException -> ShowS
showsPrec :: Int -> ParamException -> ShowS
$cshow :: ParamException -> String
show :: ParamException -> String
$cshowList :: [ParamException] -> ShowS
showList :: [ParamException] -> ShowS
Show, ParamException -> ParamException -> Bool
(ParamException -> ParamException -> Bool)
-> (ParamException -> ParamException -> Bool) -> Eq ParamException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ParamException -> ParamException -> Bool
== :: ParamException -> ParamException -> Bool
$c/= :: ParamException -> ParamException -> Bool
/= :: ParamException -> ParamException -> Bool
Eq)

instance Exception ParamException where
    displayException :: ParamException -> String
displayException (ParamNotFoundException { ByteString
name :: ParamException -> ByteString
name :: ByteString
name }) = String
"param: Parameter '" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"' not found"
    displayException (ParamCouldNotBeParsedException { ByteString
name :: ParamException -> ByteString
name :: ByteString
name, ByteString
parserError :: ParamException -> ByteString
parserError :: ByteString
parserError }) = String
"param: Parameter '" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"' could not be parsed, " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
parserError

-- | Specialized version of param for 'Text'.
--
-- This way you don't need to know about the type application syntax.
paramText :: (?context :: ControllerContext) => ByteString -> Text
paramText :: (?context::ControllerContext) => ByteString -> Text
paramText = forall valueType.
(?context::ControllerContext, ParamReader valueType) =>
ByteString -> valueType
param @Text

-- | Specialized version of param for 'Int'.
--
-- This way you don't need to know about the type application syntax.
paramInt :: (?context :: ControllerContext) => ByteString -> Int
paramInt :: (?context::ControllerContext) => ByteString -> Int
paramInt = forall valueType.
(?context::ControllerContext, ParamReader valueType) =>
ByteString -> valueType
param @Int

-- | Specialized version of param for 'Bool'.
--
-- This way you don't need to know about the type application syntax.
paramBool :: (?context :: ControllerContext) => ByteString -> Bool
paramBool :: (?context::ControllerContext) => ByteString -> Bool
paramBool = forall valueType.
(?context::ControllerContext, ParamReader valueType) =>
ByteString -> valueType
param @Bool

-- | Specialized version of param for 'UUID'.
--
-- This way you don't need to know about the type application syntax.
paramUUID :: (?context :: ControllerContext) => ByteString -> UUID
paramUUID :: (?context::ControllerContext) => ByteString -> UUID
paramUUID = forall valueType.
(?context::ControllerContext, ParamReader valueType) =>
ByteString -> valueType
param @UUID

-- | Returns @True@ when a parameter is given in the request via the query or request body.
--
-- Use 'paramOrDefault' when you want to use this for providing a default value.
--
-- __Example:__
--
-- Given the request @GET /HelloWorld@
--
-- > action HelloWorldAction = do
-- >     if hasParam "firstname"
-- >         then ...
-- >         else renderPlain "Please provide your firstname"
--
-- This will render @Please provide your firstname@ because @hasParam "firstname"@ returns @False@
hasParam :: (?context :: ControllerContext) => ByteString -> Bool
hasParam :: (?context::ControllerContext) => ByteString -> Bool
hasParam = Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ByteString -> Bool)
-> (ByteString -> Maybe ByteString) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (?context::ControllerContext) => ByteString -> Maybe ByteString
ByteString -> Maybe ByteString
queryOrBodyParam
{-# INLINABLE hasParam #-}

-- | Like 'param', but returns a default value when the parameter is missing instead of throwing
-- an exception.
--
-- Use 'paramOrNothing' when you want to get @Maybe@.
--
-- __Example:__ Pagination
--
-- When calling @GET /Users@ the variable @page@ will be set to the default value @0@.
--
-- > action UsersAction = do
-- >     let page :: Int = paramOrDefault 0 "page"
--
-- When calling @GET /Users?page=1@ the variable @page@ will be set to @1@.
paramOrDefault :: (?context :: ControllerContext) => ParamReader a => a -> ByteString -> a
paramOrDefault :: forall a.
(?context::ControllerContext, ParamReader a) =>
a -> ByteString -> a
paramOrDefault !a
defaultValue = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
defaultValue (Maybe a -> a) -> (ByteString -> Maybe a) -> ByteString -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Maybe a
forall paramType.
(?context::ControllerContext, ParamReader (Maybe paramType)) =>
ByteString -> Maybe paramType
paramOrNothing
{-# INLINABLE paramOrDefault #-}

-- | Like 'param', but returns @Nothing@ the parameter is missing instead of throwing
-- an exception.
--
-- Use 'paramOrDefault' when you want to deal with a default value.
--
-- __Example:__
--
-- When calling @GET /Users@ the variable @page@ will be set to @Nothing@.
--
-- > action UsersAction = do
-- >     let page :: Maybe Int = paramOrNothing "page"
--
-- When calling @GET /Users?page=1@ the variable @page@ will be set to @Just 1@.
paramOrNothing :: forall paramType. (?context :: ControllerContext) => ParamReader (Maybe paramType) => ByteString -> Maybe paramType
paramOrNothing :: forall paramType.
(?context::ControllerContext, ParamReader (Maybe paramType)) =>
ByteString -> Maybe paramType
paramOrNothing !ByteString
name =
    case ByteString -> Either ParamException (Maybe paramType)
forall paramType.
(?context::ControllerContext, ParamReader paramType) =>
ByteString -> Either ParamException paramType
paramOrError ByteString
name of
        Left ParamNotFoundException {} -> Maybe paramType
forall a. Maybe a
Nothing
        Left ParamException
otherException -> ParamException -> Maybe paramType
forall a e. Exception e => e -> a
Exception.throw ParamException
otherException
        Right Maybe paramType
value -> Maybe paramType
value
{-# INLINABLE paramOrNothing #-}

-- | Like 'param', but returns @Left "Some error message"@ if the parameter is missing or invalid
paramOrError :: forall paramType. (?context :: ControllerContext) => ParamReader paramType => ByteString -> Either ParamException paramType
paramOrError :: forall paramType.
(?context::ControllerContext, ParamReader paramType) =>
ByteString -> Either ParamException paramType
paramOrError !ByteString
name =
    let
        RequestContext { RequestBody
requestBody :: RequestBody
requestBody :: RequestContext -> RequestBody
requestBody } = ?context::ControllerContext
ControllerContext
?context.requestContext
    in case RequestBody
requestBody of
        FormBody {} -> case (?context::ControllerContext) => ByteString -> Maybe ByteString
ByteString -> Maybe ByteString
queryOrBodyParam ByteString
name of
                Just ByteString
value -> case forall a. ParamReader a => ByteString -> Either ByteString a
readParameter @paramType ByteString
value of
                    Left ByteString
parserError -> ParamException -> Either ParamException paramType
forall a b. a -> Either a b
Left ParamCouldNotBeParsedException { ByteString
name :: ByteString
name :: ByteString
name, ByteString
parserError :: ByteString
parserError :: ByteString
parserError }
                    Right paramType
value -> paramType -> Either ParamException paramType
forall a b. b -> Either a b
Right paramType
value
                Maybe ByteString
Nothing -> ParamException -> Either ParamException paramType
forall a b. a -> Either a b
Left ParamNotFoundException { ByteString
name :: ByteString
name :: ByteString
name }
        JSONBody { Maybe Value
jsonPayload :: Maybe Value
jsonPayload :: RequestBody -> Maybe Value
jsonPayload } -> case Maybe Value
jsonPayload of
                (Just (Aeson.Object Object
hashMap)) -> case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
Aeson.lookup (Text -> Key
Aeson.fromText (Text -> Key) -> Text -> Key
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
name) Object
hashMap of
                    Just Value
value -> case forall a. ParamReader a => Value -> Either ByteString a
readParameterJSON @paramType Value
value of
                        Left ByteString
parserError -> ParamException -> Either ParamException paramType
forall a b. a -> Either a b
Left ParamCouldNotBeParsedException { ByteString
name :: ByteString
name :: ByteString
name, ByteString
parserError :: ByteString
parserError :: ByteString
parserError }
                        Right paramType
value -> paramType -> Either ParamException paramType
forall a b. b -> Either a b
Right paramType
value
                    Maybe Value
Nothing -> ParamException -> Either ParamException paramType
forall a b. a -> Either a b
Left ParamNotFoundException { ByteString
name :: ByteString
name :: ByteString
name }
                Maybe Value
_ -> ParamException -> Either ParamException paramType
forall a b. a -> Either a b
Left ParamNotFoundException { ByteString
name :: ByteString
name :: ByteString
name }
{-# INLINABLE paramOrError #-}

-- | Returns a parameter without any parsing. Returns @Nothing@ when the parameter is missing.
queryOrBodyParam :: (?context :: ControllerContext) => ByteString -> Maybe ByteString
queryOrBodyParam :: (?context::ControllerContext) => ByteString -> Maybe ByteString
queryOrBodyParam !ByteString
name = Maybe (Maybe ByteString) -> Maybe ByteString
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (ByteString
-> [(ByteString, Maybe ByteString)] -> Maybe (Maybe ByteString)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
name [(ByteString, Maybe ByteString)]
(?context::ControllerContext) => [(ByteString, Maybe ByteString)]
allParams)
{-# INLINABLE queryOrBodyParam #-}

-- | Returns all params available in the current request
allParams :: (?context :: ControllerContext) => [(ByteString, Maybe ByteString)]
allParams :: (?context::ControllerContext) => [(ByteString, Maybe ByteString)]
allParams = case RequestBody
requestBody of
            FormBody { [Param]
params :: [Param]
params :: RequestBody -> [Param]
params, [File ByteString]
files :: [File ByteString]
files :: RequestBody -> [File ByteString]
files } -> [[(ByteString, Maybe ByteString)]]
-> [(ByteString, Maybe ByteString)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [((Param -> (ByteString, Maybe ByteString))
-> [Param] -> [(ByteString, Maybe ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
a, ByteString
b) -> (ByteString
a, ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
b)) [Param]
params), (Request -> [(ByteString, Maybe ByteString)]
Wai.queryString Request
request)]
            JSONBody { Maybe Value
jsonPayload :: RequestBody -> Maybe Value
jsonPayload :: Maybe Value
jsonPayload } -> Text -> [(ByteString, Maybe ByteString)]
forall a. Text -> a
error Text
"allParams: Not supported for JSON requests"
    where
        RequestContext { Request
request :: Request
request :: RequestContext -> Request
request, RequestBody
requestBody :: RequestContext -> RequestBody
requestBody :: RequestBody
requestBody } = ?context::ControllerContext
ControllerContext
?context.requestContext

-- | Input parser for 'param'.
--
-- Parses the input bytestring. Returns @Left "some error"@ when there is an error parsing the value.
-- Returns @Right value@ when the parsing succeeded.
class ParamReader a where
    -- | The error messages here should be human-readable, as they're visible e.g. in forms
    readParameter :: ByteString -> Either ByteString a
    -- | The error messages here are directed at other developers, so they can be a bit more technical than 'readParameter' errors
    readParameterJSON :: Aeson.Value -> Either ByteString a
    readParameterJSON = Value -> Either ByteString a
forall a. ParamReader a => Value -> Either ByteString a
enumParamReaderJSON

instance ParamReader ByteString where
    {-# INLINABLE readParameter #-}
    readParameter :: ByteString -> Either ByteString ByteString
readParameter ByteString
byteString = ByteString -> Either ByteString ByteString
forall a. a -> Either ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
byteString

    readParameterJSON :: Value -> Either ByteString ByteString
readParameterJSON (Aeson.String Text
bytestring) = ByteString -> Either ByteString ByteString
forall a b. b -> Either a b
Right (Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
bytestring)
    readParameterJSON Value
_ = ByteString -> Either ByteString ByteString
forall a b. a -> Either a b
Left ByteString
"Expected String"

instance ParamReader Int where
    {-# INLINABLE readParameter #-}
    readParameter :: ByteString -> Either ByteString Int
readParameter ByteString
byteString =
        case Parser Int -> ByteString -> Either String Int
forall a. Parser a -> ByteString -> Either String a
Attoparsec.parseOnly ((Parser Int -> Parser Int
forall a. Num a => Parser a -> Parser a
Attoparsec.signed Parser Int
forall a. Integral a => Parser a
Attoparsec.decimal) Parser Int -> Parser ByteString () -> Parser Int
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
Attoparsec.endOfInput) ByteString
byteString of
            Right Int
value -> Int -> Either ByteString Int
forall a b. b -> Either a b
Right Int
value
            Left String
error -> ByteString -> Either ByteString Int
forall a b. a -> Either a b
Left ByteString
"has to be an integer"

    readParameterJSON :: Value -> Either ByteString Int
readParameterJSON (Aeson.Number Scientific
number) =
            case Scientific -> Either Double Int
forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
Scientific.floatingOrInteger Scientific
number of
                    Left Double
float -> ByteString -> Either ByteString Int
forall a b. a -> Either a b
Left ByteString
"Expected Int"
                    Right Int
int -> Int -> Either ByteString Int
forall a b. b -> Either a b
Right Int
int
    readParameterJSON Value
_ = ByteString -> Either ByteString Int
forall a b. a -> Either a b
Left ByteString
"Expected Int"

instance ParamReader Integer where
    {-# INLINABLE readParameter #-}
    readParameter :: ByteString -> Either ByteString Integer
readParameter ByteString
byteString =
        case Parser Integer -> ByteString -> Either String Integer
forall a. Parser a -> ByteString -> Either String a
Attoparsec.parseOnly ((Parser Integer -> Parser Integer
forall a. Num a => Parser a -> Parser a
Attoparsec.signed Parser Integer
forall a. Integral a => Parser a
Attoparsec.decimal) Parser Integer -> Parser ByteString () -> Parser Integer
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
Attoparsec.endOfInput) ByteString
byteString of
            Right Integer
value -> Integer -> Either ByteString Integer
forall a b. b -> Either a b
Right Integer
value
            Left String
error -> ByteString -> Either ByteString Integer
forall a b. a -> Either a b
Left ByteString
"has to be an integer"

    readParameterJSON :: Value -> Either ByteString Integer
readParameterJSON (Aeson.Number Scientific
number) =
            case Scientific -> Either Double Integer
forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
Scientific.floatingOrInteger Scientific
number of
                    Left Double
float -> ByteString -> Either ByteString Integer
forall a b. a -> Either a b
Left ByteString
"Expected Integer"
                    Right Integer
integer -> Integer -> Either ByteString Integer
forall a b. b -> Either a b
Right Integer
integer
    readParameterJSON Value
_ = ByteString -> Either ByteString Integer
forall a b. a -> Either a b
Left ByteString
"Expected Integer"

instance ParamReader Double where
    {-# INLINABLE readParameter #-}
    readParameter :: ByteString -> Either ByteString Double
readParameter ByteString
byteString =
        case Parser Double -> ByteString -> Either String Double
forall a. Parser a -> ByteString -> Either String a
Attoparsec.parseOnly (Parser Double
Attoparsec.double Parser Double -> Parser ByteString () -> Parser Double
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
Attoparsec.endOfInput) ByteString
byteString of
            Right Double
value -> Double -> Either ByteString Double
forall a b. b -> Either a b
Right Double
value
            Left String
error -> ByteString -> Either ByteString Double
forall a b. a -> Either a b
Left ByteString
"has to be a number with decimals"

    readParameterJSON :: Value -> Either ByteString Double
readParameterJSON (Aeson.Number Scientific
number) =
            case Scientific -> Either Double Integer
forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
Scientific.floatingOrInteger Scientific
number of
                    Left Double
double -> Double -> Either ByteString Double
forall a b. b -> Either a b
Right Double
double
                    Right Integer
integer -> Double -> Either ByteString Double
forall a b. b -> Either a b
Right (Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
integer)
    readParameterJSON Value
_ = ByteString -> Either ByteString Double
forall a b. a -> Either a b
Left ByteString
"Expected Double"

instance ParamReader Scientific.Scientific where
    {-# INLINABLE readParameter #-}
    readParameter :: ByteString -> Either ByteString Scientific
readParameter ByteString
byteString =
        case Parser Scientific -> ByteString -> Either String Scientific
forall a. Parser a -> ByteString -> Either String a
Attoparsec.parseOnly (Parser Scientific
Attoparsec.scientific Parser Scientific -> Parser ByteString () -> Parser Scientific
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
Attoparsec.endOfInput) ByteString
byteString of
            Right Scientific
value -> Scientific -> Either ByteString Scientific
forall a b. b -> Either a b
Right Scientific
value
            Left String
error -> ByteString -> Either ByteString Scientific
forall a b. a -> Either a b
Left ByteString
"has to be a number with decimals"

    readParameterJSON :: Value -> Either ByteString Scientific
readParameterJSON (Aeson.Number Scientific
number) = Scientific -> Either ByteString Scientific
forall a b. b -> Either a b
Right Scientific
number
    readParameterJSON Value
_ = ByteString -> Either ByteString Scientific
forall a b. a -> Either a b
Left ByteString
"Expected Scientific"

instance ParamReader Float where
    {-# INLINABLE readParameter #-}
    readParameter :: ByteString -> Either ByteString Float
readParameter ByteString
byteString =
        case Parser Double -> ByteString -> Either String Double
forall a. Parser a -> ByteString -> Either String a
Attoparsec.parseOnly (Parser Double
Attoparsec.double Parser Double -> Parser ByteString () -> Parser Double
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
Attoparsec.endOfInput) ByteString
byteString of
            Right Double
value -> Float -> Either ByteString Float
forall a b. b -> Either a b
Right (Double -> Float
Float.double2Float Double
value)
            Left String
error -> ByteString -> Either ByteString Float
forall a b. a -> Either a b
Left ByteString
"has to be a number with decimals"

    readParameterJSON :: Value -> Either ByteString Float
readParameterJSON (Aeson.Number Scientific
number) =
            case Scientific -> Either Float Integer
forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
Scientific.floatingOrInteger Scientific
number of
                    Left Float
double -> Float -> Either ByteString Float
forall a b. b -> Either a b
Right Float
double
                    Right Integer
integer -> Float -> Either ByteString Float
forall a b. b -> Either a b
Right (Integer -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
integer)
    readParameterJSON Value
_ = ByteString -> Either ByteString Float
forall a b. a -> Either a b
Left ByteString
"Expected Float"

instance ParamReader ModelSupport.Point where
    {-# INLINABLE readParameter #-}
    readParameter :: ByteString -> Either ByteString Point
readParameter ByteString
byteString =
        case Parser Point -> ByteString -> Either String Point
forall a. Parser a -> ByteString -> Either String a
Attoparsec.parseOnly (do Double
x <- Parser Double
Attoparsec.double; Char -> Parser Char
Attoparsec.char Char
','; Double
y <- Parser Double
Attoparsec.double; Parser ByteString ()
forall t. Chunk t => Parser t ()
Attoparsec.endOfInput; Point -> Parser Point
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModelSupport.Point { Double
x :: Double
x :: Double
x, Double
y :: Double
y :: Double
y }) ByteString
byteString of
            Right Point
value -> Point -> Either ByteString Point
forall a b. b -> Either a b
Right Point
value
            Left String
error -> ByteString -> Either ByteString Point
forall a b. a -> Either a b
Left ByteString
"has to be two numbers with a comma, e.g. '1,2'"

    readParameterJSON :: Value -> Either ByteString Point
readParameterJSON (Aeson.String Text
string) = let ByteString
byteString :: ByteString = Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
string in  ByteString -> Either ByteString Point
forall a. ParamReader a => ByteString -> Either ByteString a
readParameter ByteString
byteString
    readParameterJSON Value
_ = ByteString -> Either ByteString Point
forall a b. a -> Either a b
Left ByteString
"Expected Point"

instance ParamReader ModelSupport.PGInterval where
    {-# INLINABLE readParameter #-}
    readParameter :: ByteString -> Either ByteString PGInterval
readParameter ByteString
byteString = PGInterval -> Either ByteString PGInterval
forall a. a -> Either ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> PGInterval
ModelSupport.PGInterval ByteString
byteString)

    readParameterJSON :: Value -> Either ByteString PGInterval
readParameterJSON (Aeson.String Text
bytestring) = PGInterval -> Either ByteString PGInterval
forall a b. b -> Either a b
Right (ByteString -> PGInterval
ModelSupport.PGInterval (Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
bytestring))
    readParameterJSON Value
_ = ByteString -> Either ByteString PGInterval
forall a b. a -> Either a b
Left ByteString
"Expected String"



instance ParamReader ModelSupport.Polygon where
    {-# INLINABLE readParameter #-}
    readParameter :: ByteString -> Either ByteString Polygon
readParameter ByteString
byteString =
        let
            pointParser :: Parser Point
pointParser = do
                Char -> Parser Char
Attoparsec.char Char
'('
                Double
x <- Parser Double
Attoparsec.double
                Char -> Parser Char
Attoparsec.char Char
','
                Double
y <- Parser Double
Attoparsec.double
                Char -> Parser Char
Attoparsec.char Char
')'
                Point -> Parser Point
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModelSupport.Point { Double
x :: Double
y :: Double
x :: Double
y :: Double
.. }
            parser :: Parser ByteString Polygon
parser = do
                [Point]
points <- Parser Point
pointParser Parser Point -> Parser Char -> Parser ByteString [Point]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`Attoparsec.sepBy` (Char -> Parser Char
Attoparsec.char Char
',')
                Parser ByteString ()
forall t. Chunk t => Parser t ()
Attoparsec.endOfInput
                Polygon -> Parser ByteString Polygon
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModelSupport.Polygon { [Point]
points :: [Point]
points :: [Point]
.. }
        in
        case Parser ByteString Polygon -> ByteString -> Either String Polygon
forall a. Parser a -> ByteString -> Either String a
Attoparsec.parseOnly Parser ByteString Polygon
parser ByteString
byteString of
            Right Polygon
value -> Polygon -> Either ByteString Polygon
forall a b. b -> Either a b
Right Polygon
value
            Left String
error -> ByteString -> Either ByteString Polygon
forall a b. a -> Either a b
Left ByteString
"has to be points wrapped in parenthesis, separated with a comma, e.g. '(1,2),(3,4)'"

    readParameterJSON :: Value -> Either ByteString Polygon
readParameterJSON (Aeson.String Text
string) = let ByteString
byteString :: ByteString = Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
string in ByteString -> Either ByteString Polygon
forall a. ParamReader a => ByteString -> Either ByteString a
readParameter ByteString
byteString
    readParameterJSON Value
_ = ByteString -> Either ByteString Polygon
forall a b. a -> Either a b
Left ByteString
"Expected Polygon"

instance ParamReader Text where
    {-# INLINABLE readParameter #-}
    readParameter :: ByteString -> Either ByteString Text
readParameter ByteString
byteString = Text -> Either ByteString Text
forall a. a -> Either ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
byteString)

    readParameterJSON :: Value -> Either ByteString Text
readParameterJSON (Aeson.String Text
text) = Text -> Either ByteString Text
forall a b. b -> Either a b
Right Text
text
    readParameterJSON Value
_ = ByteString -> Either ByteString Text
forall a b. a -> Either a b
Left ByteString
"Expected String"

-- | Parses comma separated input like @userIds=1,2,3@
--
-- __Example:__
--
-- >>> let userIds :: [Int] = param "userIds"
instance ParamReader value => ParamReader [value] where
    {-# INLINABLE readParameter #-}
    readParameter :: ByteString -> Either ByteString [value]
readParameter ByteString
byteString =
        ByteString
byteString
        ByteString -> (ByteString -> [ByteString]) -> [ByteString]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Char -> ByteString -> [ByteString]
Char8.split Char
','
        [ByteString]
-> ([ByteString] -> [Either ByteString value])
-> [Either ByteString value]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (ByteString -> Either ByteString value)
-> [ByteString] -> [Either ByteString value]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Either ByteString value
forall a. ParamReader a => ByteString -> Either ByteString a
readParameter
        [Either ByteString value]
-> ([Either ByteString value] -> ([ByteString], [value]))
-> ([ByteString], [value])
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> [Either ByteString value] -> ([ByteString], [value])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers
        ([ByteString], [value])
-> (([ByteString], [value]) -> Either ByteString [value])
-> Either ByteString [value]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> \case
            ([], [value]
values) -> [value] -> Either ByteString [value]
forall a b. b -> Either a b
Right [value]
values
            ((ByteString
first:[ByteString]
rest), [value]
_) -> ByteString -> Either ByteString [value]
forall a b. a -> Either a b
Left ByteString
first

    readParameterJSON :: Value -> Either ByteString [value]
readParameterJSON (Aeson.Array Array
values) =
        Array
values
        Array -> (Array -> [Value]) -> [Value]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Array -> [Value]
forall a. Vector a -> [a]
Vector.toList
        [Value]
-> ([Value] -> [Either ByteString value])
-> [Either ByteString value]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Value -> Either ByteString value)
-> [Value] -> [Either ByteString value]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Either ByteString value
forall a. ParamReader a => Value -> Either ByteString a
readParameterJSON
        [Either ByteString value]
-> ([Either ByteString value] -> ([ByteString], [value]))
-> ([ByteString], [value])
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> [Either ByteString value] -> ([ByteString], [value])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers
        ([ByteString], [value])
-> (([ByteString], [value]) -> Either ByteString [value])
-> Either ByteString [value]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> \case
            ([], [value]
values) -> [value] -> Either ByteString [value]
forall a b. b -> Either a b
Right [value]
values
            ((ByteString
first:[ByteString]
rest), [value]
_) -> ByteString -> Either ByteString [value]
forall a b. a -> Either a b
Left ByteString
first
    readParameterJSON Value
_ = ByteString -> Either ByteString [value]
forall a b. a -> Either a b
Left ByteString
"Expected Array"

-- | Parses a boolean.
--
-- Html form checkboxes usually use @on@ or @off@ for representation. These
-- values are supported here.
instance ParamReader Bool where
    {-# INLINABLE readParameter #-}
    readParameter :: ByteString -> Either ByteString Bool
readParameter ByteString
on | ByteString
on ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Bool -> Text
forall a. InputValue a => a -> Text
ModelSupport.inputValue Bool
True) = Bool -> Either ByteString Bool
forall a. a -> Either ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    readParameter ByteString
true | Text -> Text
toLower (ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
true) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"true" = Bool -> Either ByteString Bool
forall a. a -> Either ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    readParameter ByteString
_ = Bool -> Either ByteString Bool
forall a. a -> Either ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

    readParameterJSON :: Value -> Either ByteString Bool
readParameterJSON (Aeson.Bool Bool
bool) = Bool -> Either ByteString Bool
forall a b. b -> Either a b
Right Bool
bool
    readParameterJSON Value
_ = ByteString -> Either ByteString Bool
forall a b. a -> Either a b
Left ByteString
"Expected Bool"

instance ParamReader UUID where
    {-# INLINABLE readParameter #-}
    readParameter :: ByteString -> Either ByteString UUID
readParameter ByteString
byteString =
        case ByteString -> Maybe UUID
UUID.fromASCIIBytes ByteString
byteString of
            Just UUID
uuid -> UUID -> Either ByteString UUID
forall a. a -> Either ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UUID
uuid
            Maybe UUID
Nothing -> ByteString -> Either ByteString UUID
forall a b. a -> Either a b
Left ByteString
"has to be an UUID"

    readParameterJSON :: Value -> Either ByteString UUID
readParameterJSON (Aeson.String Text
string) =
        case Text -> Maybe UUID
UUID.fromText Text
string of
            Just UUID
uuid -> UUID -> Either ByteString UUID
forall a. a -> Either ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UUID
uuid
            Maybe UUID
Nothing -> ByteString -> Either ByteString UUID
forall a b. a -> Either a b
Left ByteString
"Invalid UUID"
    readParameterJSON Value
_ = ByteString -> Either ByteString UUID
forall a b. a -> Either a b
Left ByteString
"Expected String with an UUID"

-- | Accepts values such as @2020-11-08T12:03:35Z@ or @2020-11-08@
instance ParamReader UTCTime where
    {-# INLINABLE readParameter #-}
    readParameter :: ByteString -> Either ByteString UTCTime
readParameter ByteString
"" = ByteString -> Either ByteString UTCTime
forall a b. a -> Either a b
Left ByteString
"This field cannot be empty"
    readParameter ByteString
byteString =
        let
            input :: String
input = (ByteString -> String
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
byteString)
            dateTime :: Maybe UTCTime
dateTime = Bool -> TimeLocale -> String -> String -> Maybe UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
"%Y-%m-%dT%H:%M:%S%QZ" String
input
            date :: Maybe UTCTime
date = Bool -> TimeLocale -> String -> String -> Maybe UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
"%Y-%-m-%-d" String
input
        in case Maybe UTCTime
dateTime of
            Maybe UTCTime
Nothing -> case Maybe UTCTime
date of
                Just UTCTime
value -> UTCTime -> Either ByteString UTCTime
forall a b. b -> Either a b
Right UTCTime
value
                Maybe UTCTime
Nothing -> ByteString -> Either ByteString UTCTime
forall a b. a -> Either a b
Left ByteString
"has to be a valid date and time, e.g. 2020-11-08T12:03:35Z"
            Just UTCTime
value -> UTCTime -> Either ByteString UTCTime
forall a b. b -> Either a b
Right UTCTime
value

    readParameterJSON :: Value -> Either ByteString UTCTime
readParameterJSON (Aeson.String Text
string) = ByteString -> Either ByteString UTCTime
forall a. ParamReader a => ByteString -> Either ByteString a
readParameter (Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
string)
    readParameterJSON Value
_ = ByteString -> Either ByteString UTCTime
forall a b. a -> Either a b
Left ByteString
"Expected String"

-- | Accepts values such as @2020-11-08T12:03:35Z@ or @2020-11-08@
instance ParamReader LocalTime where
    {-# INLINABLE readParameter #-}
    readParameter :: ByteString -> Either ByteString LocalTime
readParameter ByteString
"" = ByteString -> Either ByteString LocalTime
forall a b. a -> Either a b
Left ByteString
"This field cannot be empty"
    readParameter ByteString
byteString =
        let
            input :: String
input = (ByteString -> String
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
byteString)
            dateTime :: Maybe LocalTime
dateTime = Bool -> TimeLocale -> String -> String -> Maybe LocalTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
"%Y-%m-%dT%H:%M:%S%QZ" String
input
            date :: Maybe LocalTime
date = Bool -> TimeLocale -> String -> String -> Maybe LocalTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
"%Y-%-m-%-d" String
input
        in case Maybe LocalTime
dateTime of
            Maybe LocalTime
Nothing -> case Maybe LocalTime
date of
                Just LocalTime
value -> LocalTime -> Either ByteString LocalTime
forall a b. b -> Either a b
Right LocalTime
value
                Maybe LocalTime
Nothing -> ByteString -> Either ByteString LocalTime
forall a b. a -> Either a b
Left ByteString
"has to be a valid date and time, e.g. 2020-11-08T12:03:35Z"
            Just LocalTime
value -> LocalTime -> Either ByteString LocalTime
forall a b. b -> Either a b
Right LocalTime
value

    readParameterJSON :: Value -> Either ByteString LocalTime
readParameterJSON (Aeson.String Text
string) = ByteString -> Either ByteString LocalTime
forall a. ParamReader a => ByteString -> Either ByteString a
readParameter (Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
string)
    readParameterJSON Value
_ = ByteString -> Either ByteString LocalTime
forall a b. a -> Either a b
Left ByteString
"Expected String"

-- | Accepts values such as @2020-11-08@
instance ParamReader Day where
    {-# INLINABLE readParameter #-}
    readParameter :: ByteString -> Either ByteString Day
readParameter ByteString
"" = ByteString -> Either ByteString Day
forall a b. a -> Either a b
Left ByteString
"This field cannot be empty"
    readParameter ByteString
byteString =
        let
            input :: String
input = (ByteString -> String
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
byteString)
            date :: Maybe Day
date = Bool -> TimeLocale -> String -> String -> Maybe Day
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
"%Y-%-m-%-d" String
input
        in case Maybe Day
date of
            Just Day
value -> Day -> Either ByteString Day
forall a b. b -> Either a b
Right Day
value
            Maybe Day
Nothing -> ByteString -> Either ByteString Day
forall a b. a -> Either a b
Left ByteString
"has to be a date, e.g. 2020-11-08"

    readParameterJSON :: Value -> Either ByteString Day
readParameterJSON (Aeson.String Text
string) = ByteString -> Either ByteString Day
forall a. ParamReader a => ByteString -> Either ByteString a
readParameter (Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
string)
    readParameterJSON Value
_ = ByteString -> Either ByteString Day
forall a b. a -> Either a b
Left ByteString
"Expected String"

instance ParamReader TimeOfDay where
    {-# INLINABLE readParameter #-}
    readParameter :: ByteString -> Either ByteString TimeOfDay
readParameter ByteString
"" = ByteString -> Either ByteString TimeOfDay
forall a b. a -> Either a b
Left ByteString
"This field cannot be empty"
    readParameter ByteString
byteString =
        let
            input :: String
input = (ByteString -> String
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
byteString)
        in case String -> Maybe TimeOfDay
forall a. Read a => String -> Maybe a
readMaybe String
input of
            Just TimeOfDay
value -> TimeOfDay -> Either ByteString TimeOfDay
forall a b. b -> Either a b
Right TimeOfDay
value
            Maybe TimeOfDay
Nothing -> ByteString -> Either ByteString TimeOfDay
forall a b. a -> Either a b
Left ByteString
"has to be time in the format hh:mm:ss"

    readParameterJSON :: Value -> Either ByteString TimeOfDay
readParameterJSON (Aeson.String Text
string) = ByteString -> Either ByteString TimeOfDay
forall a. ParamReader a => ByteString -> Either ByteString a
readParameter (Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
string)
    readParameterJSON Value
_ = ByteString -> Either ByteString TimeOfDay
forall a b. a -> Either a b
Left ByteString
"Expected String"

instance {-# OVERLAPS #-} (ParamReader (ModelSupport.PrimaryKey model')) => ParamReader (ModelSupport.Id' model') where
    {-# INLINABLE readParameter #-}
    readParameter :: ByteString -> Either ByteString (Id' model')
readParameter ByteString
uuid = PrimaryKey model' -> Id' model'
forall (table :: Symbol). PrimaryKey table -> Id' table
ModelSupport.Id (PrimaryKey model' -> Id' model')
-> Either ByteString (PrimaryKey model')
-> Either ByteString (Id' model')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either ByteString (PrimaryKey model')
forall a. ParamReader a => ByteString -> Either ByteString a
readParameter ByteString
uuid
    readParameterJSON :: Value -> Either ByteString (Id' model')
readParameterJSON Value
value = PrimaryKey model' -> Id' model'
forall (table :: Symbol). PrimaryKey table -> Id' table
ModelSupport.Id (PrimaryKey model' -> Id' model')
-> Either ByteString (PrimaryKey model')
-> Either ByteString (Id' model')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either ByteString (PrimaryKey model')
forall a. ParamReader a => Value -> Either ByteString a
readParameterJSON Value
value

instance ParamReader param => ParamReader (Maybe param) where
    {-# INLINABLE readParameter #-}
    readParameter :: ByteString -> Either ByteString (Maybe param)
readParameter ByteString
param =
        case (ByteString -> Either ByteString param
forall a. ParamReader a => ByteString -> Either ByteString a
readParameter ByteString
param) :: Either ByteString param of
            Right param
value -> Maybe param -> Either ByteString (Maybe param)
forall a b. b -> Either a b
Right (param -> Maybe param
forall a. a -> Maybe a
Just param
value)
            Left ByteString
error | ByteString
param ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"" -> Maybe param -> Either ByteString (Maybe param)
forall a b. b -> Either a b
Right Maybe param
forall a. Maybe a
Nothing
            Left ByteString
error -> ByteString -> Either ByteString (Maybe param)
forall a b. a -> Either a b
Left ByteString
error

    readParameterJSON :: Value -> Either ByteString (Maybe param)
readParameterJSON Value
value =
        case (Value -> Either ByteString param
forall a. ParamReader a => Value -> Either ByteString a
readParameterJSON Value
value) :: Either ByteString param of
            Right param
value -> Maybe param -> Either ByteString (Maybe param)
forall a b. b -> Either a b
Right (param -> Maybe param
forall a. a -> Maybe a
Just param
value)
            Left ByteString
error | Value
value Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== (Text -> Value
Aeson.String Text
"") -> Maybe param -> Either ByteString (Maybe param)
forall a b. b -> Either a b
Right Maybe param
forall a. Maybe a
Nothing
            Left ByteString
error -> ByteString -> Either ByteString (Maybe param)
forall a b. a -> Either a b
Left ByteString
error

-- | Custom error hint when the 'param' is called with do-notation
--
-- __Example:__
--
-- > action Example = do
-- >     myParam <- param "hello"
--
-- Now a custom type error will be shown telling the user to use @let myParam = param "hello"@ instead of do-notation.
instance (TypeError ('Text ("Use 'let x = param \"..\"' instead of 'x <- param \"..\"'" :: Symbol))) => ParamReader  (IO param) where
    readParameter :: ByteString -> Either ByteString (IO param)
readParameter ByteString
_ = Text -> Either ByteString (IO param)
forall a. Text -> a
error Text
"Unreachable"
    readParameterJSON :: Value -> Either ByteString (IO param)
readParameterJSON Value
_ = Text -> Either ByteString (IO param)
forall a. Text -> a
error Text
"Unreachable"

-- | Can be used as a default implementation for 'readParameter' for enum structures
--
-- __Example:__
--
-- > data Color = Yellow | Red | Blue deriving (Enum)
-- >
-- > instance ParamReader Color where
-- >     readParameter = enumParamReader
-- >     readParameterJSON = enumParamReaderJSON
enumParamReader :: forall parameter. (Enum parameter, ModelSupport.InputValue parameter) => ByteString -> Either ByteString parameter
enumParamReader :: forall parameter.
(Enum parameter, InputValue parameter) =>
ByteString -> Either ByteString parameter
enumParamReader ByteString
string =
        case (parameter -> Bool) -> [parameter] -> Maybe parameter
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\parameter
value -> parameter -> Text
forall a. InputValue a => a -> Text
ModelSupport.inputValue parameter
value Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
string') [parameter]
forall enumType. Enum enumType => [enumType]
allEnumValues of
            Just parameter
value -> parameter -> Either ByteString parameter
forall a b. b -> Either a b
Right parameter
value
            Maybe parameter
Nothing -> ByteString -> Either ByteString parameter
forall a b. a -> Either a b
Left ByteString
"Invalid value"
    where
        string' :: Text
string' = ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
string

-- | Used as a default implementation for 'readParameterJSON'
--
-- __Example:__
--
-- > data Color = Yellow | Red | Blue deriving (Enum)
-- >
-- > instance ParamReader Color where
-- >     readParameter = enumParamReader
-- >     readParameterJSON = enumParamReaderJSON
enumParamReaderJSON :: forall parameter. (ParamReader parameter) => Aeson.Value -> Either ByteString parameter
enumParamReaderJSON :: forall a. ParamReader a => Value -> Either ByteString a
enumParamReaderJSON (Aeson.String Text
string) = ByteString -> Either ByteString parameter
forall a. ParamReader a => ByteString -> Either ByteString a
readParameter (Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
string)
enumParamReaderJSON Value
otherwise = ByteString -> Either ByteString parameter
forall a b. a -> Either a b
Left ByteString
"enumParamReaderJSON: Invalid value, expected a string but got something else"

-- | Provides the 'fill' function for mass-assignment of multiple parameters to a record
--
-- Accepts a type-level list of parameter names (type-list syntax is like @\@'["a", "b", "c"]@) and a record. Then each parameter is
-- read from the request using the 'param' API. The parameter value is written to the record
-- field.  Because the parameter is assigned to the record, the parameter name list can only
-- contain attribute names of the record.
--
-- When there is a parser error, the error will be attached as a validation error to the record. The
-- remaining parameters will continue to be read.
--
-- If a parameter is missing from the request, this will be ignored and the function proceeds as usual.
--
--
-- __Example:__
--
-- > action UpdateUserAction { userId } = do
-- >     user :: User <- fetch userId
-- >     user
-- >         |> fill @["firstname", "lastname", "email"]
--
-- This code will read the firstname, lastname and email from the request and assign them to the user.
class FillParams (params :: [Symbol]) record where
    fill :: (
        ?context :: ControllerContext
        , HasField "meta" record ModelSupport.MetaBag
        , SetField "meta" record ModelSupport.MetaBag
        ) => record -> record

instance FillParams ('[]) record where
    fill :: (?context::ControllerContext, HasField "meta" record MetaBag,
 SetField "meta" record MetaBag) =>
record -> record
fill !record
record = record
record
    {-# INLINE fill #-}

instance (FillParams rest record
    , KnownSymbol fieldName
    , SetField fieldName record fieldType
    , ParamReader fieldType
    , HasField "meta" record ModelSupport.MetaBag
    , SetField "meta" record ModelSupport.MetaBag
    ) => FillParams (fieldName:rest) record where
    fill :: (?context::ControllerContext, HasField "meta" record MetaBag,
 SetField "meta" record MetaBag) =>
record -> record
fill !record
record =
        let
            ByteString
name :: ByteString = String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$! (Proxy fieldName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @fieldName))
            record' :: record
record' = case ByteString -> Either ParamException fieldType
forall paramType.
(?context::ControllerContext, ParamReader paramType) =>
ByteString -> Either ParamException paramType
paramOrError ByteString
name of
                Right !(fieldType
value :: fieldType) -> forall (field :: Symbol) model value.
SetField field model value =>
value -> model -> model
setField @fieldName fieldType
value record
record
                Left ParamCouldNotBeParsedException { ByteString
parserError :: ParamException -> ByteString
parserError :: ByteString
parserError } -> Proxy fieldName -> Text -> record -> record
forall (field :: Symbol) model.
(KnownSymbol field, HasField "meta" model MetaBag,
 SetField "meta" model MetaBag) =>
Proxy field -> Text -> model -> model
attachFailure (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @fieldName) (ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
parserError) record
record
                Left ParamNotFoundException {} -> record
record
        in
            forall (params :: [Symbol]) record.
(FillParams params record, ?context::ControllerContext,
 HasField "meta" record MetaBag, SetField "meta" record MetaBag) =>
record -> record
fill @rest record
record'
    {-# INLINE fill #-}

ifValid :: (HasField "meta" model ModelSupport.MetaBag) => (Either model model -> IO r) -> model -> IO r
ifValid :: forall model r.
HasField "meta" model MetaBag =>
(Either model model -> IO r) -> model -> IO r
ifValid Either model model -> IO r
branch model
model = Either model model -> IO r
branch (Either model model -> IO r) -> Either model model -> IO r
forall a b. (a -> b) -> a -> b
$! if model -> Bool
forall record. HasField "meta" record MetaBag => record -> Bool
ModelSupport.isValid model
model
    then model -> Either model model
forall a b. b -> Either a b
Right model
model
    else model -> Either model model
forall a b. a -> Either a b
Left model
model
{-# INLINE ifValid #-}

ifNew :: forall record. (?context :: ControllerContext, ?modelContext :: ModelSupport.ModelContext, HasField "meta" record MetaBag) => (record -> record) -> record -> record
ifNew :: forall record.
(?context::ControllerContext, ?modelContext::ModelContext,
 HasField "meta" record MetaBag) =>
(record -> record) -> record -> record
ifNew record -> record
thenBlock record
record = if record -> Bool
forall record. HasField "meta" record MetaBag => record -> Bool
ModelSupport.isNew record
record then record -> record
thenBlock record
record else record
record


-- | Transforms @Just ""@ to @Nothing@
--
-- __Example:__ We have record called @Company@ with a optional field @comment :: Maybe Text@
--
-- When we have a form that submits the @comment@ field and the field is empty, it will not be @NULL@ inside the database,
-- instead it will be set to the empty string. To avoid this we can apply @emptyValueToNothing #comment@. This function
-- turns the empty string into a 'Nothing' value.
--
-- > action UpdateCompanyAction { companyId } = do
-- >     company <- fetch companyId
-- >     company
-- >         |> fill '["name", "comment"]
-- >         |> emptyValueToNothing #comment
-- >         |> updateRecord
emptyValueToNothing :: Proxy name -> model -> model
emptyValueToNothing Proxy name
field = Proxy name -> (Maybe mono -> Maybe mono) -> model -> model
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value,
 SetField name model value) =>
Proxy name -> (value -> value) -> model -> model
modify Proxy name
field (Maybe mono -> (mono -> Maybe mono) -> Maybe mono -> Maybe mono
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe mono
forall a. Maybe a
Nothing (\mono
value -> if mono -> Bool
forall mono. MonoFoldable mono => mono -> Bool
null mono
value then Maybe mono
forall a. Maybe a
Nothing else mono -> Maybe mono
forall a. a -> Maybe a
Just mono
value))