120 lines
5.2 KiB
Haskell
120 lines
5.2 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Utils.Parameters
|
|
( GlobalGetParam(..)
|
|
, lookupGlobalGetParam, hasGlobalGetParam, lookupGlobalGetParams
|
|
, lookupGlobalGetParamForm, hasGlobalGetParamForm
|
|
, globalGetParamField
|
|
, GlobalPostParam(..)
|
|
, lookupGlobalPostParam, hasGlobalPostParam, lookupGlobalPostParams
|
|
, lookupGlobalPostParamForm, hasGlobalPostParamForm
|
|
, globalPostParamField, globalPostParamFields
|
|
, withGlobalPostParam
|
|
) where
|
|
|
|
import ClassyPrelude.Yesod
|
|
|
|
import Utils.PathPiece
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
import Data.Universe
|
|
|
|
import Control.Monad.Trans.Maybe (MaybeT(..))
|
|
|
|
import Control.Lens
|
|
|
|
|
|
data GlobalGetParam = GetLang
|
|
| GetReferer
|
|
| GetBearer
|
|
| GetRecipient
|
|
| GetCsvExampleData
|
|
| GetDryRun
|
|
| GetDownload
|
|
| GetError
|
|
| GetSelectTable
|
|
| GetGenerateToken
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
nullaryPathPiece' ''GlobalGetParam $ \n -> if
|
|
| n == 'GetLang -> "_LANG"
|
|
| otherwise -> nameToPathPiece' 1 n
|
|
|
|
lookupGlobalGetParam :: (MonadHandler m, PathPiece result) => GlobalGetParam -> m (Maybe result)
|
|
lookupGlobalGetParam ident = (>>= fromPathPiece) <$> lookupGetParam (toPathPiece ident)
|
|
|
|
hasGlobalGetParam :: MonadHandler m => GlobalGetParam -> m Bool
|
|
hasGlobalGetParam ident = isJust <$> lookupGetParam (toPathPiece ident)
|
|
|
|
lookupGlobalGetParams :: (MonadHandler m, PathPiece result) => GlobalGetParam -> m [result]
|
|
lookupGlobalGetParams ident = mapMaybe fromPathPiece <$> lookupGetParams (toPathPiece ident)
|
|
|
|
|
|
lookupGlobalGetParamForm :: (Monad m, PathPiece result) => GlobalGetParam -> MForm m (Maybe result)
|
|
lookupGlobalGetParamForm ident = runMaybeT $ do
|
|
ps <- MaybeT askParams
|
|
MaybeT . return $ Map.lookup (toPathPiece ident) ps >>= listToMaybe >>= fromPathPiece
|
|
|
|
hasGlobalGetParamForm :: Monad m => GlobalGetParam -> MForm m Bool
|
|
hasGlobalGetParamForm ident = maybe False (Map.member $ toPathPiece ident) <$> askParams
|
|
|
|
globalGetParamField :: Monad m => GlobalGetParam -> Field m a -> MForm m (Maybe a)
|
|
globalGetParamField ident Field{fieldParse} = runMaybeT $ do
|
|
ts <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askParams
|
|
fs <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askFiles
|
|
MaybeT $ preview (_Right . _Just) <$> lift (fieldParse ts fs)
|
|
|
|
data GlobalPostParam = PostFormIdentifier
|
|
| PostDeleteTarget
|
|
| PostMassInputShape
|
|
| PostBearer
|
|
| PostDBCsvImportAction | PostDBCsvImportAvailableActions
|
|
| PostDBCsvReImport
|
|
| PostCourseUserAddConfirmAction | PostCourseUserAddConfirmAvailableActions
|
|
| PostLoginDummy
|
|
| PostExamAutoOccurrencePrevious
|
|
| PostLanguage
|
|
| PostDryRun
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
nullaryPathPiece ''GlobalPostParam (camelToPathPiece' 1)
|
|
|
|
lookupGlobalPostParam :: (MonadHandler m, PathPiece result) => GlobalPostParam -> m (Maybe result)
|
|
lookupGlobalPostParam ident = (>>= fromPathPiece) <$> lookupPostParam (toPathPiece ident)
|
|
|
|
hasGlobalPostParam :: MonadHandler m => GlobalPostParam -> m Bool
|
|
hasGlobalPostParam ident = isJust <$> lookupPostParam (toPathPiece ident)
|
|
|
|
lookupGlobalPostParams :: (MonadHandler m, PathPiece result) => GlobalPostParam -> m [result]
|
|
lookupGlobalPostParams ident = mapMaybe fromPathPiece <$> lookupPostParams (toPathPiece ident)
|
|
|
|
|
|
lookupGlobalPostParamForm :: (Monad m, PathPiece result) => GlobalPostParam -> MForm m (Maybe result)
|
|
lookupGlobalPostParamForm ident = runMaybeT $ do
|
|
ps <- MaybeT askParams
|
|
MaybeT . return $ Map.lookup (toPathPiece ident) ps >>= listToMaybe >>= fromPathPiece
|
|
|
|
hasGlobalPostParamForm :: Monad m => GlobalPostParam -> MForm m Bool
|
|
hasGlobalPostParamForm ident = maybe False (Map.member $ toPathPiece ident) <$> askParams
|
|
|
|
globalPostParamField :: Monad m => GlobalPostParam -> Field m a -> MForm m (Maybe a)
|
|
globalPostParamField ident Field{fieldParse} = runMaybeT $ do
|
|
ts <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askParams
|
|
fs <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askFiles
|
|
MaybeT $ preview (_Right . _Just) <$> lift (fieldParse ts fs)
|
|
|
|
globalPostParamFields :: Monad m => GlobalPostParam -> Field m a -> MForm m [a]
|
|
globalPostParamFields ident Field{fieldParse} = fmap (fromMaybe []) . runMaybeT $ do
|
|
ts <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askParams
|
|
fs <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askFiles
|
|
forM ((Left <$> fs) ++ (Right <$> ts)) $ \inp -> MaybeT $ preview (_Right . _Just) <$> lift (either (\f -> fieldParse [] [f]) (\t -> fieldParse [t] []) inp)
|
|
|
|
withGlobalPostParam :: PathPiece result => GlobalPostParam -> result -> (Html -> MForm m a) -> (Html -> MForm m a)
|
|
withGlobalPostParam (toPathPiece -> ident) (toPathPiece -> res) f csrf
|
|
= f $ csrf <> [shamlet|<input type=hidden name=#{ident} value=#{res}>|]
|