From b26dd285df7cf4d8dff402c4e036d4a1cf370bba Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 28 Jan 2025 18:45:13 +0100 Subject: [PATCH] chore(form): create calendarDiffDaysField --- messages/uniworx/misc/de-de-formal.msg | 4 +- messages/uniworx/misc/en-eu.msg | 4 +- src/Handler/Qualification/Edit.hs | 52 ++++++++++++++++++++++++++ src/Handler/Tutorial/Users.hs | 1 + src/Handler/Utils/Form.hs | 29 ++++++++++++++ src/Utils/Form.hs | 1 + 6 files changed, 89 insertions(+), 2 deletions(-) create mode 100644 src/Handler/Qualification/Edit.hs diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index b44820cfc..c243c42f9 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -5,6 +5,7 @@ #messages or constructors that are used all over the code Logo !ident-ok: FRADrive +LdapIdentificationOrEmail: Fraport AG-Kennung / E-Mail-Adresse EmailInvitationWarning: Diese Adresse konnte keinem FRADrive-Benutzer/-Benutzerin zugeordnet werden. Es wird eine Einladung per E-Mail versandt. BoolIrrelevant !ident-ok: — FieldPrimary: Hauptfach @@ -13,7 +14,8 @@ MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Adressen möglich MultiSelectTip: Mehrfachauswahl und Abwählen mit Strg-Klick WeekDay: Wochentag Hours: Stunden -LdapIdentificationOrEmail: Fraport AG-Kennung / E-Mail-Adresse +SomeMonths: Monate +SomeDays: Tage Months num@Int64: #{num} #{pluralDE num "Monat" "Monate"} Days num@Int64: #{num} #{pluralDE num "Tag" "Tage"} NoAutomaticUpdateTip: Dieser Wert wurde manuell editiert und wird daher nicht mehr automatisch durch as AVS aktualisiert. diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index f0e05210a..f12710a69 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -5,6 +5,7 @@ #messages or constructors that are used all over the Code Logo: FRADrive +LdapIdentificationOrEmail: Fraport AG-Kennung / email address EmailInvitationWarning: This address could not be matched to any FRADrive user. An invitation will be sent via email. BoolIrrelevant: — FieldPrimary: Major @@ -13,7 +14,8 @@ MultiEmailFieldTip: Multiple emails addresses may be specified (comma-separated) MultiSelectTip: Multiple selection and desection via Ctrl-Click WeekDay: Day of the week Hours: Hours -LdapIdentificationOrEmail: Fraport AG-Kennung / email address +SomeMonths: Months +SomeDays: Days Months num: #{num} #{pluralEN num "Month" "Months"} Days num: #{num} #{pluralEN num "Day" "Days"} NoAutomaticUpdateTip: This particular value receives no automatic AVS updates, since it has been edited manually. diff --git a/src/Handler/Qualification/Edit.hs b/src/Handler/Qualification/Edit.hs new file mode 100644 index 000000000..1f0e6d87e --- /dev/null +++ b/src/Handler/Qualification/Edit.hs @@ -0,0 +1,52 @@ +-- SPDX-FileCopyrightText: 2025 Steffen Jost +-- +-- 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 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 :: Maybe Qualification -> SchoolId -> Qualification +mkQualificationForm templ ssh = renderAForm FormStandard $ Qualification -- to reorder form fiels, use permuteFun on Qualification + <$> areq hiddenField "" (Just ssh) + <*> areq ciField (fslI MsgQualificationShort) (qualificationShorthand <$> templ) + <*> areq ciField (fslI MsgQualificationName) (qualificationName <$> templ) + <*> aopt htmlField (fslI MsgQualificationDescription) (qualificationDescription <$> templ) + <*> aopt (posIntFieldI MsgQualificationValidDuration) (fslI MsgQualificationValidDuration) (qualificationValidDuration <$> templ) + <*> aopt (posIntFieldI MsgQualificationAuditDuration) (fslI MsgQualificationAuditDuration) (qualificationAuditDuration <$> templ) + <*> aopt calendarDiffDaysField (fslI MsgQualificationRefreshWithin) (qualificationRefreshWithin <$> templ) + <*> aopt calendarDiffDaysField (fslI MsgQualificationRefreshReminder) (qualificationRefreshReminder <$> templ) + <*> areq checkBoxField (fslI MsgQualificationElearningStart) (qualificationElearningStart <$> templ) + <*> areq checkBoxField (fslI MsgTableQualificationElearningRenews) (qualificationElearningRenews <$> templ) + <*> aopt (posIntFieldI MsgQualificationElearningLimit)(fslI MsgQualificationElearningLimit) (qualificationElearningLimit <$> templ) + <*> aopt (error "TODO") (fslI MsgTableQualificationLmsReuses) (qualificationLmsReuses <$> templ) + <*> areq checkBoxField (fslI MsgQualificationExpiryNotification) (qualificationExpiryNotification <$> templ) + <*> aopt (error "TODO") (fslI MsgQualificationAvsLicence) (qualificationAvsLicence <$> templ) + <*> aopt textField (fslI MsgQualficiationSapId) (qualificationSapId <$> templ) + -- TODO: add tooltips + +handleQualificationEdit :: SchoolId -> Maybe (Entity Qualification) -> Handler Html +handleQualificationEdit _ _ = error "todo" \ No newline at end of file diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index eb41ef76b..3629054bf 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -98,6 +98,7 @@ mkGenTutForm fltr html = do let res :: FormResult GenTutAction -> FormResult ExamId -> FormResult GenTutActionData res (FormSuccess GenTutActOccCopy) (FormSuccess eid) = FormSuccess $ GenTutActOccCopyData eid res (FormSuccess GenTutActOccEdit) (FormSuccess eid) = FormSuccess $ GenTutActOccEditData eid + res (FormFailure e1) (FormFailure e2) = FormFailure $ e1 <> e2 res (FormFailure e) _ = FormFailure e res _ (FormFailure e) = FormFailure e res _ _ = FormMissing diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index fef1889db..ca770354b 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -1425,6 +1425,35 @@ utcTimeField = checkMMap (return . localTimeToUTC') utcToLocalTime localTimeFiel LTUNone{} -> Left MsgIllDefinedUTCTime LTUAmbiguous{} -> Left MsgAmbiguousUTCTime +calendarDiffDaysField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m CalendarDiffDays +calendarDiffDaysField = Field + { fieldParse = parseDD + , fieldEnctype = UrlEncoded + , fieldView = \theId name attrs val isReq -> do + let (vmon, vday) = showDD val + [whamlet| + $newline never + + _{MsgSomeMonths} + + _{MsgSomeDays} + |] + } + where + showDD :: Either Text CalendarDiffDays -> (Text,Text) + showDD (Left t) = (mempty, t) -- show error message only once, on day field + showDD (Right CalendarDiffDays{..}) = (tshow cdMonths, tshow cdDays) + + parseDD [tmon, tday] _ + | Just nmon <- readMay tmon + , Just nday <- readMay tday + -- , 0 =< nmon + nday + = return $ Right $ if 0 == nmon + nday -- TODO: this should not be distinguished here + then Nothing + else Just $ CalendarDiffDays { cdMonths=nmon, cdDays=nday} + parseDD [] _ = return $ Right Nothing + parseDD _ _ = return $ Left "Parsing calendarDiffDaysField failed" -- TODO: better error messages + langField :: Bool -- ^ Only allow values from `appLanguages` -> Field Handler Lang diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 1972685ac..f49f3a883 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -821,6 +821,7 @@ daysField = convertField fromDays toDays fractionalField fromDays = (* nominalDay) + data SecretJSONFieldException = SecretJSONFieldDecryptFailure deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) instance Exception SecretJSONFieldException