fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' into 307-studiengange-behandeln

Browse Source
This commit is contained in:
Steffen Jost 2019-03-20 08:32:51 +01:00
commit 23a1b883ac
18 changed files with 208 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
src/Handler/Admin.hs
View File

@ -74,7 +74,7 @@ emailTestForm = (,)
SelFormatTime -> t
makeDemoForm :: Int -> Form (Int,Bool,Double)
makeDemoForm n = identifyForm "adminTestForm" $ \html -> do -- Important: used identForm instead!
makeDemoForm n = identifyForm ("adminTestForm" :: Text) $ \html -> do
(result, widget) <- flip (renderAForm FormStandard) html $ (,,)
<$> areq (minIntField n "Zahl") (fromString $ "Ganzzahl > " ++ show n) Nothing
<* aformSection MsgFormBehaviour
@ -95,14 +95,14 @@ makeDemoForm n = identifyForm "adminTestForm" $ \html -> do -- Important: used i
getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden!
getAdminTestR = postAdminTestR
postAdminTestR = do
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm "buttons" (buttonForm :: Form ButtonCreate)
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonCreate)
case btnResult of
(FormSuccess CreateInf) -> addMessage Info "Informatik-Knopf gedrückt"
(FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt"
FormMissing -> return ()
_other -> addMessage Warning "KEIN Knopf erkannt"
((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm "email" $ renderAForm FormStandard emailTestForm
((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm ("email" :: Text) $ renderAForm FormStandard emailTestForm
formResultModal emailResult AdminTestR $ \(email, ls) -> do
jId <- mapWriterT runDB $ do
jId <- queueJob $ JobSendTestEmail email ls

7
src/Handler/Corrections.hs
View File

@ -353,6 +353,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
, dbParamsFormEvaluate = liftHandlerT . runFormPost
, dbParamsFormResult = _1
, dbParamsFormIdent = def
}
-- -- Similar Query for Statistics over alle possible Table elements (not just the ones shown)
-- gradingSummary <- do
@ -614,13 +615,13 @@ postCorrectionR tid ssh csh shn cid = do
(fslpI MsgRatingPoints "Punktezahl")
(Just submissionRatingPoints)
((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,,)
((corrResult, corrForm), corrEncoding) <- runFormPost . identifyForm FIDcorrection . renderAForm FormStandard $ (,,)
<$> areq checkBoxField (fslI MsgRatingDone) (Just $ submissionRatingDone Submission{..})
<*> pointsForm
<*> (((\t -> t <$ guard (not $ null t)) =<<) . fmap (Text.strip . unTextarea) <$> aopt textareaField (fslI MsgRatingComment) (Just $ Textarea <$> submissionRatingComment))
<* submitButton
((uploadResult, uploadForm), uploadEncoding) <- runFormPost . identForm FIDcorrectionUpload . renderAForm FormStandard $
((uploadResult, uploadForm), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionUpload . renderAForm FormStandard $
areq (zipFileField True) (fslI MsgRatingFiles) Nothing
<* submitButton
@ -693,7 +694,7 @@ getCorrectionUserR tid ssh csh shn cid = do
getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html
getCorrectionsUploadR = postCorrectionsUploadR
postCorrectionsUploadR = do
((uploadRes, upload), uploadEncoding) <- runFormPost . identForm FIDcorrectionsUpload . renderAForm FormStandard $
((uploadRes, upload), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionsUpload . renderAForm FormStandard $
areq (zipFileField True) (fslI MsgCorrUploadField) Nothing
<* submitButton

2
src/Handler/Course.hs
View File

@ -558,7 +558,7 @@ courseToForm (Entity cid Course{..}) = CourseForm
}
makeCourseForm :: Maybe CourseForm -> Form CourseForm
makeCourseForm template = identForm FIDcourse $ \html -> do
makeCourseForm template = identifyForm FIDcourse $ \html -> do
-- TODO: Refactor to avoid the four repeated calls to liftHandlerT and three runDBs
-- let editCid = cfCourseId =<< template -- possible start for refactoring

2
src/Handler/Profile.hs
View File

@ -27,7 +27,7 @@ data SettingsForm = SettingsForm
}
makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
makeSettingForm template = identForm FIDsettings $ \html -> do
makeSettingForm template = identifyForm FIDsettings $ \html -> do
(result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm
<$ aformSection MsgFormCosmetics
<*> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here

4
src/Handler/Sheet.hs
View File

@ -90,7 +90,7 @@ getFtIdMap sId = do
return $ partitionFileType [(t,i)|(E.Value t, E.Value i) <- allfIds]
makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm
makeSheetForm msId template = identForm FIDsheet $ \html -> do
makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
oldFileIds <- (return.) <$> case msId of
Nothing -> return $ partitionFileType mempty
(Just sId) -> liftHandlerT $ runDB $ getFtIdMap sId
@ -780,7 +780,7 @@ postSCorrR = getSCorrR
getSCorrR tid ssh csh shn = do
Entity shid Sheet{..} <- runDB $ fetchSheet tid ssh csh shn
((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
((res,formWidget), formEnctype) <- runFormPost . identifyForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
case res of
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs

2
src/Handler/Submission.hs
View File

@ -49,7 +49,7 @@ import System.FilePath
makeSubmissionForm :: Maybe SubmissionId -> UploadMode -> SheetGroup -> NonEmpty UserEmail -> Form (Maybe (Source Handler File), NonEmpty UserEmail)
makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identForm FIDsubmission $ \html -> do
makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identifyForm FIDsubmission $ \html -> do
let
fileUploadForm = case uploadMode of
NoUpload -> pure Nothing

9
src/Handler/SystemMessage.hs
View File

@ -35,7 +35,7 @@ postMessageR cID = do
let
mkForm = do
((modifyRes, modifyView), modifyEnctype) <- runFormPost . identForm FIDSystemMessageModify . renderAForm FormStandard
((modifyRes, modifyView), modifyEnctype) <- runFormPost . identifyForm FIDSystemMessageModify . renderAForm FormStandard
$ SystemMessage
<$> aopt utcTimeField (fslI MsgSystemMessageFrom) (Just systemMessageFrom)
<*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just systemMessageTo)
@ -51,7 +51,7 @@ postMessageR cID = do
modifyTranss' <- forM ts' $ \(Entity tId SystemMessageTranslation{..}) -> do
cID' <- encrypt tId
runFormPost . identForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard
runFormPost . identifyForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard
$ (,)
<$> fmap (Entity tId)
( SystemMessageTranslation
@ -64,7 +64,7 @@ postMessageR cID = do
let modifyTranss = Map.map (view $ _1._1) modifyTranss'
((addTransRes, addTransView), addTransEnctype) <- runFormPost . identForm FIDSystemMessageAddTranslation . renderAForm FormStandard
((addTransRes, addTransView), addTransEnctype) <- runFormPost . identifyForm FIDSystemMessageAddTranslation . renderAForm FormStandard
$ SystemMessageTranslation
<$> pure smId
<*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") Nothing
@ -215,6 +215,7 @@ postMessageListR = do
return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
, dbParamsFormEvaluate = liftHandlerT . runFormPost
, dbParamsFormResult = id
, dbParamsFormIdent = def
}
, dbtIdent = "messages" :: Text
}
@ -246,7 +247,7 @@ postMessageListR = do
FormSuccess (_, _selection) -- prop> null _selection
-> addMessageI Error MsgSystemMessageEmptySelection
((addRes, addView), addEncoding) <- runFormPost . identForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage
((addRes, addView), addEncoding) <- runFormPost . identifyForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage
<$> aopt utcTimeField (fslI MsgSystemMessageFrom) Nothing
<*> aopt utcTimeField (fslI MsgSystemMessageTo) Nothing
<*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) Nothing

2
src/Handler/Utils/Delete.hs
View File

@ -51,7 +51,7 @@ confirmForm confirmString = flip traverseAForm aform $ \(inpConfirmStr, BtnDelet
multiple = length (filter (not . Text.null . Text.strip) $ Text.lines confirmString) > 1
confirmForm' :: PersistEntity record => Set (Key record) -> Text -> Form Bool
confirmForm' drRecords confirmString = addDeleteTargets . identForm FIDDelete . renderAForm FormStandard $ confirmForm confirmString
confirmForm' drRecords confirmString = addDeleteTargets . identifyForm FIDDelete . renderAForm FormStandard $ confirmForm confirmString
where
addDeleteTargets :: Form a -> Form a
addDeleteTargets form csrf = do

36
src/Handler/Utils/Form.hs
View File

@ -605,42 +605,6 @@ optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do
, optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a))
}) cPairs
mforced :: (site ~ HandlerSite m, MonadHandler m)
=> Field m a -> FieldSettings site -> a -> MForm m (FormResult a, FieldView site)
mforced Field{..} FieldSettings{..} val = do
tell fieldEnctype
name <- maybe newFormIdent return fsName
theId <- lift $ maybe newIdent return fsId
mr <- getMessageRender
let fsAttrs' = fsAttrs <> [("disabled", "")]
return ( FormSuccess val
, FieldView
{ fvLabel = toHtml $ mr fsLabel
, fvTooltip = toHtml <$> fmap mr fsTooltip
, fvId = theId
, fvInput = fieldView theId name fsAttrs' (Right val) False
, fvErrors = Nothing
, fvRequired = False
}
)
aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
=> Field m a -> FieldSettings site -> a -> AForm m a
aforced field settings val = formToAForm $ second pure <$> mforced field settings val
apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
=> Field m a -> FieldSettings site -> Maybe a -> AForm m a
-- ^ Pseudo required
apreq f fs mx = formToAForm $ do
mr <- getMessageRender
over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } )) <$> mopt f fs (Just <$> mx)
wpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
=> Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a)
wpreq f fs mx = mFormToWForm $ do
mr <- getMessageRender
over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } ) <$> mopt f fs (Just <$> mx)
multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
=> Map action (AForm (HandlerT UniWorX IO) a)
-> Maybe action

