122 lines
3.9 KiB
Haskell
122 lines
3.9 KiB
Haskell
{-# LANGUAGE TypeSynonymInstances #-}
|
|
{-# LANGUAGE OverlappingInstances #-} -- Parameter String
|
|
{-# LANGUAGE DeriveDataTypeable #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
module Yesod.Parameter
|
|
(
|
|
-- * Parameter
|
|
-- $param_overview
|
|
Parameter (..)
|
|
, ParamType (..)
|
|
, ParamName
|
|
, ParamValue
|
|
, ParamAttempt (..)
|
|
, ParamException
|
|
-- * Exceptions
|
|
, ParameterCountException (..)
|
|
, InvalidBool (..)
|
|
) where
|
|
|
|
import Data.Time.Calendar (Day)
|
|
import Control.Applicative
|
|
import Data.Typeable (Typeable)
|
|
import Control.Exception (Exception, SomeException (..))
|
|
import Data.Attempt
|
|
import qualified Safe.Failure as SF
|
|
import Data.Convertible.Text
|
|
|
|
-- FIXME instead of plain Attempt, an Attempt that defines better error
|
|
-- reporting (eg, multilingual)
|
|
|
|
-- $param_overview
|
|
-- In Restful, all of the underlying parameter values are strings. They can
|
|
-- come from multiple sources: GET parameters, URL rewriting (FIXME: link),
|
|
-- cookies, etc. However, most applications eventually want to convert
|
|
-- those strings into something else, like 'Int's. Additionally, it is
|
|
-- often desirable to allow multiple values, or no value at all.
|
|
--
|
|
-- That is what the parameter concept is for. A 'Parameter' is any value
|
|
-- which can be converted from a 'String', or list of 'String's.
|
|
|
|
-- | Where this parameter came from.
|
|
data ParamType =
|
|
GetParam
|
|
| PostParam
|
|
deriving (Eq, Show)
|
|
|
|
type ParamName = String
|
|
|
|
-- | The 'String' value of a parameter.
|
|
type ParamValue = String
|
|
|
|
-- | Anything which can be converted from a list of 'String's.
|
|
--
|
|
-- The default implementation of 'readParams' will error out if given
|
|
-- anything but 1 'ParamValue'. This is usually what you want.
|
|
--
|
|
-- Minimal complete definition: either 'readParam' or 'readParams'.
|
|
class Parameter a where
|
|
-- | Convert a string into the desired value, or explain why that can't
|
|
-- happen.
|
|
readParam :: ParamValue -> Attempt a
|
|
readParam = readParams . return
|
|
|
|
-- | Convert a list of strings into the desired value, or explain why
|
|
-- that can't happen.
|
|
readParams :: [ParamValue] -> Attempt a
|
|
readParams [x] = readParam x
|
|
readParams [] = failure MissingParameter
|
|
readParams xs = failure $ ExtraParameters $ length xs
|
|
|
|
data ParamAttempt v = ParamSuccess v
|
|
| ParamFailure ParamException
|
|
instance Functor ParamAttempt where
|
|
fmap _ (ParamFailure pf) = ParamFailure pf
|
|
fmap f (ParamSuccess v) = ParamSuccess $ f v
|
|
instance Applicative ParamAttempt where
|
|
pure = ParamSuccess
|
|
(ParamFailure pf1) <*> (ParamFailure pf2) = ParamFailure $ pf1 ++ pf2
|
|
(ParamFailure pf) <*> _ = ParamFailure pf
|
|
_ <*> ParamFailure pf = ParamFailure pf
|
|
(ParamSuccess f) <*> (ParamSuccess v) = ParamSuccess $ f v
|
|
instance Try ParamAttempt where
|
|
type Error ParamAttempt = ParamException
|
|
try (ParamSuccess v) = pure v
|
|
try (ParamFailure f) = failure f
|
|
type ParamException = [((ParamType, ParamName, [ParamValue]), SomeException)]
|
|
|
|
data ParameterCountException = MissingParameter | ExtraParameters Int
|
|
deriving (Show, Typeable)
|
|
instance Exception ParameterCountException
|
|
|
|
instance Parameter a => Parameter (Maybe a) where
|
|
readParams [] = return Nothing
|
|
readParams [x] = Just `fmap` readParam x
|
|
readParams xs = failure $ ExtraParameters $ length xs
|
|
|
|
instance Parameter a => Parameter [a] where
|
|
readParams = mapM readParam where
|
|
|
|
instance Parameter String where
|
|
readParam = return
|
|
|
|
instance Parameter Int where
|
|
readParam = ca
|
|
|
|
instance Parameter Integer where
|
|
readParam = SF.read
|
|
|
|
instance Parameter Day where
|
|
readParam = ca
|
|
|
|
-- for checkboxes; checks for presence or a "false" value
|
|
instance Parameter Bool where
|
|
readParams [] = return False
|
|
readParams ["false"] = return False -- FIXME more values?
|
|
readParams [_] = return True
|
|
readParams x = failure $ InvalidBool x
|
|
|
|
data InvalidBool = InvalidBool [ParamValue]
|
|
deriving (Show, Typeable)
|
|
instance Exception InvalidBool
|