Steffen Jost
e9fefa75bd
- extensive refactoring for qualification lms settings
- qualificationAuditDuration changed from months to days
- qualificationAuditDuration no longer optional
- qualificationAuditDuration is only used for LMS; clarified
- three new settings:
+ orphan-deletion-days:
+ orphan-deletion-batch:
+ orphan-deletion-repeat-hours:
115 lines
7.5 KiB
Haskell
115 lines
7.5 KiB
Haskell
-- SPDX-FileCopyrightText: 2025 Steffen Jost <S.Jost@fraport.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
|
|
{-# LANGUAGE TypeApplications #-}
|
|
|
|
module Handler.Qualification.Edit
|
|
( getQualificationNewR, postQualificationNewR
|
|
, getQualificationEditR, postQualificationEditR
|
|
)
|
|
where
|
|
|
|
import Import
|
|
|
|
import qualified Data.Text as Text
|
|
import qualified Control.Monad.State.Class as State
|
|
|
|
import Handler.Utils
|
|
-- import Database.Esqueleto.Experimental ((:&)(..))
|
|
-- import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
|
|
|
|
|
getQualificationNewR, postQualificationNewR :: SchoolId -> Handler Html
|
|
getQualificationNewR = postQualificationNewR
|
|
postQualificationNewR ssh = handleQualificationEdit ssh Nothing
|
|
|
|
getQualificationEditR, postQualificationEditR :: SchoolId -> QualificationShorthand -> Handler Html
|
|
getQualificationEditR = postQualificationEditR
|
|
postQualificationEditR ssh qsh = do
|
|
qent <- runDBRead $ getBy404 $ SchoolQualificationShort ssh qsh
|
|
handleQualificationEdit ssh $ Just qent
|
|
|
|
|
|
mkQualificationForm :: SchoolId -> Maybe Qualification -> Form Qualification
|
|
mkQualificationForm ssh templ = identifyForm FIDQualificationEdit . validateForm (validateQualificationEdit ssh) $ \html ->
|
|
flip (renderAForm FormStandard) html $ reorderedQualification
|
|
<$> areq hiddenField "" (Just ssh) -- 1 -> 1
|
|
<*> areq ciField (fslI MsgQualificationShort) (qualificationShorthand <$> templ) -- 2 -> 2
|
|
<*> areq ciField (fslI MsgQualificationName) (qualificationName <$> templ) -- 3 -> 3
|
|
<*> aopt htmlField (fslI MsgQualificationDescription) (qualificationDescription <$> templ) -- 4 -> 4
|
|
<*> aopt_natFieldI MsgQualificationValidDuration (qualificationValidDuration <$> templ) -- 5 -> 5
|
|
<*> aopt calendarDiffDaysField (fslI MsgQualificationRefreshWithin &
|
|
setTooltip MsgQualificationRefreshWithinTooltip) (qualificationRefreshWithin <$> templ) -- 6 -> 7
|
|
|
|
<*> areq checkBoxField (fslI MsgQualificationElearningStart) (qualificationElearningStart <$> templ) -- 7 -> 9
|
|
<*> aopt calendarDiffDaysField (fslI MsgQualificationRefreshReminder &
|
|
setTooltip MsgQualificationRefreshReminderTooltip) (qualificationRefreshReminder <$> templ) -- 8 -> 8
|
|
<*> areq checkBoxField (fslI MsgQualificationExpiryNotification) (qualificationExpiryNotification <$> templ) -- 9 -> 13
|
|
<*> areq_natFieldI MsgQualificationAuditDuration (qualificationAuditDuration <$> templ) -- 10 -> 6
|
|
<*> areq checkBoxField (fslI MsgQualificationElearningRenew) (qualificationElearningRenews <$> templ) -- 11 -> 10
|
|
<*> aopt_natFieldI MsgQualificationElearningLimit (qualificationElearningLimit <$> templ) -- 12 -> 11
|
|
<*> aopt qualificationField (fslI MsgTableQualificationLmsReuses &
|
|
setTooltip MsgTableQualificationLmsReusesTooltip) (qualificationLmsReuses <$> templ) -- 13 -> 12
|
|
<*> aopt avsLicenceField (fslI MsgQualificationAvsLicence &
|
|
setTooltip MsgTableQualificationIsAvsLicenceTooltip) (qualificationAvsLicence <$> templ) -- 14 -> 14
|
|
<*> aopt textField (fslI MsgQualificationSapId &
|
|
setTooltip MsgTableQualificationSapExportTooltip) (qualificationSapId <$> templ) -- 15 -> 15
|
|
where
|
|
avsLicenceField :: Field Handler AvsLicence
|
|
avsLicenceField = selectFieldList [ (Text.singleton $ licence2char lic, lic) | lic <- universeF, lic /= AvsNoLicence ]
|
|
|
|
aopt_natFieldI msg = aopt (natFieldI $ SomeMessages " " [SomeMessage msg, SomeMessage MsgMustBePositive]) (fslI msg)
|
|
areq_natFieldI msg = areq (natFieldI $ SomeMessages " " [SomeMessage msg, SomeMessage MsgMustBePositive]) (fslI msg)
|
|
-- [ 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15]
|
|
reorderedQualification = $(permuteFun [ 1, 2, 3, 4, 5,10, 6, 8, 7,11,12,13, 9,14,15]) Qualification -- == inversePermutation [1,2,3,4,5,7,9,8,13,6,10,11,12,14,15]
|
|
|
|
validateQualificationEdit :: SchoolId -> FormValidator Qualification Handler ()
|
|
validateQualificationEdit ssh = do
|
|
canonise
|
|
Qualification{..} <- State.get
|
|
guardValidation MsgQualFormErrorSshMismatch $ qualificationSchool == ssh
|
|
guardValidation MsgLmsErrorNoRefreshElearning $ not qualificationElearningStart || isJust qualificationRefreshWithin
|
|
guardValidation MsgLmsErrorNoRenewElearning $ not qualificationElearningStart || isJust qualificationValidDuration
|
|
when (isJust qualificationLmsReuses) $
|
|
liftHandler $ addMessageI Info MsgQualificationAuditDurationReuseInfo
|
|
where
|
|
canonise = do -- i.e. map Just 0 to Nothing
|
|
Qualification{..} <- State.get
|
|
-- canonisation, i.e. map Just 0 to Nothing
|
|
when (qualificationRefreshWithin == Just mempty) $ State.modify $ set _qualificationRefreshWithin Nothing
|
|
when (qualificationRefreshReminder == Just mempty) $ State.modify $ set _qualificationRefreshReminder Nothing
|
|
when (qualificationValidDuration == Just 0) $ State.modify $ set _qualificationValidDuration Nothing
|
|
when (qualificationElearningLimit == Just 0) $ State.modify $ set _qualificationElearningLimit Nothing
|
|
|
|
|
|
|
|
handleQualificationEdit :: SchoolId -> Maybe (Entity Qualification) -> Handler Html
|
|
handleQualificationEdit ssh templ = do
|
|
((qRes, qWgt), qEnc) <- runFormPost $ mkQualificationForm ssh $ entityVal <$> templ
|
|
let qForm = wrapForm qWgt def
|
|
{ formEncoding = qEnc
|
|
}
|
|
formResult qRes $ \resQuali -> do
|
|
uniqViolation <- runDB $ case templ of
|
|
Just Entity{entityKey=qid} -> replaceUnique qid resQuali -- edit old qualification
|
|
_ -> maybeM (checkUnique resQuali) (const $ return Nothing) (insertUnique resQuali) -- insert new qualification
|
|
case uniqViolation of
|
|
Just (SchoolQualificationShort _ nconflict) -> addMessageI Error $ MsgQualFormErrorDuplShort $ ciOriginal nconflict
|
|
Just (SchoolQualificationName _ nconflict) -> addMessageI Error $ MsgQualFormErrorDuplName $ ciOriginal nconflict
|
|
Nothing -> do
|
|
let qshort = qualificationShorthand resQuali
|
|
qmsg = if isNothing templ then MsgQualificationCreated else MsgQualificationEdit
|
|
addMessageI Success $ qmsg $ ciOriginal qshort
|
|
redirect $ QualificationR ssh qshort
|
|
let heading = bool MsgMenuQualificationNew MsgMenuQualificationEdit $ isJust templ
|
|
siteLayoutMsg heading $ do
|
|
setTitleI heading
|
|
[whamlet|
|
|
<p>
|
|
^{qForm}
|
|
$maybe _ <- templ
|
|
<p>
|
|
_{MsgQualificationEditNote}
|
|
|] |