29
src/Handler/Utils/Table/Pagination.hs
View File

@ -459,6 +459,19 @@ instance Monoid x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x
instance Default (DBParams (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
def = DBParamsDB
data DBParamsFormIdent where
DBParamsFormTableIdent :: DBParamsFormIdent
DBParamsFormOverrideIdent :: forall t. PathPiece t => t -> DBParamsFormIdent
DBParamsFormNoIdent :: DBParamsFormIdent
instance Default DBParamsFormIdent where
def = DBParamsFormTableIdent
unDBParamsFormIdent :: DBTable m x -> DBParamsFormIdent -> Maybe Text
unDBParamsFormIdent DBTable{dbtIdent} DBParamsFormTableIdent = Just $ toPathPiece dbtIdent
unDBParamsFormIdent _ (DBParamsFormOverrideIdent x) = Just $ toPathPiece x
unDBParamsFormIdent _ DBParamsFormNoIdent = Nothing
instance Monoid x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x where
data DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = forall a. DBParamsForm
{ dbParamsFormMethod :: StdMethod
@ -468,6 +481,7 @@ instance Monoid x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
, dbParamsFormAdditional :: Form a
, dbParamsFormEvaluate :: forall m' a' x'. (MonadHandler m', HandlerSite m' ~ UniWorX, MonadResource m') => (Html -> MForm (HandlerT UniWorX IO) (FormResult a', x')) -> m' ((FormResult a', x'), Enctype)
, dbParamsFormResult :: Lens' x (FormResult a)
, dbParamsFormIdent :: DBParamsFormIdent
}
type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = (x, Widget)
-- type DBResult' (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = (FormResult a, Enctype)
@ -490,7 +504,15 @@ instance Monoid x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
dbWidget _ _ = return . snd
dbHandler _ _ f = return . over _2 f
-- runDBTable :: forall m' k'. (MonadHandler m', HandlerSite m' ~ UniWorX, ToJSON k') => DBTable (MForm (HandlerT UniWorX IO)) x -> PaginationInput -> [k'] -> (MForm (HandlerT UniWorX IO)) (x, Widget) -> ReaderT SqlBackend m' (x, Widget)
runDBTable dbtable@(DBTable{ dbtParams = dbtParams@DBParamsForm{..} }) pi pKeys = fmap ((\(res, (wdgt, x)) -> (x & dbParamsFormResult .~ res, wdgt)) . view _1) . dbParamsFormEvaluate . fmap (fmap $ \(x, wdgt) -> (x ^. dbParamsFormResult, (wdgt, x))) . dbParamsFormWrap dbtParams . addPIHiddenField dbtable pi . addPreviousHiddenField dbtable pKeys . withFragment
runDBTable dbtable@(DBTable{ dbtParams = dbtParams@DBParamsForm{..} }) pi pKeys
= fmap ((\(res, (wdgt, x)) -> (x & dbParamsFormResult .~ res, wdgt)) . view _1)
. dbParamsFormEvaluate
. fmap (fmap $ \(x, wdgt) -> (x ^. dbParamsFormResult, (wdgt, x)))
. dbParamsFormWrap dbtParams
. maybe id (identifyForm' dbParamsFormResult) (unDBParamsFormIdent dbtable dbParamsFormIdent)
. addPIHiddenField dbtable pi
. addPreviousHiddenField dbtable pKeys
. withFragment
dbInvalidateResult DBParamsForm{..} reason result = do
reasonTxt <- getMessageRender <*> pure reason
@ -508,6 +530,7 @@ instance Monoid x => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [La
, dbParamsFormAdditional = \_ -> return (pure (), mempty)
, dbParamsFormEvaluate = liftHandlerT . runFormPost
, dbParamsFormResult = lens (\_ -> pure ()) (\s _ -> s)
, dbParamsFormIdent = def
}
dbParamsFormWrap :: Monoid x => DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget)) -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget))
@ -603,9 +626,9 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
referencePagesize = psLimit . snd . runPSValidator dbtable $ Just prevPi
(((filterRes, filterWdgt), filterEnc), ((pagesizeRes, pagesizeWdgt), pagesizeEnc)) <- mdo
(filterRes'@((filterRes, _), _)) <- runFormGet . identForm FIDDBTableFilter . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi)
(filterRes'@((filterRes, _), _)) <- runFormGet . identifyForm FIDDBTableFilter . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi)
(pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identForm FIDDBTablePagesize . addPIHiddenField dbtable (prevPi & _piPage .~ Nothing & _piLimit .~ Nothing & _piFilter .~ (formResult' filterRes <|> piFilter prevPi)) . renderAForm FormDBTablePagesize $
(pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identifyForm FIDDBTablePagesize . addPIHiddenField dbtable (prevPi & _piPage .~ Nothing & _piLimit .~ Nothing & _piFilter .~ (formResult' filterRes <|> piFilter prevPi)) . renderAForm FormDBTablePagesize $
areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addAutosubmit & addName (wIdent "pagesize") & addClass "select--pagesize") (Just referencePagesize)
<* autosubmitButton
return (filterRes', pagesizeRes')

2
src/Import/NoFoundation.hs
View File

@ -3,7 +3,7 @@ module Import.NoFoundation
, MForm
) where
import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField)
import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm)
import Model as Import
import Model.Types.JSON as Import
import Model.Migration as Import

28
src/Utils.hs
View File

@ -24,6 +24,7 @@ import Utils.DateTime as Utils
import Utils.PathPiece as Utils
import Utils.Message as Utils
import Utils.Lang as Utils
import Utils.Parameters as Utils
import Text.Blaze (Markup, ToMarkup)
@ -595,32 +596,7 @@ getSessionJson key = lookupSessionJson key <* deleteSession (toPathPiece key)
-- GET Parameters --
--------------------
data GlobalGetParam = GetReferer
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe GlobalGetParam
instance Finite GlobalGetParam
nullaryPathPiece ''GlobalGetParam (camelToPathPiece' 1)
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)
data GlobalPostParam = PostDeleteTarget
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe GlobalPostParam
instance Finite GlobalPostParam
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)
-- Moved to Utils.Parameters
---------------------------------
-- Custom HTTP Request-Headers --

77
src/Utils/Form.hs
View File

@ -2,9 +2,11 @@
module Utils.Form where
import ClassyPrelude.Yesod hiding (addMessage, cons, Proxy(..))
import ClassyPrelude.Yesod hiding (addMessage, cons, Proxy(..), identifyForm)
import Settings
import Utils.Parameters
-- import Text.Blaze (toMarkup) -- for debugging
import qualified Text.Blaze.Internal as Blaze (null)
import qualified Data.Text as T
@ -18,6 +20,8 @@ import qualified Data.Map.Lazy as Map
import qualified Data.Set as Set
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Reader.Class (MonadReader(..))
import Control.Monad.Writer.Class (MonadWriter(..))
import Data.List ((!!))
@ -210,7 +214,9 @@ data FormIdentifier
| FIDSystemMessageAddTranslation
| FIDDBTableFilter
| FIDDBTablePagesize
| FIDDBTable
| FIDDelete
| FIDCourseRegister
deriving (Eq, Ord, Read, Show)
instance PathPiece FormIdentifier where
@ -218,11 +224,32 @@ instance PathPiece FormIdentifier where
toPathPiece = showToPathPiece
identForm :: (Monad m, PathPiece ident)
=> ident -- ^ Form identification
-> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
-> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
identForm = identifyForm . toPathPiece
identifyForm' :: (Monad m, PathPiece ident, Eq ident)
=> Lens' x (FormResult a)
-> ident -- ^ Form identification
-> (Html -> MForm m (x, widget))
-> (Html -> MForm m (x, widget))
identifyForm' resLens identVal form fragment = do
-- Create hidden <input>.
let fragment' =
[shamlet|
<input .form-identifier type=hidden name=#{toPathPiece PostFormIdentifier} value=#{toPathPiece identVal}>
#{fragment}
|]
-- Check if we got its value back.
hasIdent <- (== Just identVal) <$> lookupGlobalPostParamForm PostFormIdentifier
-- Run the form proper (with our hidden <input>). If the
-- data is missing, then do not provide any params to the
-- form, which will turn its result into FormMissing. Also,
-- doing this avoids having lots of fields with red errors.
let eraseParams | not hasIdent = local (\(_, h, l) -> (Nothing, h, l))
| otherwise = id
fmap (over (_1 . resLens) $ bool (const FormMissing) id hasIdent) . eraseParams $ form fragment'
identifyForm :: (Monad m, PathPiece ident, Eq ident) => ident -> (Html -> MForm m (FormResult a, widget)) -> (Html -> MForm m (FormResult a, widget))
identifyForm = identifyForm' id
{- Hinweise zur Erinnerung:
- identForm primär, wenn es mehr als ein Formular pro Handler gibt
@ -513,4 +540,42 @@ prismAForm p outer form = review p <$> form inner
where
inner = outer >>= preview p
---------------------------------------------
-- Special variants of @mopt@, @mreq@, ... --
---------------------------------------------
mforced :: (site ~ HandlerSite m, MonadHandler m)
=> Field m a -> FieldSettings site -> a -> MForm m (FormResult a, FieldView site)
mforced Field{..} FieldSettings{..} val = do
tell fieldEnctype
name <- maybe newFormIdent return fsName
theId <- lift $ maybe newIdent return fsId
mr <- getMessageRender
let fsAttrs' = fsAttrs <> [("disabled", "")]
return ( FormSuccess val
, FieldView
{ fvLabel = toHtml $ mr fsLabel
, fvTooltip = toHtml <$> fmap mr fsTooltip
, fvId = theId
, fvInput = fieldView theId name fsAttrs' (Right val) False
, fvErrors = Nothing
, fvRequired = False
}
)
aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
=> Field m a -> FieldSettings site -> a -> AForm m a
aforced field settings val = formToAForm $ second pure <$> mforced field settings val
apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
=> Field m a -> FieldSettings site -> Maybe a -> AForm m a
-- ^ Pseudo required
apreq f fs mx = formToAForm $ do
mr <- getMessageRender
over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } )) <$> mopt f fs (Just <$> mx)
wpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
=> Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a)
wpreq f fs mx = mFormToWForm $ do
mr <- getMessageRender
over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } ) <$> mopt f fs (Just <$> mx)

78
src/Utils/Parameters.hs Normal file
View File

@ -0,0 +1,78 @@
module Utils.Parameters
( GlobalGetParam(..)
, lookupGlobalGetParam, hasGlobalGetParam
, lookupGlobalGetParamForm, hasGlobalGetParamForm
, globalGetParamField
, GlobalPostParam(..)
, lookupGlobalPostParam, hasGlobalPostParam
, lookupGlobalPostParamForm, hasGlobalPostParamForm
, globalPostParamField
) where
import ClassyPrelude.Yesod
import Utils.PathPiece
import qualified Data.Map as Map
import Data.Universe
import Control.Monad.Trans.Maybe (MaybeT(..))
data GlobalGetParam = GetReferer
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe GlobalGetParam
instance Finite GlobalGetParam
nullaryPathPiece ''GlobalGetParam (camelToPathPiece' 1)
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)
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 => GlobalPostParam -> 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 $ either (const Nothing) id <$> lift (fieldParse ts fs)
data GlobalPostParam = PostFormIdentifier
| PostDeleteTarget
| PostMassInputShape
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe GlobalPostParam
instance Finite GlobalPostParam
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)
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 $ either (const Nothing) id <$> lift (fieldParse ts fs)

4
static/js/utils/asyncTable.js
View File

@ -217,7 +217,9 @@
}
function destroyUtils() {
utilInstances.forEach(function(utilInstance) {
utilInstances.filter(function(utilInstance) {
return !!utilInstance;
}).forEach(function(utilInstance) {
utilInstance.destroy();
});
}

4
static/js/utils/form.js
View File

@ -48,7 +48,9 @@
form.classList.add(JS_INITIALIZED);
function destroyUtils() {
utilInstances.forEach(function(utilInstance) {
utilInstances.filter(function(utilInstance) {
return !!utilInstance;
}).forEach(function(utilInstance) {
utilInstance.destroy();
});
}

4
static/js/utils/inputs.js
View File

@ -38,7 +38,9 @@
});
function destroyUtils() {
utilInstances.forEach(function(utilInstance) {
utilInstances.filter(function(utilInstance) {
return !!utilInstance;
}).forEach(function(utilInstance) {
utilInstance.destroy();
});
}

4
static/js/utils/modal.js
View File

@ -140,7 +140,9 @@
setup();
function destroyUtils() {
utilInstances.forEach(function(utilInstance) {
utilInstances.filter(function(utilInstance) {
return !!utilInstance;
}).forEach(function(utilInstance) {
utilInstance.destroy();
});
}