From 58152beb03f09bb0ac26916f851308773c952064 Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 29 Jul 2024 11:29:58 +0200 Subject: [PATCH 01/23] refactor(utils): flip arguments bsnoc --- src/Utils.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Utils.hs b/src/Utils.hs index aa3bb03a0..69b114b01 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -714,9 +714,9 @@ bcons :: Bool -> a -> [a] -> [a] bcons False _ = id bcons True x = (x:) -bsnoc :: Bool -> a -> [a] -> [a] -bsnoc False _ xs = xs -bsnoc True x xs = xs ++ [x] +bsnoc :: Bool -> [a] -> a -> [a] +bsnoc False xs _ = xs +bsnoc True xs x = xs ++ [x] -- | Merge/Add any attribute-value pair to an existing list of such pairs. -- If the attribute exists, the new valu will be prepended, separated by a single empty space From 11fdcf0d445b8cfe97c3a3c26513a9229937c536 Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 29 Jul 2024 14:58:19 +0200 Subject: [PATCH 02/23] fix(lms): max e-learning tries default removed and info added to lms overview --- models/lms.model | 2 +- templates/i18n/lms-all/de-de-formal.hamlet | 9 +++++++++ templates/i18n/lms-all/en-eu.hamlet | 8 ++++++++ 3 files changed, 18 insertions(+), 1 deletion(-) diff --git a/models/lms.model b/models/lms.model index 0d4b1e49d..9a7712c29 100644 --- a/models/lms.model +++ b/models/lms.model @@ -14,7 +14,7 @@ Qualification refreshReminder CalendarDiffDays Maybe -- send a second notification about renewal within this number of month/days before expiry elearningStart Bool -- automatically schedule e-refresher elearningRenews Bool default=true -- successful e-learing automatically increases validity automatically by validDuration - elearningLimit Int Maybe defualt=5 -- limit of e-learning attempts, currently only for informative purposes, as it is enforced by LMS only + elearningLimit Int Maybe -- limit of e-learning attempts, currently only for informative purposes, as it is enforced by LMS only lmsReuses QualificationId Maybe -- if set, lms is also included within the given qualification's lms, but only for direct routes. AuditDuration is used from this Qualification instead. expiryNotification Bool default=true -- should expiryNotification be generated for this qualification? avsLicence AvsLicence Maybe -- if set, valid QualificationUsers are synchronized to AVS as a driving licence diff --git a/templates/i18n/lms-all/de-de-formal.hamlet b/templates/i18n/lms-all/de-de-formal.hamlet index c93ddfb58..08f2088ed 100644 --- a/templates/i18n/lms-all/de-de-formal.hamlet +++ b/templates/i18n/lms-all/de-de-formal.hamlet @@ -7,6 +7,15 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
^{lmsTable} +

+ Hinweis: # + Es muss anderweitig sichergestellt werden, dass die hier lediglich angezeigte maximale Anzahl # + an E‑Learning Prüfungsversuchen mit der im externen LMS eingestellten Zahl übereinstimmt! # + Die Begrenzung der Prüfungsversuche wird ausschließlich durch das externe LMS kontrolliert, # + an FRADrive wird weder die Anzahl der möglichen noch der erfolgten Versuche übermittelt. # + Die hier eingestellte Zahl dient ausschließlich zur Information der Lizenzinhaber per Brief oder E‑Mail. + + $maybe btnForm <- mbBtnForm

diff --git a/templates/i18n/lms-all/en-eu.hamlet b/templates/i18n/lms-all/en-eu.hamlet index 69aa8df82..2c4fa87a0 100644 --- a/templates/i18n/lms-all/en-eu.hamlet +++ b/templates/i18n/lms-all/en-eu.hamlet @@ -7,6 +7,14 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
^{lmsTable} +

+ Note: # + It must be ensured that the maximum number of e‑learning exam attempts # + configured in the external LMS agrees with the number displayed here for the corresponding qualification. # + The maximum number of attempts is a setting of the external LMS only, which is never transmitted to FRADrive. # + The number shown is only used in the communication to licences holders via letter or Email. + + $maybe btnForm <- mbBtnForm

From 689e6347dadb749c99e24f1f191ac2639e73161e Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 30 Jul 2024 10:42:39 +0200 Subject: [PATCH 03/23] chore(print): make apc ident comparison fuzzy received and stored idents are additionally accepted as infixes of one another, if the length difference is less than 3 characters --- src/Jobs/Handler/Print.hs | 44 +++++++++++++++++++++++++++------------ 1 file changed, 31 insertions(+), 13 deletions(-) diff --git a/src/Jobs/Handler/Print.hs b/src/Jobs/Handler/Print.hs index 630a946eb..60ac7484b 100644 --- a/src/Jobs/Handler/Print.hs +++ b/src/Jobs/Handler/Print.hs @@ -18,34 +18,52 @@ import qualified Data.Text as Text -- import Database.Persist.Sql (deleteWhereCount) -- import Database.Esqueleto.Experimental ((:&)(..)) --- import qualified Database.Esqueleto.Experimental as E --- import qualified Database.Esqueleto.Legacy as E +import qualified Database.Esqueleto.Experimental as E +import qualified Database.Esqueleto.Utils as E -- import qualified Database.Esqueleto.PostgreSQL as E -- for insertSelect variant --- import qualified Database.Esqueleto.Utils as E +-- import qualified Database.Esqueleto.Legacy as E - -jobPrintAckChunkSize :: Int +jobPrintAckChunkSize :: Int jobPrintAckChunkSize = 64 +-- | Maximum length difference between received and stored apcIdent +-- APC sometimes sends ids back that are shorter than expected +apcIdentMaxDiff :: Int +apcIdentMaxDiff = 3 + -- needed, since JobPrintAck cannot requeue itself due to JobNoQueueSame (and having no parameters) dispatchJobPrintAckAgain :: JobHandler UniWorX dispatchJobPrintAckAgain = JobHandlerException act - where + where act = void $ queueJob JobPrintAck -- liftIO $ threadDelay 3e6 -- wait 3s before continuing UPDATE: no wait needed - + dispatchJobPrintAck :: JobHandler UniWorX dispatchJobPrintAck = JobHandlerException act - where + where act = do - moretodo <- runDB $ do + moretodo <- runDB $ do aliases <- selectList [] [Desc PrintAckIdAliasPriority] let ftransAliases = id : fmap (\Entity{entityVal=PrintAckIdAlias{printAckIdAliasNeedle=n, printAckIdAliasReplacement=r}} -> Text.replace n r) aliases - ackOneId ackt apci = selectKeysList [PrintJobApcIdent ==. apci, PrintJobAcknowledged ==. Nothing] [Asc PrintJobCreated, LimitTo 1] >>= \case - [pjid] -> update pjid [PrintJobAcknowledged =. Just ackt] >> - return True - _ -> return False + ackOneId ackt apci = selectKeysList [PrintJobApcIdent ==. apci, PrintJobAcknowledged ==. Nothing] [Asc PrintJobCreated, LimitTo 1] >>= \case -- mark oldest as done, if there are multiple with the same identifier + [pjid] -> update pjid [PrintJobAcknowledged =. Just ackt] $> True + _ -> do + pjcs <- E.select $ do + let len_apci = Text.length apci + ifx_bounds = (E.val $ len_apci - apcIdentMaxDiff, E.val $ len_apci + apcIdentMaxDiff) + pj <- E.from $ E.table @PrintJob + E.where_ $ E.isNothing (pj E.^. PrintJobAcknowledged) + E.&&. (E.length_ (pj E.^. PrintJobApcIdent) `E.between` ifx_bounds) + E.&&. (E.isInfixOf (E.val apci) (pj E.^. PrintJobApcIdent) + E.||. E.isInfixOf (pj E.^. PrintJobApcIdent) (E.val apci) + ) + E.orderBy [E.asc $ pj E.^. PrintJobCreated] -- mark oldest printjob as done, if there are multiple matching jobs + E.limit 1 + return $ pj E.^. PrintJobId + case pjcs of + [E.Value pjid] -> update pjid [PrintJobAcknowledged =. Just ackt] $> True + _ -> return False procOneId oks Entity{entityKey=paid, entityVal=PrintAcknowledge{printAcknowledgeApcIdent=Text.strip -> apci, printAcknowledgeTimestamp=ackt}} = orM [ackOneId ackt $ ftrans apci | ftrans <- ftransAliases] >>= \case True -> delete paid >> return (succ oks) From 8b0466e74e36e1d0d07518fd317d46b00ab53eff Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 30 Jul 2024 15:56:45 +0200 Subject: [PATCH 04/23] fix(ap): disambiguate action message --- messages/uniworx/categories/firm/de-de-formal.msg | 2 +- messages/uniworx/categories/firm/en-eu.msg | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index bf76f6e0e..951ec61ab 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -19,7 +19,7 @@ FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig FirmActAddSupervisors: Ansprechpartner hinzufügen FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner geändert #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert. -RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber noch nicht deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)} +RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber keine aktiven Ansprechpartnerbeziehungen wurden deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)} FirmActChangeContactUser: Kontaktinformationen von allen Firmenangehörigen ändern FirmActChangeContactFirm: Kontaktinformationen der Firma ändern FirmActChangeContactFirmInfo: Firmenkontaktinformationen werden nur für neue Firmenangehörige verwendet, für die sonst keine Kontaktinformationen vorliegen. diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 38abc7d0c..56c575e5d 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -19,7 +19,7 @@ FirmActResetMutualSupervision: Supervisors supervise each other FirmActAddSupervisors: Add supervisors FirmActAddSupersEmpty: No supervisors added FirmActAddSupersSet n postal: #{n} default company supervisors changed #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated. -RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisions terminated") (nact > 0)} +RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but no active supervisions were deactivated" (" and " <> tshow nact <> " active supervisions terminated") (nact > 0)} FirmActChangeContactUser: Change contact data for all company associates FirmActChangeContactFirm: Change company contact data FirmActChangeContactFirmInfo: The company contact data is only used for new company associates that would habe no contact information of their own otherwise. From 6ccbb3b7ff5848ed350674cb66d33b17b3516b22 Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 30 Jul 2024 15:57:43 +0200 Subject: [PATCH 05/23] refactor(ldap): some minor code cleaning --- src/Foundation/Yesod/Auth.hs | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index f31fc4a1e..cd6b4c42b 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -107,7 +107,7 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ] _other -> return res - $logDebugS "auth" $ tshow Creds{..} + $logDebugS "auth" $ tshow Creds{..} ldapPool' <- getsYesod $ view _appLdapPool flip catches excHandlers $ case ldapPool' of @@ -153,9 +153,9 @@ _upsertCampusUserMode mMode cs@Creds{..} defaultOther = apHash -ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User) -ldapLookupAndUpsert ident = - getsYesod (view _appLdapPool) >>= \case +ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User) +ldapLookupAndUpsert ident = + getsYesod (view _appLdapPool) >>= \case Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation." Just ldapPool -> campusUser'' ldapPool campusUserFailoverMode ident >>= \case @@ -188,15 +188,15 @@ upsertCampusUser upsertMode ldapData = do user@(Entity userId userRec) <- case oldUsers of Just [oldUserId] -> updateGetEntity oldUserId userUpdate _other -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate - unless (validDisplayName (newUser ^. _userTitle) + unless (validDisplayName (newUser ^. _userTitle) (newUser ^. _userFirstName) - (newUser ^. _userSurname) + (newUser ^. _userSurname) (userRec ^. _userDisplayName)) $ - update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ] - when (validEmail' (userRec ^. _userEmail)) $ do + update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ] -- update invalid display names only + when (validEmail' (userRec ^. _userEmail)) $ do -- RECALL: userRec already contains basic updates let emUps = [ UserDisplayEmail =. (newUser ^. _userEmail) | not (validEmail' (userRec ^. _userDisplayEmail)) ] ++ [ UserAuthentication =. AuthLDAP | is _AuthNoLogin (userRec ^. _userAuthentication) ] - unless (null emUps) $ update userId emUps + update userId emUps -- update already checks whether list is empty -- Attempt to update ident, too: unless (validEmail' (userRec ^. _userIdent)) $ void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ())) @@ -227,7 +227,7 @@ decodeUserTest mbIdent ldapData = do decodeUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertCampusUserMode -> Ldap.AttrList [] -> m (User,_) -decodeUser now UserDefaultConf{..} upsertMode ldapData = do +decodeUser now UserDefaultConf{..} upsertMode ldapData = do let userTelephone = decodeLdap ldapUserTelephone <&> canonicalPhone userMobile = decodeLdap ldapUserMobile <&> canonicalPhone @@ -266,7 +266,7 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do -- -> return $ CI.mk userEmail | otherwise -> throwM CampusUserInvalidEmail - + userLdapPrimaryKey <- if | [bs] <- ldapMap !!! ldapPrimaryKey , Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs @@ -305,13 +305,13 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do , userPrefersPostal = userDefaultPrefersPostal , .. } - userUpdate = + userUpdate = [ UserLastAuthentication =. Just now | isLogin ] ++ [ UserEmail =. userEmail | validEmail' userEmail ] ++ [ - -- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272 + -- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 191 UserFirstName =. userFirstName - , UserSurname =. userSurname + , UserSurname =. userSurname , UserLastLdapSynchronisation =. Just now , UserLdapPrimaryKey =. userLdapPrimaryKey , UserMobile =. userMobile From b9f70c779600299e77410771851e8eb30e921fb1 Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 30 Jul 2024 15:58:12 +0200 Subject: [PATCH 06/23] chore(avs): ensure supervisor reroutes are correct upon company switch --- src/Handler/Utils/Avs.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 50b70f784..43bc8793c 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -703,8 +703,9 @@ upsertCompanySuperior (mbCid, newAfi) mbOldAfi ) (\_old new -> [ -- UserSupervisorSupervisor E.=. new E.^. UserSupervisorSupervisor -- this is already given in case of conflict - UserSupervisorCompany E.=. new E.^. UserSupervisorCompany - , UserSupervisorReason E.=. new E.^. UserSupervisorReason + UserSupervisorCompany E.=. new E.^. UserSupervisorCompany + , UserSupervisorReason E.=. new E.^. UserSupervisorReason + , UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications ] ) reportAdminProblem $ AdminProblemCompanySuperiorChange supid cid oldSup From 43f5c5f4854d1ab2af27b479e72a58e2818a5696 Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 31 Jul 2024 14:16:40 +0200 Subject: [PATCH 07/23] fix(avs): fix #173 by not using firm superior email as display email Instead, a valid firm superior email is used as `UserEmail` so that it can be used as a fallback address. --- src/Handler/Utils/Avs.hs | 14 +++++++----- src/Handler/Utils/AvsUpdate.hs | 4 +++- src/Handler/Utils/Company.hs | 10 ++++++--- src/Model/Types/Avs.hs | 40 +++++++++++++++++----------------- src/Utils.hs | 1 + 5 files changed, 40 insertions(+), 29 deletions(-) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 43bc8793c..c48e31169 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -51,6 +51,7 @@ import Jobs.Queue import Utils.Avs import Utils.Users +import Utils.Mail (validEmail) import Handler.Utils.Users import Handler.Utils.Company import Handler.Utils.Qualification @@ -365,11 +366,12 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv , CU_API_UserMatrikelnummer -- , CU_API_UserCompanyPersonalNumber -- needs special treatment, see ldap_ups above ] - eml_up = mkUpdate usr newAvsDataContact oldAvsDataContact $ mkCheckUpdate CU_ADC_UserDisplayEmail -- Email updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen. + eml_up1 = mkUpdate usr newAvsDataContact oldAvsDataContact $ mkCheckUpdate CU_ADC_UserDisplayEmail -- DisplayEmail updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen. + eml_up2 = mkUpdate usr newAvsFirmInfo oldAvsFirmInfo $ mkCheckUpdate CU_AFI_UserEmail -- Email update erfolgt nur, wenn hier die SuperiorEmail als Fallback gespeichert wurde frm_up = mkUpdate' usr newAvsFirmInfo oldAvsFirmInfo $ mkCheckUpdate CU_AFI_UserPostAddress -- Legacy, if company postal is stored in user; should no longer be true for new users, since company address should now be referenced with UserCompany instead pin_up = mkUpdate' usr newAvsCardNo oldAvsCardNo $ -- Maybe update PDF pin to latest card CheckUpdate UserPinPassword $ to $ fmap avsFullCardNo2pin -- _Just . to avsFullCardNo2pin . re _Just - usr_up1 = eml_up `mcons` (frm_up `mcons` (pin_up `mcons` (ldap_ups <> per_ups))) + usr_up1 = catMaybes [eml_up1, eml_up2, frm_up, pin_up] <> ldap_ups <> per_ups avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons` [ UserAvsLastSynch =. now , UserAvsLastSynchError =. Nothing @@ -443,8 +445,9 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv -- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef) -- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId -- return pst_up - update usrId $ usr_up2 <> usr_up1 -- update user eventually - update uaId avs_ups -- update stored avsinfo for future updates + update usrId usr_up2 -- update user by company switch first (due to possible conflicts with usr_up2) + update usrId usr_up1 -- update user eventually + update uaId avs_ups -- update stored avsinfo for future updates return (apid, usrId) @@ -528,13 +531,14 @@ createAvsUserById muid api = do (Nothing, Nothing) -> do -- create fresh user Entity{entityKey=cid, entityVal=cmp} <- runDB $ upsertAvsCompany firmInfo Nothing -- individual runDB, since no need to rollback let pinPass = avsFullCardNo2pin <$> usrCardNo + superiorEmail = filterMaybe validEmail $ adc ^. _avsContactFirmInfo . _avsFirmEMailSuperior newUserData = AddUserData { audTitle = Nothing , audFirstName = cpi ^. _avsInfoFirstName & Text.strip , audSurname = cpi ^. _avsInfoLastName & Text.strip , audDisplayName = cpi ^. _avsInfoDisplayName , audDisplayEmail = adc ^. _avsContactPrimaryEmail . to (fromMaybe mempty) . from _CI - , audEmail = "AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI + , audEmail = maybe ("AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI) stripCI superiorEmail , audIdent = "AVSID:" <> ciShow api , audAuth = maybe AuthKindNoLogin (const AuthKindLDAP) internalPersNo , audMatriculation = cpi ^. _avsInfoPersonNo & Just diff --git a/src/Handler/Utils/AvsUpdate.hs b/src/Handler/Utils/AvsUpdate.hs index 5ff7c55fa..6b60c0780 100644 --- a/src/Handler/Utils/AvsUpdate.hs +++ b/src/Handler/Utils/AvsUpdate.hs @@ -87,6 +87,7 @@ instance MkCheckUpdate CU_AvsDataContcat_User where data CU_AvsFirmInfo_User = CU_AFI_UserPostAddress + | CU_AFI_UserEmail -- CU_AFI_UserDisplayEmail -- use _avsContactPrimaryEmailAddress instead deriving (Show, Eq) @@ -94,7 +95,8 @@ instance MkCheckUpdate CU_AvsFirmInfo_User where type MCU_Rec CU_AvsFirmInfo_User = User type MCU_Raw CU_AvsFirmInfo_User = AvsFirmInfo mkCheckUpdate CU_AFI_UserPostAddress = CheckUpdate UserPostAddress _avsFirmPostAddress - -- mkCheckUpdate CU_AFI_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsFirmPrimaryEmail . _Just . from _CI -- Maybe im AvsInfo, aber nicht im User, daher Opt + mkCheckUpdate CU_AFI_UserEmail = CheckUpdateOpt UserEmail $ _avsFirmEMailSuperior . _Just . from _CI -- in rare cases, firm superior email is used as fallback here + -- mkCheckUpdate CU_AFI_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsFirmPrimaryEmail . _Just . from _CI -- Maybe im AvsInfo, aber nicht im User, daher Opt -- NOTE: Ensure that the lenses between CU_UserAvs_User and CU_AvsPersonInfo_User/CU_AvsFirmInfo_User agree! diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index a5f2f02dc..b60423756 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -163,10 +163,14 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d usrPrefPost = userPrefersPostal usrRec usrPrefPostUp = toMaybe (Just usrPrefPost == (mbOldComp ^? _Just . _companyPrefersPostal)) (UserPrefersPostal =. companyPrefersPostal newCompany) - usrEmail :: UserEmail = userDisplayEmail usrRec + -- newCmpEmail :: UserEmail = fromMaybe "" $ companyEmail newCompany + usrEmail :: UserEmail = userEmail usrRec + usrDisplayEmail :: UserEmail = userDisplayEmail usrRec avsEmail :: Maybe UserEmail = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPrimaryEmail . _Just . from _CI - usrEmailUp = toMaybe (usrPostEmailUpds && avsEmail == Just usrEmail) (UserDisplayEmail =. "") - usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrEmailUp] + usrDisplayEmailUp = toMaybe (usrPostEmailUpds && avsEmail == Just usrDisplayEmail) (UserDisplayEmail =. "") -- delete DisplayEmail, if equal to AVS Firm Email + supEmail :: Maybe UserEmail = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmEMailSuperior . _Just . from _CI + usrEmailUp = toMaybe (usrPostEmailUpds && supEmail == Just usrEmail) (UserEmail =. "") -- delete UserEmail, if equal to AVS Firm Superior + usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrDisplayEmailUp, usrEmailUp] -- [UserPostAddress =. Nothing, UserPrefersPostal =. companyPrefersPostal newCompany] -- unconditional -- update uid usrUpdate -- repsertSuperiorSupervisor is not called here, since the Superior is indepentent of the actual company association diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index ef9752f0f..636b28291 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -216,7 +216,7 @@ instance PersistFieldSql AvsFullCardNo where parseAvsCardNo :: Text -> Maybe (Either AvsCardNo AvsFullCardNo) parseAvsCardNo = splitDigitsByDot AvsCardNo (AvsFullCardNo . AvsCardNo) -discernAvsCardPersonalNo :: Text -> Maybe (Either AvsInternalPersonalNo AvsFullCardNo) +discernAvsCardPersonalNo :: Text -> Maybe (Either AvsInternalPersonalNo AvsFullCardNo) discernAvsCardPersonalNo = splitDigitsByDot mkAvsInternalPersonalNo (AvsFullCardNo . AvsCardNo) -- | Just implies that argument is a whole number or decimal with one single digit after the point. Helper functions receive digit-parts without dot @@ -227,7 +227,7 @@ splitDigitsByDot fl fr (Text.span Char.isDigit -> (c, pv)) = Just $ Left $ fl c | Just ('.', v) <- Text.uncons pv , Just (Char.isDigit -> True, "") <- Text.uncons v - = Just $ Right $ fr c v + = Just $ Right $ fr c v splitDigitsByDot _ _ _ = Nothing -- The AVS API requires PersonIds sometimes as as mere numbers `AvsPersonId` and sometimes as tagged objects `AvsObjPersonId` @@ -453,7 +453,7 @@ deriveJSON defaultOptions } ''AvsStatusPerson makeLenses_ ''AvsStatusPerson - + data AvsDataPerson = AvsDataPerson { avsPersonFirstName :: Text -- WARNING: name stored as is, but AVS does contain weird whitespaces @@ -551,7 +551,7 @@ _avsInfoDisplayName :: Lens' AvsPersonInfo Text _avsInfoDisplayName = lens g s where g AvsPersonInfo{avsInfoFirstName, avsInfoLastName} = Text.append avsInfoFirstName $ Text.cons ' ' avsInfoLastName - s api dn = let (Text.strip -> fn, Text.strip -> ln) = Text.breakOnEnd " " dn + s api dn = let (Text.strip -> fn, Text.strip -> ln) = Text.breakOnEnd " " dn in api{avsInfoFirstName = fn, avsInfoLastName = ln} @@ -603,7 +603,7 @@ instance {-# OVERLAPS #-} Canonical (Maybe AvsFirmCommunication) where makeLenses_ ''AvsFirmCommunication _avsCommunicationAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmCommunication (Maybe Text) _avsCommunicationAddress = to mkAddr - where + where mkAddr AvsFirmCommunication{..} = composeAddress avsCommunicationStreetANDHouseNo avsCommunicationZIPCode avsCommunicationCity avsCommunicationCountry instance FromJSON AvsFirmCommunication where @@ -645,7 +645,7 @@ _avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo _avsFirmPostAddress = to mkPost where mkPost afi@AvsFirmInfo{avsFirmFirm} = - let someAddr = afi ^. _avsFirmPostAddressSimple + let someAddr = afi ^. _avsFirmPostAddressSimple prefAddr = plaintextToStoredMarkup . (avsFirmFirm <>) . Text.cons '\n' in prefAddr <$> someAddr @@ -657,27 +657,27 @@ _avsFirmPostAddressSimple = to mkPost mkPost AvsFirmInfo{..} = let firmAddr = composeAddress avsFirmStreetANDHouseNo avsFirmZIPCode avsFirmCity avsFirmCountry commAddr = avsFirmCommunication ^. _Just . _avsCommunicationAddress - in asum $ [res | res@(Just addr) <- [commAddr, firmAddr], validPostAddressText addr] + in asum $ [res | res@(Just addr) <- [commAddr, firmAddr], validPostAddressText addr] _avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text) _avsFirmPrimaryEmail = to mkEmail where mkEmail afi = - let candidates = catMaybes + let candidates = catMaybes [ afi ^. _avsFirmCommunication . _Just . _avsCommunicationEMail , afi ^. _avsFirmEMail - , afi ^. _avsFirmEMailSuperior -- only set for Fraport departments, hence this is a non-personal department wide email suitable as company email + , afi ^. _avsFirmEMailSuperior -- only set for Fraport departments, hence this is a non-personal department wide email suitable as company email ] in pickValidEmail candidates -- should we return an invalid email rather than none? -- | Not sure this is useful, since postal is ignored if there is no post address anyway _avsFirmPrefersPostal :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Bool _avsFirmPrefersPostal = to mkPostPref - where + where mkPostPref afi = isJust (afi ^. _avsFirmPostAddress) || isNothing (afi ^. _avsFirmPrimaryEmail) -- Note _avsFirmAddress is never empty; always includes the company name; consider using user _avsFirmPostAddress instead --- _avsFirmAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Text +-- _avsFirmAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Text -- _avsFirmAddress = to mkAddr -- where -- mkAddr AvsFirmInfo{..} = @@ -726,12 +726,12 @@ makeLenses_ ''AvsDataContact _avsContactPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsDataContact (Maybe Text) _avsContactPrimaryEmail = to mkEmail where - mkEmail adc = + mkEmail adc = let candidates = catMaybes [ adc ^. _avsContactFirmInfo . _avsFirmCommunication . _Just . _avsCommunicationEMail , adc ^. _avsContactFirmInfo . _avsFirmEMail , adc ^. _avsContactPersonInfo . _avsInfoPersonEMail - , adc ^. _avsContactFirmInfo . _avsFirmEMailSuperior -- only set for Fraport departments, hence this is a non-personal department wide email suitable as company email + -- , adc ^. _avsContactFirmInfo . _avsFirmEMailSuperior -- only set for Fraport departments, hence this is a non-personal department wide email suitable as company email. Superior email is used as systemEmail only. ] in pickValidEmail candidates -- should we return an invalid email rather than none? @@ -848,15 +848,15 @@ fixAvsQueryPerson AvsQueryPerson{avsPersonQueryVersionNo=Nothing, avsPersonQuery = AvsQueryPerson { avsPersonQueryCardNo = Just acn1 , avsPersonQueryVersionNo = Just avc1 - , avsPersonQueryFirstName = canonical avsPersonQueryFirstName - , avsPersonQueryLastName = canonical avsPersonQueryLastName + , avsPersonQueryFirstName = canonical avsPersonQueryFirstName + , avsPersonQueryLastName = canonical avsPersonQueryLastName , avsPersonQueryInternalPersonalNo = canonical avsPersonQueryInternalPersonalNo } fixAvsQueryPerson AvsQueryPerson{..} = AvsQueryPerson - { avsPersonQueryCardNo = canonical avsPersonQueryCardNo - , avsPersonQueryVersionNo = canonical avsPersonQueryVersionNo - , avsPersonQueryFirstName = canonical avsPersonQueryFirstName - , avsPersonQueryLastName = canonical avsPersonQueryLastName + { avsPersonQueryCardNo = canonical avsPersonQueryCardNo + , avsPersonQueryVersionNo = canonical avsPersonQueryVersionNo + , avsPersonQueryFirstName = canonical avsPersonQueryFirstName + , avsPersonQueryLastName = canonical avsPersonQueryLastName , avsPersonQueryInternalPersonalNo = canonical avsPersonQueryInternalPersonalNo } @@ -878,7 +878,7 @@ deriveJSON defaultOptions ''AvsQueryGetLicences data AvsQueryGetAllLicences = AvsQueryGetAllLicences -- for convenience, encoding AvsQueryGetLicences (AvsObjPersonId avsPersonIdZero) deriving (Eq, Ord, Show, Generic) - + newtype AvsQuerySetLicences = AvsQuerySetLicences (Set AvsPersonLicence) deriving (Eq, Ord, Show, Generic) deriveJSON defaultOptions ''AvsQuerySetLicences diff --git a/src/Utils.hs b/src/Utils.hs index 69b114b01..94baeef10 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -991,6 +991,7 @@ catchIfMPlus :: forall m e a. (MonadPlus m, MonadCatch m, Exception e) => (e -> catchIfMPlus p act = catchIf p act (const mzero) -- | Monadic version of 'fromMaybe' +-- Warning: fromMaybeM [1,2,3] [Nothing, Just 4, Just 5, Nothing] == [1,2,3,4,5,1,2,3] and fromMaybeM [1,2,3] [Just 4] == [4] fromMaybeM :: Monad m => m a -> m (Maybe a) -> m a fromMaybeM act = maybeM act pure From 507a7e02fc68476d01031dc9f9ee1a669a453ed1 Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 31 Jul 2024 15:03:26 +0200 Subject: [PATCH 08/23] fix(avs): using firm superior as UserEmail is a no-go due to uniqueness constraints Thus, we do not save the firm superior as `UserEmail` any more. The firm superior email is still used as a fallback for `CompanyEmail` which in turn is used as a fallback email, if a `CompanyUser` has no valid email at all. --- src/Handler/Utils/Avs.hs | 12 ++++++------ src/Handler/Utils/AvsUpdate.hs | 4 ++-- src/Handler/Utils/Company.hs | 5 +---- src/Utils.hs | 9 ++++++++- 4 files changed, 17 insertions(+), 13 deletions(-) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index c48e31169..aa17b586d 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -51,7 +51,7 @@ import Jobs.Queue import Utils.Avs import Utils.Users -import Utils.Mail (validEmail) +-- import Utils.Mail (validEmail) import Handler.Utils.Users import Handler.Utils.Company import Handler.Utils.Qualification @@ -366,12 +366,12 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv , CU_API_UserMatrikelnummer -- , CU_API_UserCompanyPersonalNumber -- needs special treatment, see ldap_ups above ] - eml_up1 = mkUpdate usr newAvsDataContact oldAvsDataContact $ mkCheckUpdate CU_ADC_UserDisplayEmail -- DisplayEmail updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen. - eml_up2 = mkUpdate usr newAvsFirmInfo oldAvsFirmInfo $ mkCheckUpdate CU_AFI_UserEmail -- Email update erfolgt nur, wenn hier die SuperiorEmail als Fallback gespeichert wurde + eml_up = mkUpdate usr newAvsDataContact oldAvsDataContact $ mkCheckUpdate CU_ADC_UserDisplayEmail -- DisplayEmail updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen. + -- eml_up2 = mkUpdate usr newAvsFirmInfo oldAvsFirmInfo $ mkCheckUpdate CU_AFI_UserEmail -- Email update erfolgt nur, wenn hier die SuperiorEmail als Fallback gespeichert wurde; UserEmail Uniqueness nicht gewährleistet frm_up = mkUpdate' usr newAvsFirmInfo oldAvsFirmInfo $ mkCheckUpdate CU_AFI_UserPostAddress -- Legacy, if company postal is stored in user; should no longer be true for new users, since company address should now be referenced with UserCompany instead pin_up = mkUpdate' usr newAvsCardNo oldAvsCardNo $ -- Maybe update PDF pin to latest card CheckUpdate UserPinPassword $ to $ fmap avsFullCardNo2pin -- _Just . to avsFullCardNo2pin . re _Just - usr_up1 = catMaybes [eml_up1, eml_up2, frm_up, pin_up] <> ldap_ups <> per_ups + usr_up1 = mconss [eml_up, frm_up, pin_up] $ ldap_ups <> per_ups avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons` [ UserAvsLastSynch =. now , UserAvsLastSynchError =. Nothing @@ -531,14 +531,14 @@ createAvsUserById muid api = do (Nothing, Nothing) -> do -- create fresh user Entity{entityKey=cid, entityVal=cmp} <- runDB $ upsertAvsCompany firmInfo Nothing -- individual runDB, since no need to rollback let pinPass = avsFullCardNo2pin <$> usrCardNo - superiorEmail = filterMaybe validEmail $ adc ^. _avsContactFirmInfo . _avsFirmEMailSuperior + -- superiorEmail = filterMaybe validEmail $ adc ^. _avsContactFirmInfo . _avsFirmEMailSuperior newUserData = AddUserData { audTitle = Nothing , audFirstName = cpi ^. _avsInfoFirstName & Text.strip , audSurname = cpi ^. _avsInfoLastName & Text.strip , audDisplayName = cpi ^. _avsInfoDisplayName , audDisplayEmail = adc ^. _avsContactPrimaryEmail . to (fromMaybe mempty) . from _CI - , audEmail = maybe ("AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI) stripCI superiorEmail + , audEmail = "AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI , audIdent = "AVSID:" <> ciShow api , audAuth = maybe AuthKindNoLogin (const AuthKindLDAP) internalPersNo , audMatriculation = cpi ^. _avsInfoPersonNo & Just diff --git a/src/Handler/Utils/AvsUpdate.hs b/src/Handler/Utils/AvsUpdate.hs index 6b60c0780..a468d4392 100644 --- a/src/Handler/Utils/AvsUpdate.hs +++ b/src/Handler/Utils/AvsUpdate.hs @@ -87,7 +87,7 @@ instance MkCheckUpdate CU_AvsDataContcat_User where data CU_AvsFirmInfo_User = CU_AFI_UserPostAddress - | CU_AFI_UserEmail + -- CU_AFI_UserEmail -- PROBLEM: UserEmail must be unique! -- CU_AFI_UserDisplayEmail -- use _avsContactPrimaryEmailAddress instead deriving (Show, Eq) @@ -95,7 +95,7 @@ instance MkCheckUpdate CU_AvsFirmInfo_User where type MCU_Rec CU_AvsFirmInfo_User = User type MCU_Raw CU_AvsFirmInfo_User = AvsFirmInfo mkCheckUpdate CU_AFI_UserPostAddress = CheckUpdate UserPostAddress _avsFirmPostAddress - mkCheckUpdate CU_AFI_UserEmail = CheckUpdateOpt UserEmail $ _avsFirmEMailSuperior . _Just . from _CI -- in rare cases, firm superior email is used as fallback here + -- mkCheckUpdate CU_AFI_UserEmail = CheckUpdateOpt UserEmail $ _avsFirmEMailSuperior . _Just . from _CI -- in rare cases, firm superior email is used as fallback here; but UserEmail must be unique! -- mkCheckUpdate CU_AFI_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsFirmPrimaryEmail . _Just . from _CI -- Maybe im AvsInfo, aber nicht im User, daher Opt diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index b60423756..81b76d10f 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -164,13 +164,10 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d usrPrefPostUp = toMaybe (Just usrPrefPost == (mbOldComp ^? _Just . _companyPrefersPostal)) (UserPrefersPostal =. companyPrefersPostal newCompany) -- newCmpEmail :: UserEmail = fromMaybe "" $ companyEmail newCompany - usrEmail :: UserEmail = userEmail usrRec usrDisplayEmail :: UserEmail = userDisplayEmail usrRec avsEmail :: Maybe UserEmail = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPrimaryEmail . _Just . from _CI usrDisplayEmailUp = toMaybe (usrPostEmailUpds && avsEmail == Just usrDisplayEmail) (UserDisplayEmail =. "") -- delete DisplayEmail, if equal to AVS Firm Email - supEmail :: Maybe UserEmail = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmEMailSuperior . _Just . from _CI - usrEmailUp = toMaybe (usrPostEmailUpds && supEmail == Just usrEmail) (UserEmail =. "") -- delete UserEmail, if equal to AVS Firm Superior - usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrDisplayEmailUp, usrEmailUp] + usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrDisplayEmailUp] -- [UserPostAddress =. Nothing, UserPrefersPostal =. companyPrefersPostal newCompany] -- unconditional -- update uid usrUpdate -- repsertSuperiorSupervisor is not called here, since the Superior is indepentent of the actual company association diff --git a/src/Utils.hs b/src/Utils.hs index 94baeef10..4d6113ba0 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -991,7 +991,7 @@ catchIfMPlus :: forall m e a. (MonadPlus m, MonadCatch m, Exception e) => (e -> catchIfMPlus p act = catchIf p act (const mzero) -- | Monadic version of 'fromMaybe' --- Warning: fromMaybeM [1,2,3] [Nothing, Just 4, Just 5, Nothing] == [1,2,3,4,5,1,2,3] and fromMaybeM [1,2,3] [Just 4] == [4] +-- Warning: fromMaybeM [1,2,3] [Nothing, Just 4, Just 5, Nothing] == [1,2,3,4,5,1,2,3] and fromMaybeM [1,2,3] [Just 4] == [4], use `mconss` instead fromMaybeM :: Monad m => m a -> m (Maybe a) -> m a fromMaybeM act = maybeM act pure @@ -1002,6 +1002,13 @@ mcons :: Maybe a -> [a] -> [a] mcons Nothing xs = xs mcons (Just x) xs = x:xs +mconss :: [Maybe a] -> [a] -> [a] +mconss [] tl = tl +mconss (m:xs) tl + | Just x <- m = x : mconss xs tl + | otherwise = mconss xs tl + + -- | apply binary function to maybes, but ignores Nothing by using id if possible, unlike fmap/ap ignoreNothing :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a ignoreNothing _ Nothing y = y From 0fde59c19aefa708e10ff9349044eae9a4278540 Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 31 Jul 2024 17:51:13 +0200 Subject: [PATCH 09/23] chore(profile): show user courses among enrolled course type list (Recall: course = tutorial, course type = course) --- src/Handler/Profile.hs | 107 ++++++++++++++++++++++++----------------- test/Database/Fill.hs | 14 +++++- 2 files changed, 75 insertions(+), 46 deletions(-) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index d888678be..9bddff59c 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -31,9 +31,11 @@ import Utils.Print (validCmdArgument) import Data.Map ((!)) import qualified Data.Map as Map import qualified Data.Set as Set -import qualified Database.Esqueleto.Legacy as E +import Database.Esqueleto.Experimental ((:&)(..)) +import qualified Database.Esqueleto.Experimental as E +import qualified Database.Esqueleto.Legacy as EL (on,from) import qualified Database.Esqueleto.Utils as E --- import Database.Esqueleto ((^.)) + import qualified Data.Text as Text import Data.List (inits) @@ -192,28 +194,28 @@ notificationForm template = wFormToAForm $ do -> return False NTKCourseParticipant | Just uid <- mbUid - -> fmap not . E.selectExists . E.from $ \courseParticipant -> + -> fmap not . E.selectExists . EL.from $ \courseParticipant -> E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val uid E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive NTKSubmissionUser | Just uid <- mbUid - -> fmap not . E.selectExists . E.from $ \submissionUser -> + -> fmap not . E.selectExists . EL.from $ \submissionUser -> E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid NTKExamParticipant | Just uid <- mbUid - -> fmap not . E.selectExists . E.from $ \examRegistration -> + -> fmap not . E.selectExists . EL.from $ \examRegistration -> E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val uid NTKCorrector | Just uid <- mbUid - -> fmap not . E.selectExists . E.from $ \sheetCorrector -> + -> fmap not . E.selectExists . EL.from $ \sheetCorrector -> E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid NTKCourseLecturer | Just uid <- mbUid - -> fmap not . E.selectExists . E.from $ \lecturer -> + -> fmap not . E.selectExists . EL.from $ \lecturer -> E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid NTKFunctionary f | Just uid <- mbUid - -> fmap not . E.selectExists . E.from $ \userFunction -> + -> fmap not . E.selectExists . EL.from $ \userFunction -> E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid E.&&. userFunction E.^. UserFunctionFunction E.==. E.val f _ | Nothing <- mbUid -> return False -- Show everything for not-logged-in users (e.g. if they presented a token) @@ -428,8 +430,8 @@ serveProfileR :: (UserId, User) -> Handler Html serveProfileR (uid, user@User{..}) = do currentRoute <- fromMaybe ProfileR <$> getCurrentRoute (userSchools, userExamOfficeLabels) <- runDB $ do - userSchools <- fmap (setOf $ folded . _Value) . E.select . E.from $ \school -> do - E.where_ . E.exists . E.from $ \userSchool -> + userSchools <- fmap (setOf $ folded . _Value) . E.select . EL.from $ \school -> do + E.where_ . E.exists . EL.from $ \userSchool -> E.where_ $ E.not_ (userSchool E.^. UserSchoolIsOptOut) E.&&. userSchool E.^. UserSchoolUser E.==. E.val uid E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId @@ -519,8 +521,8 @@ serveProfileR (uid, user@User{..}) = do oldExamLabels = userExamOfficeLabels newExamLabels = stgExamOfficeSettings & eosettingsLabels forM_ oldExamLabels $ \(Entity eolid ExamOfficeLabel{..}) -> unless (Right eolid `Map.member` newExamLabels || Left examOfficeLabelName `Map.member` newExamLabels) $ do - E.delete . E.from $ \examOfficeExternalExamLabel -> E.where_ $ examOfficeExternalExamLabel E.^. ExamOfficeExternalExamLabelLabel E.==. E.val eolid - E.delete . E.from $ \examOfficeExamLabel -> E.where_ $ examOfficeExamLabel E.^. ExamOfficeExamLabelLabel E.==. E.val eolid + E.delete . EL.from $ \examOfficeExternalExamLabel -> E.where_ $ examOfficeExternalExamLabel E.^. ExamOfficeExternalExamLabelLabel E.==. E.val eolid + E.delete . EL.from $ \examOfficeExamLabel -> E.where_ $ examOfficeExamLabel E.^. ExamOfficeExamLabelLabel E.==. E.val eolid when (csvExportLabel userCsvOptions == Just examOfficeLabelName) $ update uid [ UserCsvOptions =. userCsvOptions { csvExportLabel = Nothing } ] delete eolid @@ -633,19 +635,19 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do addressLinkdIcon <- messageTooltip <$> messageIconI Info IconLink MsgAddressIsLinkedTip (actualPrefersPostal, (actualPostAddress, postalAutomatic), (actualDisplayEmail, emailAutomatic)) <- getPostalPreferenceAndAddress' usrEnt functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] [] - lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do - E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId - E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet + lecture_corrector <- E.select $ E.distinct $ EL.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do + EL.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + EL.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand) - studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do - E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId - E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId + studies <- E.select $ EL.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do + EL.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId + EL.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid return (studyfeat, studydegree, studyterms) companies <- wgtCompanies uid - -- supervisors' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do - -- E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId + -- supervisors' <- E.select $ EL.from $ \(spvr `E.InnerJoin` usrSpvr) -> do + -- EL.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId -- E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid -- E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)] -- return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications) @@ -653,8 +655,8 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do -- supervisors = intersperse (text2widget ", ") $ -- (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors' -- icnReroute = text2widget " " <> toWgt (icon IconReroute) - -- supervisees' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do - -- E.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId + -- supervisees' <- E.select $ EL.from $ \(spvr `E.InnerJoin` usrSpvr) -> do + -- EL.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId -- E.where_ $ spvr E.^. UserSupervisorSupervisor E.==. E.val uid -- return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications) -- let numSupervisees = length supervisees' @@ -681,7 +683,7 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do -- let examTable, ownTutorialTable, tutorialTable :: Widget -- examTable = i18n MsgPersonalInfoExamAchievementsWip -- ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip - -- tutorialTable = i18n MsgPersonalInfoTutorialsWip + -- tutorialTable = i18n MsgPersonalInfoTutorialsWip -- note that tutorials are linked in enrolledCoursesTable cID <- encrypt uid mCRoute <- getCurrentRoute @@ -705,7 +707,7 @@ mkOwnedCoursesTable = withType = id dbtSQLQuery' uid (course `E.InnerJoin` lecturer) = do - E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse + EL.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid return ( course E.^. CourseTerm , course E.^. CourseSchool @@ -747,18 +749,28 @@ mkOwnedCoursesTable = -- | Table listing all courses that the given user is enrolled in mkEnrolledCoursesTable :: UserId -> DB (Bool, Widget) -mkEnrolledCoursesTable = - let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) +mkEnrolledCoursesTable uid = do + usrTuts <- E.select $ do + (tpar :& tut) <- E.from $ E.table @TutorialParticipant `E.innerJoin` E.table @Tutorial + `E.on` (\(tpar :& tut) -> tut E.^. TutorialId E.==. tpar E.^. TutorialParticipantTutorial) + E.where_ $ tpar E.^. TutorialParticipantUser E.==. E.val uid + E.orderBy [E.asc $ tut E.^. TutorialCourse, E.desc $ tut E.^. TutorialName] -- Data.Map.fromAscListWith reverses tutorials, hence E.desc + return (tut E.^. TutorialCourse, tut E.^. TutorialName) + + let usrTutMap :: Map CourseId [TutorialName] + usrTutMap = Map.fromAscListWith (++) [(tcid, [tnm]) | (E.Value tcid, E.Value tnm) <- usrTuts] + + withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) withType = id validator = def & defaultSorting [SortDescBy "time"] - in \uid -> (_1 %~ getAny) <$> dbTableWidget validator + (_1 %~ getAny) <$> dbTableWidget validator DBTable { dbtIdent = "courseMembership" :: Text , dbtSQLQuery = \(course `E.InnerJoin` participant) -> do - E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse + EL.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive return (course, participant E.^. CourseParticipantRegistration) @@ -775,7 +787,14 @@ mkEnrolledCoursesTable = , sortable (Just "time") (i18nCell MsgProfileRegistered) $ do regTime <- view $ _dbrOutput . _2 return $ dateTimeCell regTime - ] + , sortable Nothing (i18nCell MsgCourseTutorials) $ \(view $ _dbrOutput . _1 -> Entity{entityKey=cid, entityVal=Course{..}}) -> + cell [whamlet| +
    + $forall tutName <- maybeMonoid (Map.lookup cid usrTutMap) +
  • + ^{simpleLink (citext2widget tutName) (CTutorialR courseTerm courseSchool courseShorthand tutName TUsersR)} + |] + ] , dbtSorting = Map.fromList [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseName ) , ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm ) @@ -808,9 +827,9 @@ mkSubmissionTable = withType = id dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` subUser) = do - E.on $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission - E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet - E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + EL.on $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission + EL.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet + EL.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.where_ $ subUser E.^. SubmissionUserUser E.==. E.val uid let crse = ( course E.^. CourseTerm , course E.^. CourseSchool @@ -821,7 +840,7 @@ mkSubmissionTable = dbtRowKey (_ `E.InnerJoin` _ `E.InnerJoin` submission `E.InnerJoin` _) = submission E.^. SubmissionId lastSubEdit uid submission = -- latest Edit-Time of this user for submission - E.subSelectMaybe . E.from $ \subEdit -> do + E.subSelectMaybe . EL.from $ \subEdit -> do E.where_ $ subEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId E.&&. subEdit E.^. SubmissionEditUser E.==. E.val (Just uid) return . E.max_ $ subEdit E.^. SubmissionEditTime @@ -888,8 +907,8 @@ mkSubmissionGroupTable = withType = id dbtSQLQuery' uid (course `E.InnerJoin` sgroup `E.InnerJoin` sguser) = do - E.on $ sguser E.^. SubmissionGroupUserSubmissionGroup E.==. sgroup E.^. SubmissionGroupId - E.on $ sgroup E.^. SubmissionGroupCourse E.==. course E.^. CourseId + EL.on $ sguser E.^. SubmissionGroupUserSubmissionGroup E.==. sgroup E.^. SubmissionGroupId + EL.on $ sgroup E.^. SubmissionGroupCourse E.==. course E.^. CourseId E.where_ $ sguser E.^. SubmissionGroupUserUser E.==. E.val uid let crse = ( course E.^. CourseTerm , course E.^. CourseSchool @@ -942,18 +961,18 @@ mkCorrectionsTable = -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a) withType = id - corrsAssigned uid sheet = E.subSelectCount . E.from $ \submission -> + corrsAssigned uid sheet = E.subSelectCount . EL.from $ \submission -> E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) - corrsCorrected uid sheet = E.subSelectCount . E.from $ \submission -> + corrsCorrected uid sheet = E.subSelectCount . EL.from $ \submission -> E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) E.&&. E.not_ (E.isNothing $ submission E.^. SubmissionRatingTime) dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` corrector) = do - E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet - E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + EL.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet + EL.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid let crse = ( course E.^. CourseTerm , course E.^. CourseSchool @@ -1018,9 +1037,9 @@ mkQualificationsTable = DBTable { dbtIdent = "userQualifications" :: Text , dbtSQLQuery = \(quali `E.InnerJoin` quser `E.LeftOuterJoin` qblock) -> do - E.on $ quser E.^. QualificationUserId E.=?. qblock E.?. QualificationUserBlockQualificationUser + EL.on $ quser E.^. QualificationUserId E.=?. qblock E.?. QualificationUserBlockQualificationUser E.&&. qblock `isLatestBlockBefore` E.val now - E.on $ quser E.^. QualificationUserQualification E.==. quali E.^. QualificationId + EL.on $ quser E.^. QualificationUserQualification E.==. quali E.^. QualificationId E.where_ $ quser E.^. QualificationUserUser E.==. E.val uid return (quali, quser, qblock) , dbtRowKey = \(_quali `E.InnerJoin` quser `E.LeftOuterJoin` _qblock) -> quser E.^. QualificationUserId @@ -1078,7 +1097,7 @@ mkSupervisorsTable uid = dbTableWidget validator DBTable{..} dbtStyle = def dbtSQLQuery (usr `E.InnerJoin` spr) = do - E.on $ spr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + EL.on $ spr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId E.where_ $ spr E.^. UserSupervisorUser E.==. E.val uid return (usr, spr) dbtRowKey (_ `E.InnerJoin` spr) = spr E.^. UserSupervisorId @@ -1131,7 +1150,7 @@ mkSuperviseesTable userPrefersPostal uid = dbTableWidget validator DBTable{..} dbtStyle = def dbtSQLQuery (usr `E.InnerJoin` spr) = do - E.on $ spr E.^. UserSupervisorUser E.==. usr E.^. UserId + EL.on $ spr E.^. UserSupervisorUser E.==. usr E.^. UserId E.where_ $ spr E.^. UserSupervisorSupervisor E.==. E.val uid return (usr, spr) dbtRowKey (_ `E.InnerJoin` spr) = spr E.^. UserSupervisorId @@ -1290,7 +1309,7 @@ postCsvOptionsR = do Entity uid User{userCsvOptions} <- requireAuth userIsExamOffice <- hasReadAccessTo $ ExamOfficeR EOExamsR - examOfficeLabels <- if not userIsExamOffice then return mempty else runDB . E.select . E.from $ \examOfficeLabel -> do + examOfficeLabels <- if not userIsExamOffice then return mempty else runDB . E.select . EL.from $ \examOfficeLabel -> do E.where_ $ examOfficeLabel E.^. ExamOfficeLabelUser E.==. E.val uid E.orderBy [ E.asc (examOfficeLabel E.^. ExamOfficeLabelName) ] return $ examOfficeLabel E.^. ExamOfficeLabelName diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 996b018ee..ebd39a99b 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -1098,7 +1098,7 @@ fillDb = do , tutorialFirstDay = Just firstDay } insert_ $ Tutor tut1 jost - insert_ Tutorial + tut2 <- insert Tutorial { tutorialName = mkName "Vorlage" , tutorialCourse = c , tutorialType = "Vorlage" @@ -1138,7 +1138,7 @@ fillDb = do , tutorialTutorControlled = True , tutorialFirstDay = Just firstDay } - insert_ Tutorial + tut3 <- insert Tutorial { tutorialName = mkName "Sondertutoriumsvorlage" , tutorialCourse = c , tutorialType = "Vorlage_Sondertutorium" @@ -1178,6 +1178,16 @@ fillDb = do , tutorialTutorControlled = True , tutorialFirstDay = Just $ succ $ succ firstDay } + insert_ $ CourseParticipant c jost now CourseParticipantActive + insert_ $ CourseParticipant c gkleen now $ CourseParticipantInactive True + insert_ $ CourseParticipant c fhamann now $ CourseParticipantInactive False + insert_ $ CourseParticipant c svaupel now CourseParticipantActive + insert_ $ TutorialParticipant tut1 svaupel + insert_ $ TutorialParticipant tut2 svaupel + when (odd tyear) $ insert_ $ TutorialParticipant tut3 svaupel + insert_ $ TutorialParticipant tut1 gkleen + insert_ $ TutorialParticipant tut2 fhamann + when (even tyear) $ insert_ $ TutorialParticipant tut3 jost when (odd tyear) $ void . insert' $ Exam { examCourse = c From bc47387c91dda60a2f12e52dba28ea7b079316f0 Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 31 Jul 2024 19:03:30 +0200 Subject: [PATCH 10/23] fix(course): WIP course cloning should propose same associated qualifications, towards #149 --- src/Handler/Course/Edit.hs | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index c1d5a580b..509a8d261 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -46,12 +46,13 @@ data CourseForm = CourseForm , cfRegTo :: Maybe UTCTime , cfDeRegUntil :: Maybe UTCTime , cfLecturers :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)] + , cfQualis :: [(QualificationId, Int)] } makeLenses_ ''CourseForm -courseToForm :: Entity Course -> [Lecturer] -> Map UserEmail (InvitationDBData Lecturer) -> CourseForm -courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm +courseToForm :: Entity Course -> [Lecturer] -> Map UserEmail (InvitationDBData Lecturer) -> [CourseQualification] -> CourseForm +courseToForm (Entity cid Course{..}) lecs lecInvites qualis = CourseForm { cfCourseId = Just cid , cfName = courseName , cfDesc = courseDescription @@ -69,6 +70,9 @@ courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm , cfDeRegUntil = courseDeregisterUntil , cfLecturers = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs] ++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- Map.toList lecInvites ] + -- TODO: Filterung nach aktueller Schule, da ansonsten ein Sicherheitleck droht! Siehe #150 + , cfQualis = [ (courseQualificationQualification, courseQualificationSortOrder) + | CourseQualification{..} <- qualis, courseQualificationCourse == cid ] } @@ -91,7 +95,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB (termsField, userTerms) <- liftHandler $ case template of -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin - (Just cform) | (Just cid) <- cfCourseId cform -> do -- edit existing course + (Just cform) | (Just cid) <- cfCourseId cform -> do -- edit existing course& \c _courseOld@Course{..} <- runDB $ get404 cid mayEditTerm <- isAuthorized TermEditR True mayDelete <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True @@ -208,6 +212,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB & setTooltip MsgCourseDeregisterUntilTip) (deepAlt (cfDeRegUntil <$> template) newDeRegUntil) <* aformSection MsgCourseFormSectionAdministration <*> lecturerForm + <*> pure mempty -- TODO: continue here !!! -- TODO: Filterung nach aktueller Schule, da ansonsten ein Sicherheitleck droht! Siehe #150 return (result, widget) @@ -280,8 +285,11 @@ getCourseNewR = do E.limit 1 return course template <- case oldCourses of - (oldTemplate:_) -> - let newTemplate = courseToForm oldTemplate mempty mempty in + (oldTemplate:_) -> runDB $ do + mbLecs <- oldTemplate & \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType] + mbLecInvites <- oldTemplate & sourceInvitationsF . entityKey + mbQualis <- oldTemplate & \course -> map entityVal <$> selectList [CourseQualificationCourse ==. entityKey course] [Asc CourseQualificationSortOrder] + let newTemplate = courseToForm oldTemplate mbLecs mbLecInvites mbQualis return $ Just $ newTemplate { cfCourseId = Nothing , cfTerm = TermKey $ termFromRational 0 -- invalid, will be ignored; undefined won't work due to strictness @@ -314,10 +322,11 @@ pgCEditR tid ssh csh = do mbCourse <- getBy (TermSchoolCourseShort tid ssh csh) mbLecs <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType] mbLecInvites <- for mbCourse $ sourceInvitationsF . entityKey - return $ (,,) <$> mbCourse <*> mbLecs <*> mbLecInvites + mbQualis <- for mbCourse $ \course -> map entityVal <$> selectList [CourseQualificationCourse ==. entityKey course] [Asc CourseQualificationSortOrder] + return $ (,,,) <$> mbCourse <*> mbLecs <*> mbLecInvites <*> mbQualis -- IMPORTANT: both GET and POST Handler must use the same template, -- since an Edit is identified via CourseID, which is not embedded in the received form data for security reasons. - courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 3) courseToForm <$> courseData + courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 4) courseToForm <$> courseData -- | Course Creation and Editing From 5b6e4e60e7d2957fbce93ee2e2d6d3464b4e3db7 Mon Sep 17 00:00:00 2001 From: Steffen Date: Thu, 1 Aug 2024 11:41:27 +0200 Subject: [PATCH 11/23] fix(course): fix #150 course edit for associated qualifications requires school admin or lecturer rights --- .../courses/courses/de-de-formal.msg | 2 + .../categories/courses/courses/en-eu.msg | 4 +- src/Handler/Course/Edit.hs | 122 +++++++++++------- src/Utils.hs | 8 +- 4 files changed, 86 insertions(+), 50 deletions(-) diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index d8faf2d87..e1e39aa94 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -70,6 +70,8 @@ CourseInvalidInput: Eingaben bitte korrigieren. CourseEditTitle: Kursart editieren/anlegen CourseEditOk tid@TermId ssh@SchoolId csh@CourseShorthand: Kursart #{tid}-#{ssh}-#{csh} wurde erfolgreich geändert. CourseEditDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kursart #{tid}-#{ssh}-#{csh} konnte nicht geändert werden: Es gibt bereits einen andere Kursart mit dem selben Kürzel oder Titel in diesem Jahr und Bereich. +CourseEditQualificationFail: Eine Qualifikation konnte uas unbekanntem Grund nicht mit diesem Kurs assoziert werden. +CourseEditQualificationFailRights qsh@QualificationShorthand ssh@SchoolId: Qualifikation #{qsh} konnte nicht mit diesem Kurs assoziert werden, da Ihre Berechtigungen für Bereich #{ssh} dazu nicht ausreichen. CourseLecturer: Kursverwalter:in MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Einladung zur Kursartteilnahme CourseParticipantInviteHeading courseName@Text: Einladung zum Kursartteilnahmer für #{courseName} diff --git a/messages/uniworx/categories/courses/courses/en-eu.msg b/messages/uniworx/categories/courses/courses/en-eu.msg index 9f14a46a7..43ea7c45e 100644 --- a/messages/uniworx/categories/courses/courses/en-eu.msg +++ b/messages/uniworx/categories/courses/courses/en-eu.msg @@ -70,8 +70,10 @@ CourseInvalidInput: Invalid input CourseEditTitle: Edit/Create course CourseEditOk tid ssh csh: Successfully edited course type #{tid}-#{ssh}-#{csh} CourseEditDupShort tid ssh csh: Could not edit course type #{tid}-#{ssh}-#{csh}. Another course type with the same shorthand or title already exists for the given year and school. +CourseEditQualificationFail: A qualifikation could not be associated with this course for unknown reasons. +CourseEditQualificationFailRights qsh ssh: Qualification #{qsh} could not be associated with this course, due to your insufficient rights for department #{ssh}. CourseLecturer: Course administrator -MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Invitaion to join the course +MailSubjectParticipantInvitation tid ssh csh: [#{tid}-#{ssh}-#{csh}] Invitaion to join the course CourseParticipantInviteHeading courseName: Invitation to enrol for #{courseName} CourseParticipantInviteExplanation: You were invited to be a participant of a course. CourseParticipantInviteField: Email addresses to invite diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 509a8d261..bfec8a864 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -106,51 +106,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB -> return (termsSetField [cfTerm cform], [cfTerm cform]) _allOtherCases -> (termsAllowedField, ) . Set.toList <$> runDB getActiveTerms - let miAdd :: ListPosition -> Natural -> ListLength -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId)))) - miAdd _ _ _ nudge btn = Just $ \csrf -> do - (addRes, addView) <- mpreq (multiUserInvitationField $ MUILookupAnyUser Nothing) (fslI MsgCourseLecturerEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing - let addRes'' = addRes <&> \newDat oldDat -> if - | existing <- newDat `Set.intersection` Set.fromList (Map.elems oldDat) - , not $ Set.null existing - -> FormFailure [mr MsgCourseLecturerAlreadyAdded] - | otherwise - -> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) $ Map.lookupMax oldDat ..] $ Set.toList newDat - addView' = $(widgetFile "course/lecturerMassInput/add") - return (addRes'', addView') - - miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType) - miCell _ (Right lid) defType nudge = \csrf -> do - (lrwRes,lrwView) <- mreq (selectField optionsFinite) (fslI MsgCourseLecturerType & addName (nudge "lecturer-type")) (join defType) - usr <- liftHandler . runDB $ get404 lid - let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown") - return (Just <$> lrwRes,lrwView') - miCell _ (Left lEmail) defType nudge = \csrf -> do - (lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType - invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning - let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation") - return (lrwRes,lrwView') - - miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape - -> ListPosition -- ^ Coordinate to delete - -> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition) - miDelete = miDeleteList - - miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition - miAddEmpty _ _ _ = Set.empty - - miLayout :: ListLength - -> Map ListPosition (Either UserEmail UserId, FormResult (Maybe LecturerType)) -- ^ massInput state - -> Map ListPosition Widget -- ^ Cell widgets - -> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons - -> Map (Natural, ListPosition) Widget -- ^ Addition widgets - -> Widget - miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "course/lecturerMassInput/layout") - - miIdent :: Text - miIdent = "lecturers" - - - lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)] + let lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)] lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) (map liftEither . Map.elems) $ massInput MassInput{..} (fslI MsgCourseLecturers & setTooltip MsgCourseLecturerRightsIdentical) @@ -167,6 +123,50 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB unliftEither (Right (lid , lType )) = (Right lid , Just lType) unliftEither (Left (lEmail, mLType)) = (Left lEmail, mLType ) + miAdd :: ListPosition -> Natural -> ListLength -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId)))) + miAdd _ _ _ nudge btn = Just $ \csrf -> do + (addRes, addView) <- mpreq (multiUserInvitationField $ MUILookupAnyUser Nothing) (fslI MsgCourseLecturerEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing + let addRes'' = addRes <&> \newDat oldDat -> if + | existing <- newDat `Set.intersection` Set.fromList (Map.elems oldDat) + , not $ Set.null existing + -> FormFailure [mr MsgCourseLecturerAlreadyAdded] + | otherwise + -> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) $ Map.lookupMax oldDat ..] $ Set.toList newDat + addView' = $(widgetFile "course/lecturerMassInput/add") + return (addRes'', addView') + + miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType) + miCell _ (Right lid) defType nudge = \csrf -> do + (lrwRes,lrwView) <- mreq (selectField optionsFinite) (fslI MsgCourseLecturerType & addName (nudge "lecturer-type")) (join defType) + usr <- liftHandler . runDB $ get404 lid + let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown") + return (Just <$> lrwRes,lrwView') + miCell _ (Left lEmail) defType nudge = \csrf -> do + (lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType + invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning + let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation") + return (lrwRes,lrwView') + + miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape + -> ListPosition -- ^ Coordinate to delete + -> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition) + miDelete = miDeleteList + + miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition + miAddEmpty _ _ _ = Set.empty + + miLayout :: ListLength + -> Map ListPosition (Either UserEmail UserId, FormResult (Maybe LecturerType)) -- ^ massInput state + -> Map ListPosition Widget -- ^ Cell widgets + -> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons + -> Map (Natural, ListPosition) Widget -- ^ Addition widgets + -> Widget + miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "course/lecturerMassInput/layout") + + miIdent :: Text + miIdent = "lecturers" + + (newVisFrom,newRegFrom,newRegTo,newDeRegUntil) <- case template of (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing,Nothing) _allIOtherCases -> do @@ -366,6 +366,7 @@ courseEditHandler miButtonAction mbCourseForm = do let (invites, adds) = partitionEithers $ cfLecturers res insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites + void $ upsertCourseQualifications aid cid $ cfQualis res insert_ $ CourseEdit aid now cid memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId) return insertOkay @@ -414,11 +415,9 @@ courseEditHandler miButtonAction mbCourseForm = do let (invites, adds) = partitionEithers $ cfLecturers res insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites - + void $ upsertCourseQualifications aid cid $ cfQualis res insert_ $ CourseEdit aid now cid - memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId) - addMessageI Success $ MsgCourseEditOk tid ssh csh return True when success $ redirect $ CourseR tid ssh csh CShowR @@ -429,3 +428,30 @@ courseEditHandler miButtonAction mbCourseForm = do { formAction = Just $ SomeRoute actionUrl , formEncoding = formEnctype } + +-- upsertCourseQualifications :: forall m backend . (MonadIO m, PersistStoreWrite backend, PersistQueryRead backend) => UserId -> CourseId -> [(QualificationId, Int)] -> ReaderT backend m Bool +upsertCourseQualifications :: UserId -> CourseId -> [(QualificationId, Int)] -> YesodJobDB UniWorX Bool -- could be generalized +upsertCourseQualifications uid cid qualis = do + let newQualis = Map.fromList qualis + oldQualis <- Map.fromDistinctAscList . fmap (\Entity{entityKey=k, entityVal=CourseQualification{..}} -> (courseQualificationQualification, (k, courseQualificationSortOrder))) + <$> selectList [CourseQualificationCourse ==. cid] [Asc CourseQualificationSortOrder] + -- NOTE: CourseQualification allow the immediate assignment of these qualifications to any enrolled user. Hence SchoolAdmins must not be allowed to assign school-foreign qualifications, see #150 + okSchools <- Set.fromDistinctAscList . fmap (userFunctionSchool . entityVal) + <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin, SchoolLecturer]] [Asc UserFunctionSchool] + foldWithKeyMapM oldQualis $ \qu (k, so_old) -> case Map.lookup qu newQualis of + Just so_new | so_new /= so_old + -> update k [CourseQualificationSortOrder =. so_new] -- existing CourseQualifications may be re-ordered, regardless of school association + Nothing -> delete k -- existing CourseQualifications may be removed, regardless of school association + _ -> return () + res <- foldWithKeyMapM (newQualis Map.\\ oldQualis) $ \qu so -> get qu >>= \case + Just Qualification{qualificationSchool=ssh, qualificationShorthand=qsh} + | Set.member ssh okSchools -> + insert_ CourseQualification{courseQualificationQualification = qu, courseQualificationCourse = cid, courseQualificationSortOrder = so} + $> All True + | otherwise -> do + addMessageI Warning $ MsgCourseEditQualificationFailRights qsh ssh + pure $ All False + _ -> do + addMessageI Warning MsgCourseEditQualificationFail + pure $ All False + pure $ getAll res diff --git a/src/Utils.hs b/src/Utils.hs index 4d6113ba0..f16b0aa14 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -879,6 +879,12 @@ mapFilterM f m = ($ m) . runKleisli $ foldMap (Kleisli . Map.alterF (runMaybeT . _MapUnit :: Iso' (Map k ()) (Set k) _MapUnit = iso Map.keysSet $ Map.fromSet (const ()) +foldMapWithKeyM :: (Monad m, Monoid o) => (k -> a -> m o) -> Map k a -> m o +foldMapWithKeyM act = foldMapM (uncurry act) . Map.toAscList + +foldWithKeyMapM :: (Monad m, Monoid o) => Map k a -> (k -> a -> m o) -> m o +foldWithKeyMapM = flip foldMapWithKeyM + --------------- -- Functions -- --------------- @@ -1305,7 +1311,7 @@ ofoldl1M _ _ = error "otoList of NonNull is empty" foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b foldMapM f = foldrM (\x xs -> (<> xs) <$> f x) mempty -{- left as a remineder: if you need these, use MaybeT instead! +{- left as a reminder: if you need these below, rather use MaybeT instead! -- convenient synonym for `flip foldMapM` continueJust :: (Applicative m, Monoid b) => Maybe a -> (a -> m b) -> m b continueJust (Just x) f = f x From e1419766f3a06f702abad0ea42f6552305504ba0 Mon Sep 17 00:00:00 2001 From: Steffen Date: Thu, 1 Aug 2024 17:09:05 +0200 Subject: [PATCH 12/23] fix(course): fix #149 course cloning proposes associated qualifications This commit required a massInput form, using massInputAccumEditA, which turned out to difficult to use. --- .../courses/courses/de-de-formal.msg | 1 + .../categories/courses/courses/en-eu.msg | 1 + messages/uniworx/misc/de-de-formal.msg | 3 +- messages/uniworx/misc/en-eu.msg | 3 +- src/Handler/Course/Edit.hs | 47 ++++++++++++++++--- .../massinput/courseQualifications/add.hamlet | 9 ++++ .../courseQualifications/form.hamlet | 11 +++++ .../courseQualifications/layout.hamlet | 21 +++++++++ 8 files changed, 88 insertions(+), 8 deletions(-) create mode 100644 templates/widgets/massinput/courseQualifications/add.hamlet create mode 100644 templates/widgets/massinput/courseQualifications/form.hamlet create mode 100644 templates/widgets/massinput/courseQualifications/layout.hamlet diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index e1e39aa94..53cc9d2d9 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -72,6 +72,7 @@ CourseEditOk tid@TermId ssh@SchoolId csh@CourseShorthand: Kursart #{tid}-# CourseEditDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kursart #{tid}-#{ssh}-#{csh} konnte nicht geändert werden: Es gibt bereits einen andere Kursart mit dem selben Kürzel oder Titel in diesem Jahr und Bereich. CourseEditQualificationFail: Eine Qualifikation konnte uas unbekanntem Grund nicht mit diesem Kurs assoziert werden. CourseEditQualificationFailRights qsh@QualificationShorthand ssh@SchoolId: Qualifikation #{qsh} konnte nicht mit diesem Kurs assoziert werden, da Ihre Berechtigungen für Bereich #{ssh} dazu nicht ausreichen. +CourseEditQualificationFailExists: Diese Qualifikation ist bereits assoziert CourseLecturer: Kursverwalter:in MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Einladung zur Kursartteilnahme CourseParticipantInviteHeading courseName@Text: Einladung zum Kursartteilnahmer für #{courseName} diff --git a/messages/uniworx/categories/courses/courses/en-eu.msg b/messages/uniworx/categories/courses/courses/en-eu.msg index 43ea7c45e..ed44433f7 100644 --- a/messages/uniworx/categories/courses/courses/en-eu.msg +++ b/messages/uniworx/categories/courses/courses/en-eu.msg @@ -72,6 +72,7 @@ CourseEditOk tid ssh csh: Successfully edited course type #{tid}-#{ssh}-#{csh} CourseEditDupShort tid ssh csh: Could not edit course type #{tid}-#{ssh}-#{csh}. Another course type with the same shorthand or title already exists for the given year and school. CourseEditQualificationFail: A qualifikation could not be associated with this course for unknown reasons. CourseEditQualificationFailRights qsh ssh: Qualification #{qsh} could not be associated with this course, due to your insufficient rights for department #{ssh}. +CourseEditQualificationFailExists: This qualification is already associated CourseLecturer: Course administrator MailSubjectParticipantInvitation tid ssh csh: [#{tid}-#{ssh}-#{csh}] Invitaion to join the course CourseParticipantInviteHeading courseName: Invitation to enrol for #{courseName} diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index 7fa240fe6..07758a5d6 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -29,4 +29,5 @@ PaginationSize: Einträge pro Seite PaginationPage: Angzeigte Seite PaginationError: Paginierung Parameter dürfen nicht negativ sein -NullDeletes: Zum Löschen NULL eingeben. \ No newline at end of file +NullDeletes: Zum Löschen NULL eingeben. +SortPriority: Sortierungspriorität \ No newline at end of file diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index e7142f4bc..54d519125 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -29,4 +29,5 @@ PaginationSize: Rows per Page PaginationPage: Page to show PaginationError: Pagination parameter must not be negative -NullDeletes: Enter NULL to delete. \ No newline at end of file +NullDeletes: Enter NULL to delete. +SortPriority: Sort order priority \ No newline at end of file diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index bfec8a864..d8519968b 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -85,13 +85,23 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB MsgRenderer mr <- getMsgRenderer uid <- liftHandler requireAuthId - (lecturerSchools, adminSchools, oldSchool) <- liftHandler . runDB $ do - lecturerSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolLecturer]] [] - protoAdminSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]] [] + (userSchools, elegibleQualifications) :: ([SchoolId], OptionList QualificationId) <- liftHandler . runDB $ do + lecturerSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolLecturer]] [] + protoAdminSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]] [] adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools oldSchool <- forM (cfCourseId =<< template) $ fmap courseSchool . getJust - return (lecturerSchools, adminSchools, oldSchool) - let userSchools = nubOrd . maybe id (:) oldSchool $ lecturerSchools ++ adminSchools + let elegibleSchools = Set.fromList $ lecturerSchools ++ adminSchools + userSchools = Set.toList $ maybe id Set.insert oldSchool elegibleSchools + q2opt :: Entity Qualification -> Option QualificationId + q2opt (Entity qid Qualification{..}) = + let qsh = CI.original $ unSchoolKey qualificationSchool + in Option{ optionDisplay = CI.original qualificationName <> " (" <> qsh <> ")" + , optionExternalValue = "(" <> CI.original qualificationShorthand <> "___" <> qsh <> ")" + , optionInternalValue = qid + } + elegibleQualifications <- selectList [QualificationSchool <-. Set.toList elegibleSchools] [Asc QualificationName, Asc QualificationSchool] + return (userSchools, mkOptionList (map q2opt elegibleQualifications)) + (termsField, userTerms) <- liftHandler $ case template of -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin @@ -166,6 +176,31 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB miIdent :: Text miIdent = "lecturers" + qualificationsForm :: Maybe [(QualificationId, Int)] -> AForm Handler [(QualificationId, Int)] -- filter by admin school done later through upsertCourseQualifications + qualificationsForm = massInputAccumEditA miAdd miEdit miButtonAction miLayout miIdent (fslI $ MsgCourseQualifications 9) False + where + miIdent :: Text + miIdent = "qualifications" + + miAdd :: (Text -> Text) -> FieldView UniWorX -> Form ([(QualificationId,Int)] -> FormResult [(QualificationId,Int)]) + miAdd nudge submitView csrf = do + (formRes, formView) <- aCourseQualiForm nudge Nothing csrf + let addRes = formRes <&> \newDat (Set.fromList -> oldDat) -> if + | newDat `Set.member` oldDat -> FormFailure [mr MsgCourseEditQualificationFailExists] + | otherwise -> FormSuccess $ pure newDat + return (addRes, $(widgetFile "widgets/massinput/courseQualifications/add")) + + miEdit :: (Text -> Text) -> (QualificationId, Int) -> Form (QualificationId,Int) + miEdit nudge = aCourseQualiForm nudge . Just + + miLayout :: MassInputLayout ListLength (QualificationId,Int) (QualificationId, Int) + miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/courseQualifications/layout") + + aCourseQualiForm :: (Text -> Text) -> Maybe (QualificationId, Int) -> Form (QualificationId, Int) + aCourseQualiForm nudge mTemplate csrf = do + (cquRes, cquView) <- mpreq (selectField $ pure elegibleQualifications) ("" & addName (nudge "cquali")) (view _1 <$> mTemplate) + (ordRes, ordView) <- mpreq intField ("" & addName (nudge "cqordr")) (view _2 <$> mTemplate) + return ((,) <$> cquRes <*> ordRes, $(widgetFile "widgets/massinput/courseQualifications/form")) (newVisFrom,newRegFrom,newRegTo,newDeRegUntil) <- case template of (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing,Nothing) @@ -212,7 +247,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB & setTooltip MsgCourseDeregisterUntilTip) (deepAlt (cfDeRegUntil <$> template) newDeRegUntil) <* aformSection MsgCourseFormSectionAdministration <*> lecturerForm - <*> pure mempty -- TODO: continue here !!! -- TODO: Filterung nach aktueller Schule, da ansonsten ein Sicherheitleck droht! Siehe #150 + <*> qualificationsForm (cfQualis <$> template) return (result, widget) diff --git a/templates/widgets/massinput/courseQualifications/add.hamlet b/templates/widgets/massinput/courseQualifications/add.hamlet new file mode 100644 index 000000000..6903dab9f --- /dev/null +++ b/templates/widgets/massinput/courseQualifications/add.hamlet @@ -0,0 +1,9 @@ +$newline never + +$# SPDX-FileCopyrightText: 2024 Sarah Vaupel , Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +^{formView} + + ^{fvWidget submitView} diff --git a/templates/widgets/massinput/courseQualifications/form.hamlet b/templates/widgets/massinput/courseQualifications/form.hamlet new file mode 100644 index 000000000..8e286195c --- /dev/null +++ b/templates/widgets/massinput/courseQualifications/form.hamlet @@ -0,0 +1,11 @@ +$newline never + +$# SPDX-FileCopyrightText: 2024 Sarah Vaupel , Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + + + #{csrf} + ^{fvWidget cquView} + + ^{fvWidget ordView} diff --git a/templates/widgets/massinput/courseQualifications/layout.hamlet b/templates/widgets/massinput/courseQualifications/layout.hamlet new file mode 100644 index 000000000..c137daf67 --- /dev/null +++ b/templates/widgets/massinput/courseQualifications/layout.hamlet @@ -0,0 +1,21 @@ +$newline never + +$# SPDX-FileCopyrightText: 2024 Sarah Vaupel , Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + + + + + + $forall coord <- review liveCoords lLength + + ^{cellWdgts ! coord} + + + ^{addWdgts ! (0, 0)} From cfd25348ad3b63ac6bc5031467a3c4ead2e07eed Mon Sep 17 00:00:00 2001 From: Steffen Date: Thu, 1 Aug 2024 17:45:18 +0200 Subject: [PATCH 13/23] fix(course): fix #148 course qualification ordering some refactoring done along the way, fixing a bug in relation to #150 as well --- src/Handler/Course/Edit.hs | 17 +++++------ src/Handler/Tutorial/Users.hs | 49 +++++++++++++----------------- src/Handler/Utils/Course.hs | 10 +++--- src/Handler/Utils/Qualification.hs | 28 +++++++++++++++++ 4 files changed, 61 insertions(+), 43 deletions(-) diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index d8519968b..007276923 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -92,16 +92,8 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB oldSchool <- forM (cfCourseId =<< template) $ fmap courseSchool . getJust let elegibleSchools = Set.fromList $ lecturerSchools ++ adminSchools userSchools = Set.toList $ maybe id Set.insert oldSchool elegibleSchools - q2opt :: Entity Qualification -> Option QualificationId - q2opt (Entity qid Qualification{..}) = - let qsh = CI.original $ unSchoolKey qualificationSchool - in Option{ optionDisplay = CI.original qualificationName <> " (" <> qsh <> ")" - , optionExternalValue = "(" <> CI.original qualificationShorthand <> "___" <> qsh <> ")" - , optionInternalValue = qid - } elegibleQualifications <- selectList [QualificationSchool <-. Set.toList elegibleSchools] [Asc QualificationName, Asc QualificationSchool] - return (userSchools, mkOptionList (map q2opt elegibleQualifications)) - + return (userSchools, qualificationsOptionList elegibleQualifications) (termsField, userTerms) <- liftHandler $ case template of -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin @@ -469,10 +461,15 @@ upsertCourseQualifications :: UserId -> CourseId -> [(QualificationId, Int)] -> upsertCourseQualifications uid cid qualis = do let newQualis = Map.fromList qualis oldQualis <- Map.fromDistinctAscList . fmap (\Entity{entityKey=k, entityVal=CourseQualification{..}} -> (courseQualificationQualification, (k, courseQualificationSortOrder))) - <$> selectList [CourseQualificationCourse ==. cid] [Asc CourseQualificationSortOrder] + <$> selectList [CourseQualificationCourse ==. cid] [Asc CourseQualificationQualification] -- NOTE: CourseQualification allow the immediate assignment of these qualifications to any enrolled user. Hence SchoolAdmins must not be allowed to assign school-foreign qualifications, see #150 okSchools <- Set.fromDistinctAscList . fmap (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin, SchoolLecturer]] [Asc UserFunctionSchool] + {- Some debugging due to an error caused by using fromDistinctAscList with violated precondition: + $logErrorS "CourseQuali" $ "OLD Course Qualifications:" <> tshow oldQualis + $logErrorS "CourseQuali" $ "NEW Course Qualifications:" <> tshow newQualis + $logErrorS "CourseQuali" $ "DIFF Course Qualifications:" <> tshow (newQualis Map.\\ oldQualis) + -} foldWithKeyMapM oldQualis $ \qu (k, so_old) -> case Map.lookup qu newQualis of Just so_new | so_new /= so_old -> update k [CourseQualificationSortOrder =. so_new] -- existing CourseQualifications may be re-ordered, regardless of school association diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 973366f0a..1f068722e 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -50,7 +50,7 @@ data TutorialUserActionData | TutorialUserGrantQualificationData { tuQualification :: QualificationId , tuValidUntil :: Day - } + } | TutorialUserSendMailData | TutorialUserDeregisterData{} deriving (Eq, Ord, Read, Show, Generic) @@ -62,7 +62,7 @@ postTUsersR tid ssh csh tutn = do isAdmin <- hasReadAccessTo AdminR (Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications) <- runDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn + tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn qualifications <- getCourseQualifications cid now <- liftIO getCurrentTime let nowaday = utctDay now @@ -70,7 +70,7 @@ postTUsersR tid ssh csh tutn = do dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> minDur colChoices = mconcat $ catMaybes [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) - , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR + , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR , pure colUserEmail , pure $ colUserMatriclenr isAdmin , pure $ colUserQualifications nowaday @@ -80,34 +80,27 @@ postTUsersR tid ssh csh tutn = do & defaultSortingByName & restrictSorting (\name _ -> none (== name) ["note", "registration", "tutorials", "exams", "submission-group", "state"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information & restrictFilter (\name _ -> none (== name) ["tutorial", "exam", "submission-group", "active", "has-personalised-sheet-files"]) - isInTut q = E.exists $ do + isInTut q = E.exists $ do tutorialParticipant <- E.from $ E.table @TutorialParticipant E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid csvColChoices = flip elem ["name", "matriculation", "email", "qualifications"] - - let - qualOpt :: Entity Qualification -> Handler (Option QualificationId) - qualOpt (Entity qualId qual) = do - cQualId :: CryptoUUIDQualification <- encrypt qualId - return $ Option - { optionDisplay = CI.original $ qualificationName qual - , optionInternalValue = qualId - , optionExternalValue = tshow cQualId - } + + qualOptions = qualificationsOptionList qualifications + let acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData) acts = Map.fromList $ (if null qualifications then mempty else [ ( TutorialUserRenewQualification , TutorialUserRenewQualificationData - <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing + <$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing ) , ( TutorialUserGrantQualification , TutorialUserGrantQualificationData - <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing + <$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing <*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry - ) - ] + ) + ] ) ++ [ ( TutorialUserSendMail , pure TutorialUserSendMailData ) , ( TutorialUserDeregister , pure TutorialUserDeregisterData ) @@ -122,20 +115,20 @@ postTUsersR tid ssh csh tutn = do rcvr <- requireAuth encRcvr <- encrypt $ entityKey rcvr letters <- runDB $ makeCourseCertificates tut Nothing $ toList selectedUsers - let mbAletter = anyone letters - case mbAletter of + let mbAletter = anyone letters + case mbAletter of Nothing -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing -- TODO: better error message - Just aletter -> do + Just aletter -> do now <- liftIO getCurrentTime - apcIdent <- letterApcIdent aletter encRcvr now + apcIdent <- letterApcIdent aletter encRcvr now let fName = letterFileName aletter renderLetters rcvr letters apcIdent >>= \case - Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err + Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err Right pdf -> return $ Just (sendByteStringAsFile fName (LBS.toStrict pdf) now) -- sendResponseByteStringFile "demoPDF.pdf" (LBS.toStrict pdf) - -- let typePDF :: ContentType + -- let typePDF :: ContentType -- typePDF = "application/pdf" - -- sendResponse (typePDF, toContent pdf) + -- sendResponse (typePDF, toContent pdf) (TutorialUserGrantQualificationData{..}, selectedUsers) | tuQualification `Set.member` courseQids -> do -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime @@ -146,7 +139,7 @@ postTUsersR tid ssh csh tutn = do redirect $ CTutorialR tid ssh csh tutn TUsersR (TutorialUserRenewQualificationData{..}, selectedUsers) | tuQualification `Set.member` courseQids -> do - noks <- runDB $ renewValidQualificationUsers tuQualification Nothing Nothing $ Set.toList selectedUsers + noks <- runDB $ renewValidQualificationUsers tuQualification Nothing Nothing $ Set.toList selectedUsers addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks redirect $ CTutorialR tid ssh csh tutn TUsersR (TutorialUserSendMailData{}, selectedUsers) -> do @@ -160,8 +153,8 @@ postTUsersR tid ssh csh tutn = do addMessageI Success $ MsgTutorialUsersDeregistered nrDel redirect $ CTutorialR tid ssh csh tutn TUsersR _other -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing - - case tcontent of + + case tcontent of Just act -> act -- abort and return produced content Nothing -> do tutors <- runDB $ E.select $ do diff --git a/src/Handler/Utils/Course.hs b/src/Handler/Utils/Course.hs index c0d31a0d5..93d0c2692 100644 --- a/src/Handler/Utils/Course.hs +++ b/src/Handler/Utils/Course.hs @@ -109,14 +109,14 @@ showCourseEventRoom uid courseEvent = E.or ] getCourseQualifications :: ( MonadHandler m - , backend ~ SqlBackend - ) + , backend ~ SqlBackend + ) => CourseId -> ReaderT backend m [Entity Qualification] -getCourseQualifications cid = Ex.select $ do +getCourseQualifications cid = Ex.select $ do (qual :& courseQual) <- Ex.from $ Ex.table @Qualification `Ex.innerJoin` Ex.table @CourseQualification - `Ex.on` (\(qual :& courseQual) -> qual E.^. QualificationId E.==. courseQual E.^. CourseQualificationQualification) + `Ex.on` (\(qual :& courseQual) -> qual E.^. QualificationId E.==. courseQual E.^. CourseQualificationQualification) Ex.where_ $ courseQual E.^. CourseQualificationCourse E.==. E.val cid - Ex.orderBy [E.asc $ courseQual E.^. CourseQualificationSortOrder] + Ex.orderBy [E.asc $ courseQual E.^. CourseQualificationSortOrder, E.asc $ qual E.^. QualificationName] pure qual \ No newline at end of file diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index ab135e847..a2074d5da 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -289,3 +289,31 @@ qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationChangeReas E.&&. quserBlockAux True (E.val cutoff) (E.==. (quser E.^. QualificationUserId)) (Just (\qblock -> (qblock E.^. QualificationUserBlockReason) E.==. E.val reason)) return $ quser E.^. QualificationUserUser qualificationUserBlocking qid (E.unValue <$> toUnblock) True mbUnblockTime undo_reason notify + + +----------- +-- Forms -- +----------- + + +qualificationOption :: Entity Qualification -> Option QualificationId +qualificationOption (Entity qid Qualification{..}) = + let qsh = ciOriginal $ unSchoolKey qualificationSchool + in Option{ optionDisplay = ciOriginal qualificationName <> " (" <> qsh <> ")" + , optionExternalValue = "(" <> ciOriginal qualificationShorthand <> "___" <> qsh <> ")" + , optionInternalValue = qid + } + +qualificationsOptionList :: [Entity Qualification] -> OptionList QualificationId +qualificationsOptionList = mkOptionList . map qualificationOption + +{- Should we encrypt the external value or simply rely on uniqueness? +qualOpt :: Entity Qualification -> Handler (Option QualificationId) +qualOpt (Entity qualId qual) = do + cQualId :: CryptoUUIDQualification <- encrypt qualId + return $ Option + { optionDisplay = ciOriginal $ qualificationName qual + , optionInternalValue = qualId + , optionExternalValue = tshow cQualId + } +-} From ec027675525b30198378745ed281f60a42471807 Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 2 Aug 2024 15:40:25 +0200 Subject: [PATCH 14/23] fix(course): fix #150 no longer allow duplicated associated qualifications and orders due to editing existing --- .../courses/courses/de-de-formal.msg | 1 + .../categories/courses/courses/en-eu.msg | 1 + src/Handler/Course/Edit.hs | 20 +++++++++++++------ src/Utils.hs | 20 +++++++++++++++++++ 4 files changed, 36 insertions(+), 6 deletions(-) diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index 53cc9d2d9..e0c589aba 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -73,6 +73,7 @@ CourseEditDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kursart #{tid}-# CourseEditQualificationFail: Eine Qualifikation konnte uas unbekanntem Grund nicht mit diesem Kurs assoziert werden. CourseEditQualificationFailRights qsh@QualificationShorthand ssh@SchoolId: Qualifikation #{qsh} konnte nicht mit diesem Kurs assoziert werden, da Ihre Berechtigungen für Bereich #{ssh} dazu nicht ausreichen. CourseEditQualificationFailExists: Diese Qualifikation ist bereits assoziert +CourseEditQualificationFailOrder: Diese Sortierpriorität existiert bereits CourseLecturer: Kursverwalter:in MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Einladung zur Kursartteilnahme CourseParticipantInviteHeading courseName@Text: Einladung zum Kursartteilnahmer für #{courseName} diff --git a/messages/uniworx/categories/courses/courses/en-eu.msg b/messages/uniworx/categories/courses/courses/en-eu.msg index ed44433f7..9f7835095 100644 --- a/messages/uniworx/categories/courses/courses/en-eu.msg +++ b/messages/uniworx/categories/courses/courses/en-eu.msg @@ -73,6 +73,7 @@ CourseEditDupShort tid ssh csh: Could not edit course type #{tid}-#{ssh}-#{csh}. CourseEditQualificationFail: A qualifikation could not be associated with this course for unknown reasons. CourseEditQualificationFailRights qsh ssh: Qualification #{qsh} could not be associated with this course, due to your insufficient rights for department #{ssh}. CourseEditQualificationFailExists: This qualification is already associated +CourseEditQualificationFailOrder: This sort order priority is used already CourseLecturer: Course administrator MailSubjectParticipantInvitation tid ssh csh: [#{tid}-#{ssh}-#{csh}] Invitaion to join the course CourseParticipantInviteHeading courseName: Invitation to enrol for #{courseName} diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 007276923..6c0c7e851 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -177,12 +177,16 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB miAdd :: (Text -> Text) -> FieldView UniWorX -> Form ([(QualificationId,Int)] -> FormResult [(QualificationId,Int)]) miAdd nudge submitView csrf = do (formRes, formView) <- aCourseQualiForm nudge Nothing csrf - let addRes = formRes <&> \newDat (Set.fromList -> oldDat) -> if - | newDat `Set.member` oldDat -> FormFailure [mr MsgCourseEditQualificationFailExists] - | otherwise -> FormSuccess $ pure newDat + let addRes = formRes <&> \newDat@(newQid,oldOrd) (unzip -> (oldQids,oldOrds)) -> + let qidBad = guardMonoid (newQid `elem` oldQids) [mr MsgCourseEditQualificationFailExists] + ordBad = guardMonoid (oldOrd `elem` oldOrds) [mr MsgCourseEditQualificationFailOrder ] + problems = qidBad ++ ordBad + in if null problems + then FormSuccess $ pure newDat + else FormFailure problems return (addRes, $(widgetFile "widgets/massinput/courseQualifications/add")) - miEdit :: (Text -> Text) -> (QualificationId, Int) -> Form (QualificationId,Int) + miEdit :: (Text -> Text) -> (QualificationId, Int) -> Form (QualificationId, Int) miEdit nudge = aCourseQualiForm nudge . Just miLayout :: MassInputLayout ListLength (QualificationId,Int) (QualificationId, Int) @@ -259,6 +263,10 @@ validateCourse = do unless userAdmin $ do guardValidation MsgCourseUserMustBeLecturer $ anyOf (traverse . _Right . _1) (== uid) cfLecturers + guardValidation MsgCourseEditQualificationFailExists + $ not $ hasDuplicates $ fst <$> cfQualis + guardValidation MsgCourseEditQualificationFailOrder + $ not $ hasDuplicates $ snd <$> cfQualis warnValidation MsgCourseShorthandTooLong $ length (CI.original cfShort) <= 10 @@ -460,10 +468,10 @@ courseEditHandler miButtonAction mbCourseForm = do upsertCourseQualifications :: UserId -> CourseId -> [(QualificationId, Int)] -> YesodJobDB UniWorX Bool -- could be generalized upsertCourseQualifications uid cid qualis = do let newQualis = Map.fromList qualis - oldQualis <- Map.fromDistinctAscList . fmap (\Entity{entityKey=k, entityVal=CourseQualification{..}} -> (courseQualificationQualification, (k, courseQualificationSortOrder))) + oldQualis <- Map.fromList . fmap (\Entity{entityKey=k, entityVal=CourseQualification{..}} -> (courseQualificationQualification, (k, courseQualificationSortOrder))) <$> selectList [CourseQualificationCourse ==. cid] [Asc CourseQualificationQualification] -- NOTE: CourseQualification allow the immediate assignment of these qualifications to any enrolled user. Hence SchoolAdmins must not be allowed to assign school-foreign qualifications, see #150 - okSchools <- Set.fromDistinctAscList . fmap (userFunctionSchool . entityVal) + okSchools <- Set.fromList . fmap (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin, SchoolLecturer]] [Asc UserFunctionSchool] {- Some debugging due to an error caused by using fromDistinctAscList with violated precondition: $logErrorS "CourseQuali" $ "OLD Course Qualifications:" <> tshow oldQualis diff --git a/src/Utils.hs b/src/Utils.hs index f16b0aa14..ac3027992 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1447,6 +1447,26 @@ anyone :: (Foldable t, Alternative f) => t a -> f a anyone = Fold.foldr ((<|>).pure) empty + +-- returns true, if the foldable contains an element twice +hasDuplicates :: (Foldable t, Ord a) => t a -> Bool +hasDuplicates = fst . Fold.foldl' aux (False, mempty) + where + aux r@(True , _) _ = r + aux (False, xs) x + | x `Set.member` xs = (True , xs) + | otherwise = (False, Set.insert x xs) + +{- +-- | like `hasDuplicates` but terminates on infinte lists that contain duplicates +hasDuplicates' :: Ord a => [a] -> Bool +hasDuplicates' = aux mempty + where + aux _ [] = False + aux seen (x:xs) = Set.member x seen || aux (Set.insert x seen) xs +-} + + ------------ -- Writer -- ------------ From d1fa01fcc5125c4adee8849f9c944884926f78ad Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 2 Aug 2024 16:13:09 +0200 Subject: [PATCH 15/23] fix(avs): towards #117 update if current value is Nothing even if oldval == newval MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Damit sollten zumindest die ganzen NULL Fälle bein einem neuen Update erledigt sein. Unklar, wo diese aber herkamen. --- src/Handler/Utils/AvsUpdate.hs | 14 ++--- src/Utils/DB.hs | 95 +++++++++++++++++++++++----------- 2 files changed, 73 insertions(+), 36 deletions(-) diff --git a/src/Handler/Utils/AvsUpdate.hs b/src/Handler/Utils/AvsUpdate.hs index a468d4392..cf0ff1abe 100644 --- a/src/Handler/Utils/AvsUpdate.hs +++ b/src/Handler/Utils/AvsUpdate.hs @@ -67,11 +67,11 @@ instance MkCheckUpdate CU_AvsPersonInfo_User where mkCheckUpdate CU_API_UserFirstName = CheckUpdate UserFirstName _avsInfoFirstName mkCheckUpdate CU_API_UserSurname = CheckUpdate UserSurname _avsInfoLastName mkCheckUpdate CU_API_UserDisplayName = CheckUpdate UserDisplayName _avsInfoDisplayName - mkCheckUpdate CU_API_UserBirthday = CheckUpdate UserBirthday _avsInfoDateOfBirth - mkCheckUpdate CU_API_UserMobile = CheckUpdate UserMobile _avsInfoPersonMobilePhoneNo - mkCheckUpdate CU_API_UserMatrikelnummer = CheckUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just - mkCheckUpdate CU_API_UserCompanyPersonalNumber = CheckUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo; needs special treatment, see ldap_ups abov - mkCheckUpdate CU_API_UserLdapPrimaryKey = CheckUpdate UserLdapPrimaryKey $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just + mkCheckUpdate CU_API_UserBirthday = CheckUpdateMay UserBirthday _avsInfoDateOfBirth + mkCheckUpdate CU_API_UserMobile = CheckUpdateMay UserMobile _avsInfoPersonMobilePhoneNo + mkCheckUpdate CU_API_UserMatrikelnummer = CheckUpdateMay UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just + mkCheckUpdate CU_API_UserCompanyPersonalNumber = CheckUpdateMay UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo; needs special treatment, see ldap_ups abov + mkCheckUpdate CU_API_UserLdapPrimaryKey = CheckUpdateMay UserLdapPrimaryKey $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- mkCheckUpdate CU_API_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsInfoPersonEMail . _Just . from _CI -- Maybe im AvsInfo, aber nicht im User, daher Opt data CU_AvsDataContcat_User @@ -82,7 +82,7 @@ data CU_AvsDataContcat_User instance MkCheckUpdate CU_AvsDataContcat_User where type MCU_Rec CU_AvsDataContcat_User = User type MCU_Raw CU_AvsDataContcat_User = AvsDataContact - mkCheckUpdate CU_ADC_UserPostAddress = CheckUpdate UserPostAddress _avsContactPrimaryPostAddress + mkCheckUpdate CU_ADC_UserPostAddress = CheckUpdateMay UserPostAddress _avsContactPrimaryPostAddress mkCheckUpdate CU_ADC_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsContactPrimaryEmail . _Just . from _CI data CU_AvsFirmInfo_User @@ -94,7 +94,7 @@ data CU_AvsFirmInfo_User instance MkCheckUpdate CU_AvsFirmInfo_User where type MCU_Rec CU_AvsFirmInfo_User = User type MCU_Raw CU_AvsFirmInfo_User = AvsFirmInfo - mkCheckUpdate CU_AFI_UserPostAddress = CheckUpdate UserPostAddress _avsFirmPostAddress + mkCheckUpdate CU_AFI_UserPostAddress = CheckUpdateMay UserPostAddress _avsFirmPostAddress -- mkCheckUpdate CU_AFI_UserEmail = CheckUpdateOpt UserEmail $ _avsFirmEMailSuperior . _Just . from _CI -- in rare cases, firm superior email is used as fallback here; but UserEmail must be unique! -- mkCheckUpdate CU_AFI_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsFirmPrimaryEmail . _Just . from _CI -- Maybe im AvsInfo, aber nicht im User, daher Opt diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 3470b2427..7cf9dc8a9 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -43,14 +43,14 @@ getField = view . fieldLensVal -- | Obtain a lens from an EntityField fieldLensVal :: PersistEntity record => EntityField record typ -> Lens' record typ fieldLensVal f = entityLens . fieldLens f - where + where entityLens :: Lens' record (Entity record) entityLens = lens getVal setVal getVal :: record -> Entity record getVal = Entity (error "fieldLensVal unexpectectly required an entity key") -- this is safe, since the lens is only used locally setVal :: record -> Entity record -> record setVal _ = entityVal - + emptyOrIn :: PersistField typ => E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool) @@ -115,16 +115,16 @@ existsKey404 = bool notFound (return ()) <=< existsKey -- | given filter criteria like `selectList` this function returns Just if and only if there is precisely one result -- getByPeseudoUnique -getByFilter :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m) +getByFilter :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m) => [Filter record] -> ReaderT backend m (Maybe (Entity record)) -getByFilter crit = - selectList crit [LimitTo 2] <&> \case +getByFilter crit = + selectList crit [LimitTo 2] <&> \case [singleEntity] -> Just singleEntity _ -> Nothing -- not existing or not unique -getKeyByFilter :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m) +getKeyByFilter :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m) => [Filter record] -> ReaderT backend m (Maybe (Key record)) -getKeyByFilter crit = +getKeyByFilter crit = selectKeysList crit [LimitTo 2] <&> \case [singleKey] -> Just singleKey _ -> Nothing -- not existing or not unique @@ -142,9 +142,9 @@ updateGetEntity k = fmap (Entity k) . updateGet k -- | insert or replace a record based on a single uniqueness constraint -- this function was meant to be supplied with the uniqueness constraint, but it would be unsafe if the uniqueness constraint would not match the supplied record -replaceBy :: (PersistUniqueWrite backend, MonadIO m, OnlyOneUniqueKey record, PersistEntityBackend record ~ BaseBackend backend) +replaceBy :: (PersistUniqueWrite backend, MonadIO m, OnlyOneUniqueKey record, PersistEntityBackend record ~ BaseBackend backend) => record -> ReaderT backend m () -replaceBy r = do +replaceBy r = do u <- onlyUnique r deleteBy u insert_ r @@ -189,15 +189,15 @@ replaceEntity Entity{..} = replace entityKey entityVal -- * Unique denotes old record -- * Changes to fields involved in uniqueness work, but may throw an error if updated record already exists --- | Safe version of upsertBy which does nothing if the new or updated record would violate a uniqueness constraint +-- | Safe version of upsertBy which does nothing if the new or updated record would violate a uniqueness constraint upsertBySafe :: ( MonadIO m , PersistEntity record , PersistUniqueWrite backend , PersistEntityBackend record ~ BaseBackend backend - ) + ) => Unique record -> record -> (record -> record) -> ReaderT backend m (Maybe (Key record)) upsertBySafe uniq newr upd = maybeM (insertUnique newr) do_upd (getBy uniq) - where + where do_upd Entity{entityKey = oid, entityVal = oldr} = do delete oid insertUnique $ upd oldr @@ -263,13 +263,13 @@ instance WithRunDB backend m (ReaderT backend m) where useRunDB = id -- Could be used at Handler.Admin.postAdminProblemsR, but not yet elsewhere, thus inlined for now, as it may be too special: --- updateWithMessage +-- updateWithMessage -- :: ( YesodPersist site, PersistEntity val, BackendCompatible SqlBackend (YesodPersistBackend site), PersistEntityBackend val ~ SqlBackend -- , Num a, Ord a, RenderMessage site msg, RedirectUrl site (url,[(Text,Text)])) -- => url -- where to redirect, if changes were mage -- -> [Filter val] -- update filter -- -> [Update val] -- actual update --- -> a -- expected updates +-- -> a -- expected updates -- -> (a -> msg) -- message to add with number of actual changes -- -> HandlerFor site () -- updateWithMessage route flt upd no_req msg = do @@ -290,7 +290,7 @@ instance WithRunDB backend m (ReaderT backend m) where -- DBRunner site -- -> DBRunner' (YesodPersistBackend site) (HandlerFor site) -- fromDBRunner' DBRunner{..} = DBRunner' runDBRunner - + -- toDBRunner :: forall site. -- DBRunner' (YesodPersistBackend site) (HandlerFor site) -- -> DBRunner site @@ -332,27 +332,34 @@ instance WithRunDB backend m (ReaderT backend m) where -- void . atomically $ tryPutTMVar runnerTMVar runner -- return runner -- getRunnerNoLock = maybe getRunner return =<< atomically (tryReadTMVar runnerTMVar) - + -- runCachedDBRunnerUsing act getRunnerNoLock -- A datatype for a specific heterogeneous list to compute DB updates, consisting of a persistent record field and a fitting lens -data CheckUpdate record iraw = - forall typ. (Eq typ, PersistField typ) => +data CheckUpdate record iraw = + forall typ. (Eq typ, PersistField typ) => CheckUpdate (EntityField record typ) (Getting typ iraw typ) -- A persistent record field and fitting getting (also use for typ ~ Maybe typ') - | forall typ. (Eq typ, PersistField typ) => + | forall typ. (Eq typ, PersistField typ) => + CheckUpdateMay (EntityField record (Maybe typ)) (Getting (Maybe typ) iraw (Maybe typ)) -- Special case, when `typ` is optional everywhere, forces update of Nothing to Just values + | forall typ. (Eq typ, PersistField typ) => CheckUpdateOpt (EntityField record typ) (Getting (Monoid.First typ) iraw typ) -- Special case, when `typ` is optional for the lens, but not optional in DB. -- deriving instance Lift (CheckUpdate record iraw) -- not possible, seee Handler.Utils.AvsUpdate for a workaround -- instance Lift (CheckUpdate record iraw) where -- lift = $(makeLift ''CheckUpdate) +-- | checks if an update would be performed, if a new different value would be presented. Should agree with `mkUpdate` familiy of functions mayUpdate :: PersistEntity record => record -> Maybe iraw -> CheckUpdate record iraw -> Bool mayUpdate ent (Just old) (CheckUpdate up l) | let oldval = old ^. l , let entval = ent ^. fieldLensVal up - = oldval == entval + = oldval == entval +mayUpdate ent (Just old) (CheckUpdateMay up l) + | let oldval = old ^. l + , let entval = ent ^. fieldLensVal up + = isNothing entval || oldval == entval mayUpdate ent (Just old) (CheckUpdateOpt up l) | Just oldval <- old ^? l , let entval = ent ^. fieldLensVal up @@ -369,6 +376,12 @@ mkUpdate ent new (Just old) (CheckUpdate up l) , newval /= entval , oldval == entval = Just (up =. newval) +mkUpdate ent new (Just old) (CheckUpdateMay up l) + | let newval = new ^. l + , let oldval = old ^. l + , let entval = ent ^. fieldLensVal up + , (isNothing entval && isJust newval) || (newval /= entval && oldval == entval) + = Just (up =. newval) mkUpdate ent new (Just old) (CheckUpdateOpt up l) | Just newval <- new ^? l , Just oldval <- old ^? l @@ -383,12 +396,18 @@ mkUpdate' :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate mkUpdate' ent new Nothing = mkUpdateDirect ent new mkUpdate' ent new just = mkUpdate ent new just +-- | Like `mkUpdate` but performs the update without comparison to a previous older value, whenever current entity value and new value are different mkUpdateDirect :: PersistEntity record => record -> iraw -> CheckUpdate record iraw -> Maybe (Update record) mkUpdateDirect ent new (CheckUpdate up l) | let newval = new ^. l , let entval = ent ^. fieldLensVal up , newval /= entval = Just (up =. newval) +mkUpdateDirect ent new (CheckUpdateMay up l) + | let newval = new ^. l + , let entval = ent ^. fieldLensVal up + , newval /= entval + = Just (up =. newval) mkUpdateDirect ent new (CheckUpdateOpt up l) | Just newval <- new ^? l , let entval = ent ^. fieldLensVal up @@ -398,33 +417,43 @@ mkUpdateDirect _ _ _ = Nothing -- | Unconditionally update a record through CheckUpdate updateRecord :: PersistEntity record => record -> iraw -> CheckUpdate record iraw -> record -updateRecord ent new (CheckUpdate up l) = +updateRecord ent new (CheckUpdate up l) = + let newval = new ^. l + lensRec = fieldLensVal up + in ent & lensRec .~ newval +updateRecord ent new (CheckUpdateMay up l) = let newval = new ^. l lensRec = fieldLensVal up in ent & lensRec .~ newval updateRecord ent new (CheckUpdateOpt up l) - | Just newval <- new ^? l + | Just newval <- new ^? l = ent & fieldLensVal up .~ newval | otherwise - = ent + = ent -- | like mkUpdate' but only returns the update if the new value would be unique -- mkUpdateCheckUnique' :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate record iraw -> DB (Maybe (Update record)) -mkUpdateCheckUnique' :: (MonadIO m, PersistQueryRead backend, PersistEntity record, PersistEntityBackend record ~ BaseBackend backend) +mkUpdateCheckUnique' :: (MonadIO m, PersistQueryRead backend, PersistEntity record, PersistEntityBackend record ~ BaseBackend backend) => record -> a -> Maybe a -> CheckUpdate record a -> ReaderT backend m (Maybe (Update record)) - mkUpdateCheckUnique' ent new Nothing (CheckUpdate up l) | let newval = new ^. l , let entval = ent ^. fieldLensVal up , newval /= entval - = do + = do + newval_exists <- exists [up ==. newval] + return $ toMaybe (not newval_exists) (up =. newval) +mkUpdateCheckUnique' ent new Nothing (CheckUpdateMay up l) + | let newval = new ^. l + , let entval = ent ^. fieldLensVal up + , newval /= entval + = do newval_exists <- exists [up ==. newval] return $ toMaybe (not newval_exists) (up =. newval) mkUpdateCheckUnique' ent new Nothing (CheckUpdateOpt up l) | Just newval <- new ^? l , let entval = ent ^. fieldLensVal up , newval /= entval - = do + = do newval_exists <- exists [up ==. newval] return $ toMaybe (not newval_exists) (up =. newval) mkUpdateCheckUnique' ent new (Just old) (CheckUpdate up l) @@ -433,7 +462,15 @@ mkUpdateCheckUnique' ent new (Just old) (CheckUpdate up l) , let entval = ent ^. fieldLensVal up , newval /= entval , oldval == entval - = do + = do + newval_exists <- exists [up ==. newval] + return $ toMaybe (not newval_exists) (up =. newval) +mkUpdateCheckUnique' ent new (Just old) (CheckUpdateMay up l) + | let newval = new ^. l + , let oldval = old ^. l + , let entval = ent ^. fieldLensVal up + , (isNothing entval && isJust newval) || (newval /= entval && oldval == entval) + = do newval_exists <- exists [up ==. newval] return $ toMaybe (not newval_exists) (up =. newval) mkUpdateCheckUnique' ent new (Just old) (CheckUpdateOpt up l) @@ -442,7 +479,7 @@ mkUpdateCheckUnique' ent new (Just old) (CheckUpdateOpt up l) , let entval = ent ^. fieldLensVal up , newval /= entval , oldval == entval - = do + = do newval_exists <- exists [up ==. newval] return $ toMaybe (not newval_exists) (up =. newval) mkUpdateCheckUnique' _ _ _ _ = return Nothing From 4df8bd2fa5e2c785aefbed105eadf01cd920a814 Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 2 Aug 2024 18:28:16 +0200 Subject: [PATCH 16/23] chore(mail): stub towards #171 new routes /mail and /mail/show/UUID to eventually display all sent emails by the system --- .../uniworx/categories/print/de-de-formal.msg | 4 +- messages/uniworx/categories/print/en-eu.msg | 4 +- .../utils/navigation/menu/de-de-formal.msg | 3 + .../uniworx/utils/navigation/menu/en-eu.msg | 3 + routes | 3 + src/Application.hs | 13 +- src/CryptoID.hs | 1 + src/Foundation/Navigation.hs | 7 +- src/Handler/Course/Edit.hs | 2 +- src/Handler/LMS.hs | 2 +- src/Handler/MailCenter.hs | 144 ++++++++++++++++++ src/Handler/PrintCenter.hs | 10 +- templates/mail-center.hamlet | 9 ++ 13 files changed, 188 insertions(+), 17 deletions(-) create mode 100644 src/Handler/MailCenter.hs create mode 100644 templates/mail-center.hamlet diff --git a/messages/uniworx/categories/print/de-de-formal.msg b/messages/uniworx/categories/print/de-de-formal.msg index d2c275335..3cc18f0ee 100644 --- a/messages/uniworx/categories/print/de-de-formal.msg +++ b/messages/uniworx/categories/print/de-de-formal.msg @@ -26,4 +26,6 @@ PrintPDF !ident-ok: PDF PrintManualRenewal: Vorfeldführerschein Renewal-Brief testweise versenden PrintLmsUser: E‑Learning Id PrintJobs: Druckaufräge -PrintLetterType: Brieftypkürzel \ No newline at end of file +PrintLetterType: Brieftypkürzel + +MCActDummy: Platzhalter \ No newline at end of file diff --git a/messages/uniworx/categories/print/en-eu.msg b/messages/uniworx/categories/print/en-eu.msg index dbe776ebe..2b491983e 100644 --- a/messages/uniworx/categories/print/en-eu.msg +++ b/messages/uniworx/categories/print/en-eu.msg @@ -26,4 +26,6 @@ PrintPDF: PDF PrintManualRenewal: Manual sending of an apron driver's licence renewal letter PrintLmsUser: E‑learning id PrintJobs: Print jobs -PrintLetterType: Letter type shorthand \ No newline at end of file +PrintLetterType: Letter type shorthand + +MCActDummy: Placeholder \ No newline at end of file diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index eab4f204e..8979eacc5 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -149,6 +149,9 @@ MenuPrintDownload: Brief herunterladen MenuPrintLog: LPR Schnittstelle MenuPrintAck: Druckbestätigung +MenuMailCenter: E‑Mails +MenuMailShow: Anzeige + MenuApiDocs: API-Dokumentation (Englisch) MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger) diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 526c6d871..09399e8bf 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -149,6 +149,9 @@ MenuPrintDownload: Download Letter MenuPrintLog: LPR Interface MenuPrintAck: Acknowledge Printing +MenuMailCenter: Email +MenuMailShow: Display + MenuApiDocs: API documentation MenuSwagger: OpenAPI 2.0 (Swagger) diff --git a/routes b/routes index c484282ac..762594efd 100644 --- a/routes +++ b/routes @@ -84,6 +84,9 @@ /print/download/#CryptoUUIDPrintJob PrintDownloadR GET !system-printer /print/log PrintLogR GET !system-printer +/mail MailCenterR GET POST +/mail/show/#CryptoUUIDSentMail MailShowR GET + /health HealthR GET !free /health/interface/+Texts HealthInterfaceR GET !free /instance InstanceR GET !free diff --git a/src/Application.hs b/src/Application.hs index e7dc88b68..30f6d9469 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -158,6 +158,7 @@ import Handler.Qualification import Handler.LMS import Handler.SAP import Handler.PrintCenter +import Handler.MailCenter import Handler.ApiDocs import Handler.Swagger import Handler.Firm @@ -352,15 +353,15 @@ makeFoundation appSettings''@AppSettings{..} = do handleIf isBucketExists (const $ return ()) $ Minio.makeBucket appUploadTmpBucket Nothing return conn - appAvsQuery <- case appAvsConf of + appAvsQuery <- case appAvsConf of Nothing -> do $logErrorS "avsPrepare" "appAvsConfig is empty, i.e. invalid AVS configuration settings." return Nothing - -- error "AvsConfig is empty, i.e. invalid AVS configuration settings." - - Just avsConf -> do + -- error "AvsConfig is empty, i.e. invalid AVS configuration settings." + + Just avsConf -> do manager <- newManagerSettings $ mkManagerSettings (def { settingDisableCertificateValidation = True }) Nothing - let avsServer = BaseUrl + let avsServer = BaseUrl { baseUrlScheme = Https , baseUrlHost = avsHost avsConf , baseUrlPort = avsPort avsConf @@ -657,7 +658,7 @@ appMain = runResourceT $ do notifyWatchdog = forever' Nothing $ \pResults -> do let delay = floor $ wInterval % 4 d <- liftIO $ newDelay delay - + $logDebugS "Notify" $ "Waiting up to " <> tshow delay <> "µs..." mResults <- atomically $ asum [ pResults <$ waitDelay d diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 9d724bbee..9c4fdfaa1 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -59,6 +59,7 @@ decCryptoIDs [ ''SubmissionId , ''MaterialFileId , ''PrintJobId , ''QualificationId + , ''SentMailId ] decCryptoIDKeySize diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index b485a7018..af634108c 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -136,6 +136,9 @@ breadcrumb PrintAckR{} = i18nCrumb MsgMenuPrintSend $ Just PrintCenter breadcrumb PrintAckDirectR{}= i18nCrumb MsgMenuPrintAck $ Just PrintCenterR breadcrumb PrintLogR = i18nCrumb MsgMenuPrintLog $ Just PrintCenterR +breadcrumb MailCenterR = i18nCrumb MsgMenuMailCenter Nothing +breadcrumb MailShowR{} = i18nCrumb MsgMenuMailShow $ Just MailCenterR + breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR breadcrumb (SchoolR ssh sRoute) = case sRoute of SchoolEditR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do @@ -1225,7 +1228,7 @@ pageActions (AdminUserR cID) = return , NavPageActionPrimary { navLink = defNavLink MsgMenuUserEdit $ ForProfileR cID , navChildren = [] - } + } , NavPageActionPrimary { navLink = defNavLinkModal MsgUserHijack $ AdminHijackUserR cID , navChildren = [] @@ -1461,7 +1464,7 @@ pageActions (ForProfileDataR cID) = return [ NavPageActionPrimary { navLink = defNavLink MsgAdminUserHeading $ AdminUserR cID , navChildren = [] - } + } ] pageActions TermShowR = do participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 6c0c7e851..c1df2fd59 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros -- -- SPDX-License-Identifier: AGPL-3.0-or-later diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index b4e8f0b83..27fd41991 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later diff --git a/src/Handler/MailCenter.hs b/src/Handler/MailCenter.hs new file mode 100644 index 000000000..ce4b2b06e --- /dev/null +++ b/src/Handler/MailCenter.hs @@ -0,0 +1,144 @@ +-- SPDX-FileCopyrightText: 2024 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Handler.MailCenter + ( getMailCenterR, postMailCenterR + , getMailShowR + ) where + +import Import + +import qualified Data.Set as Set +import qualified Data.Map as Map +-- import qualified Data.Aeson as Aeson +-- import qualified Data.Text as Text + +-- import Database.Persist.Sql (updateWhereCount) +-- import Database.Esqueleto.Experimental ((:&)(..)) +import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy +import qualified Database.Esqueleto.Experimental as E +import qualified Database.Esqueleto.Utils as E +import Database.Esqueleto.Utils.TH + +-- import Utils.Print + +import Handler.Utils +-- import Handler.Utils.Csv +-- import qualified Data.Csv as Csv +-- import qualified Data.CaseInsensitive as CI + +-- import Jobs.Queue + + +-- avoids repetition of local definitions +single :: (k,a) -> Map k a +single = uncurry Map.singleton + + +data MCTableAction = MCActDummy -- just a dummy, since we don't now yet which actions we will be needing + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + +instance Universe MCTableAction +instance Finite MCTableAction +nullaryPathPiece ''MCTableAction $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''MCTableAction id + +data MCTableActionData = MCActDummyData + deriving (Eq, Ord, Read, Show, Generic) + + +type MCTableExpr = + ( E.SqlExpr (Entity SentMail) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) + ) + +queryMail :: MCTableExpr -> E.SqlExpr (Entity SentMail) +queryMail = $(sqlLOJproj 2 1) + +{- +queryRecipient :: MCTableExpr -> E.SqlExpr (Maybe (Entity User)) +queryRecipient = $(sqlLOJproj 2 2) +-} + +type MCTableData = DBRow (Entity SentMail, Maybe (Entity User)) + +resultMail :: Lens' MCTableData (Entity SentMail) +resultMail = _dbrOutput . _1 + +{- +resultRecipient :: Traversal' MCTableData (Entity User) +resultRecipient = _dbrOutput . _2 . _Just +-} + +mkMCTable :: DB (FormResult (MCTableActionData, Set SentMailId), Widget) +mkMCTable = do + let + dbtSQLQuery :: MCTableExpr -> E.SqlQuery (E.SqlExpr (Entity SentMail), E.SqlExpr (Maybe (Entity User))) + dbtSQLQuery (mail `E.LeftOuterJoin` recipient) = do + EL.on $ mail E.^. SentMailRecipient E.==. recipient E.?. UserId + return (mail, recipient) + dbtRowKey = queryMail >>> (E.^. SentMailId) + dbtProj = dbtProjId + dbtColonnade = mconcat + [ dbSelect (applying _2) id (return . view (resultMail . _entityKey)) + , sortable (Just "sent") (i18nCell MsgPrintJobCreated) $ \( view $ resultMail . _entityVal . _sentMailSentAt -> t) -> dateTimeCell t -- TODO: msg + ] + dbtSorting = mconcat + [ single ("sent" , SortColumn $ queryMail >>> (E.^. SentMailSentAt)) + ] + dbtFilter = mconcat + [ single ("sent" , FilterColumn . E.mkDayFilter $ views (to queryMail) (E.^. SentMailSentAt)) + ] + dbtFilterUI mPrev = mconcat + [ prismAForm (singletonFilter "sent" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) -- TODO: msg + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout} + dbtIdent :: Text + dbtIdent = "sent-mail" + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + dbtParams = DBParamsForm + { dbParamsFormMethod = POST + , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute + , dbParamsFormAttrs = [] + , dbParamsFormSubmit = FormSubmit + , dbParamsFormAdditional + = let acts :: Map MCTableAction (AForm Handler MCTableActionData) + acts = mconcat + [ singletonMap MCActDummy $ pure MCActDummyData + ] + in renderAForm FormStandard + $ (, mempty) . First . Just + <$> multiActionA acts (fslI MsgTableAction) Nothing + , dbParamsFormEvaluate = liftHandler . runFormPost + , dbParamsFormResult = id + , dbParamsFormIdent = def + } + postprocess :: FormResult (First MCTableActionData, DBFormResult SentMailId Bool MCTableData) + -> FormResult ( MCTableActionData, Set SentMailId) + postprocess inp = do + (First (Just act), jobMap) <- inp + let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap + return (act, jobSet) + psValidator = def & defaultSorting [SortDescBy "sent"] + over _1 postprocess <$> dbTable psValidator DBTable{..} + +getMailCenterR, postMailCenterR :: Handler Html +getMailCenterR = postMailCenterR +postMailCenterR = do + (mcRes, mcTable) <- runDB mkMCTable + formResult mcRes $ \case + (MCActDummyData, Set.toList -> _smIds) -> do + addMessageI Success MsgBoolIrrelevant + reloadKeepGetParams MailCenterR + siteLayoutMsg MsgMenuMailCenter $ do + setTitleI MsgMenuMailCenter + $(widgetFile "mail-center") + + +getMailShowR :: CryptoUUIDSentMail -> Handler Html +getMailShowR _ = error "TODO: STUB" diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 99e2433b4..559fb6188 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -20,9 +20,9 @@ import qualified Data.Set as Set import qualified Data.Map as Map import Database.Persist.Sql (updateWhereCount) -import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma -import qualified Database.Esqueleto.Legacy as E -import qualified Database.Esqueleto.Utils as E +import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma +import qualified Database.Esqueleto.Legacy as E -- needed for dbTable using Esqueleto.Legacy +import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH import Utils.Print @@ -133,10 +133,10 @@ instance Finite PJTableAction nullaryPathPiece ''PJTableAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''PJTableAction id --- Not yet needed, since there is no additional data for now: data PJTableActionData = PJActAcknowledgeData | PJActReprintData { ignoreReroute :: Maybe Bool } deriving (Eq, Ord, Read, Show, Generic) + type PJTableExpr = ( E.SqlExpr (Entity PrintJob) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) diff --git a/templates/mail-center.hamlet b/templates/mail-center.hamlet new file mode 100644 index 000000000..de17a2a38 --- /dev/null +++ b/templates/mail-center.hamlet @@ -0,0 +1,9 @@ +$newline never + +$# SPDX-FileCopyrightText: 2024 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +
    +

    + ^{mcTable} From 21d32fd4cf204f8f135865b2ee04ec6b86ac5590 Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 5 Aug 2024 18:15:44 +0200 Subject: [PATCH 17/23] chore(mail): mail display towards #171 --- .../utils/navigation/menu/de-de-formal.msg | 3 +- .../uniworx/utils/navigation/menu/en-eu.msg | 3 +- routes | 3 +- src/Database/Esqueleto/Utils.hs | 23 +-- src/Foundation/Navigation.hs | 22 ++- src/Handler/MailCenter.hs | 139 +++++++++++++++++- src/Mail.hs | 45 +++--- src/Model/Types/Mail.hs | 5 +- src/Network/Mail/Mime/Instances.hs | 5 +- src/Utils/Lens.hs | 7 +- 10 files changed, 206 insertions(+), 49 deletions(-) diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 8979eacc5..9eae9e201 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -150,7 +150,8 @@ MenuPrintLog: LPR Schnittstelle MenuPrintAck: Druckbestätigung MenuMailCenter: E‑Mails -MenuMailShow: Anzeige +MenuMailHtml !ident-ok: Html +MenuMailPlain !ident-ok: Text MenuApiDocs: API-Dokumentation (Englisch) MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger) diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 09399e8bf..79438c351 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -150,7 +150,8 @@ MenuPrintLog: LPR Interface MenuPrintAck: Acknowledge Printing MenuMailCenter: Email -MenuMailShow: Display +MenuMailHtml: Html +MenuMailPlain: Text MenuApiDocs: API documentation MenuSwagger: OpenAPI 2.0 (Swagger) diff --git a/routes b/routes index 762594efd..10627db43 100644 --- a/routes +++ b/routes @@ -85,7 +85,8 @@ /print/log PrintLogR GET !system-printer /mail MailCenterR GET POST -/mail/show/#CryptoUUIDSentMail MailShowR GET +/mail/html/#CryptoUUIDSentMail MailHtmlR GET +/mail/plain/#CryptoUUIDSentMail MailPlainR GET /health HealthR GET !free /health/interface/+Texts HealthInterfaceR GET !free diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 9dfd9eec9..1ce50b833 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -48,6 +48,7 @@ module Database.Esqueleto.Utils , subSelectCountDistinct , selectCountRows, selectCountDistinct , selectMaybe + , str2text , num2text --, text2num , day, day', dayMaybe, interval, diffDays, diffTimes , exprLift @@ -328,7 +329,7 @@ mkExactFilterLastWith :: (PersistField b) -> Last a -- ^ needle -> E.SqlExpr (E.Value Bool) mkExactFilterLastWith cast lenslike row criterias - | Last (Just crit) <- criterias = lenslike row E.==. E.val (cast crit) + | Last (Just crit) <- criterias = lenslike row E.==. E.val (cast crit) | otherwise = true -- | like `mkExactFilterLast` but deals with Nothing being a filter criterion as well @@ -409,7 +410,7 @@ mkContainsFilterWithCommaPlus cast lenslike row (foldMap commaSeparatedText -> c | Set.null compulsories = cond_optional | Set.null alternatives = cond_compulsory | otherwise = cond_compulsory E.&&. cond_optional - where + where (Set.mapMonotonic (Text.stripStart . Text.drop 1) -> compulsories, alternatives) = Set.partition (Text.isPrefixOf "+") criterias cond_compulsory = all (hasInfix (lenslike row) . E.val . cast) compulsories cond_optional = any (hasInfix (lenslike row) . E.val . cast) alternatives @@ -516,7 +517,7 @@ selectExists query = do _other -> error "SELECT EXISTS ... returned zero or more than one rows" selectNotExists = fmap not . selectExists -filterExists :: (MonadIO m, PersistEntity val, MonoFoldable mono, PersistField (Element mono)) +filterExists :: (MonadIO m, PersistEntity val, MonoFoldable mono, PersistField (Element mono)) => EntityField val (Element mono) -> mono -> E.SqlReadT m [Element mono] filterExists prj vs = fmap (fmap Ex.unValue) <$> Ex.select $ do ent <- Ex.from Ex.table @@ -655,7 +656,7 @@ infixl 8 ->. infixl 8 ->>. -(->>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value Text) +(->>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value Text) (->>.) expr t = E.unsafeSqlBinOp "->>" expr $ E.val t infixl 8 ->>>. @@ -682,7 +683,7 @@ unKey = E.veryUnsafeCoerceSqlExprValue -- | distinct version of `Database.Esqueleto.subSelectCount` subSelectCountDistinct :: (Num a, PersistField a) => Ex.SqlQuery (Ex.SqlExpr (Ex.Value typ)) -> Ex.SqlExpr (Ex.Value a) subSelectCountDistinct query = Ex.subSelectUnsafe (Ex.countDistinct <$> query) - + -- PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a) -- countDistinct :: Num a => SqlExpr (Value typ) -> SqlExpr (Value a) @@ -707,6 +708,10 @@ selectCountDistinct q = do selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r) selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1) +-- | convert something that is like a text to text +str2text :: E.SqlString a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Text) +str2text = E.unsafeSqlCastAs "text" + -- | cast numeric type to text, which is safe and allows for an inefficient but safe comparison of numbers stored as text and numbers num2text :: Num n => E.SqlExpr (E.Value n) -> E.SqlExpr (E.Value Text) num2text = E.unsafeSqlCastAs "text" @@ -726,9 +731,9 @@ dayMaybe :: E.SqlExpr (E.Value (Maybe UTCTime)) -> E.SqlExpr (E.Value (Maybe Day dayMaybe = E.unsafeSqlCastAs "date" interval :: CalendarDiffDays -> E.SqlExpr (E.Value Day) -- E.+=. requires both types to be the same, so we use Day --- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example +-- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text.Builder.fromString . iso8601Show - where + where singleQuote = Text.Builder.singleton '\'' wrapSqlString b = singleQuote <> b <> singleQuote @@ -775,12 +780,12 @@ instance (PersistField a1, PersistField a2, PersistField b, Finite a1, Finite a2 -- Suspected to cause trouble. Needs more testing! --- truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record) +-- truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record) -- => record -> ReaderT backend m () -- truncateTable tbl = E.rawExecute ("TRUNCATE TABLE " <> P.tableName tbl <> " RESTART IDENTITY") [] truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record) -- TODO: test this code => proxy record -> ReaderT backend m () -truncateTable tbl = +truncateTable tbl = let tblName :: Text = P.unEntityNameDB $ P.entityDB $ P.entityDef tbl in E.rawExecute ("TRUNCATE TABLE " <> tblName <> " RESTART IDENTITY") [] \ No newline at end of file diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index af634108c..773b2c165 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -137,7 +137,8 @@ breadcrumb PrintAckDirectR{}= i18nCrumb MsgMenuPrintAck $ Just PrintCenter breadcrumb PrintLogR = i18nCrumb MsgMenuPrintLog $ Just PrintCenterR breadcrumb MailCenterR = i18nCrumb MsgMenuMailCenter Nothing -breadcrumb MailShowR{} = i18nCrumb MsgMenuMailShow $ Just MailCenterR +breadcrumb MailHtmlR{} = i18nCrumb MsgMenuMailHtml $ Just MailCenterR +breadcrumb MailPlainR{} = i18nCrumb MsgMenuMailPlain $ Just MailCenterR breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR breadcrumb (SchoolR ssh sRoute) = case sRoute of @@ -2477,8 +2478,25 @@ pageActions PrintCenterR = do , navForceActive = False } } + emailCenter = NavPageActionPrimary + { navLink = defNavLink MsgMenuMailCenter $ MailCenterR + , navChildren = [] + } dayLinks <- mapM toDayAck $ Map.toAscList dayMap - return $ manualSend : printLog : printAck : take 9 dayLinks + return $ emailCenter : manualSend : printLog : printAck : take 9 dayLinks + +pageActions (MailHtmlR smid) = return + [ NavPageActionPrimary + { navLink = defNavLink MsgMenuMailPlain $ MailPlainR smid + , navChildren = [] + } + ] +pageActions (MailPlainR smid) = return + [ NavPageActionPrimary + { navLink = defNavLink MsgMenuMailHtml $ MailHtmlR smid + , navChildren = [] + } + ] pageActions AdminCrontabR = return [ NavPageActionPrimary diff --git a/src/Handler/MailCenter.hs b/src/Handler/MailCenter.hs index ce4b2b06e..f638341f0 100644 --- a/src/Handler/MailCenter.hs +++ b/src/Handler/MailCenter.hs @@ -6,7 +6,8 @@ module Handler.MailCenter ( getMailCenterR, postMailCenterR - , getMailShowR + , getMailHtmlR + , getMailPlainR ) where import Import @@ -31,6 +32,18 @@ import Handler.Utils -- import qualified Data.CaseInsensitive as CI -- import Jobs.Queue +import qualified Data.Aeson as Aeson + +import Text.Blaze.Html (preEscapedToHtml) +-- import Text.Blaze.Html5 as H (html, body, pre, p, h1) +-- import Text.Blaze.Html.Renderer.String (renderHtml) +-- import Data.Text (Text) + + +-- import qualified Data.Text.Lazy as LT +-- import qualified Data.Text.Lazy.Encoding as LT +import qualified Data.ByteString.Lazy as LB + -- avoids repetition of local definitions @@ -58,20 +71,19 @@ type MCTableExpr = queryMail :: MCTableExpr -> E.SqlExpr (Entity SentMail) queryMail = $(sqlLOJproj 2 1) -{- + queryRecipient :: MCTableExpr -> E.SqlExpr (Maybe (Entity User)) queryRecipient = $(sqlLOJproj 2 2) --} + type MCTableData = DBRow (Entity SentMail, Maybe (Entity User)) resultMail :: Lens' MCTableData (Entity SentMail) resultMail = _dbrOutput . _1 -{- resultRecipient :: Traversal' MCTableData (Entity User) resultRecipient = _dbrOutput . _2 . _Just --} + mkMCTable :: DB (FormResult (MCTableActionData, Set SentMailId), Widget) mkMCTable = do @@ -85,15 +97,27 @@ mkMCTable = do dbtColonnade = mconcat [ dbSelect (applying _2) id (return . view (resultMail . _entityKey)) , sortable (Just "sent") (i18nCell MsgPrintJobCreated) $ \( view $ resultMail . _entityVal . _sentMailSentAt -> t) -> dateTimeCell t -- TODO: msg + , sortable (Just "recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR + , sortable Nothing (i18nCell MsgCommSubject) $ \(view resultMail -> Entity k v) -> + let subject = v ^? _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject" + linkWgt = maybe (msg2widget MsgUtilEMail) text2widget subject + in anchorCellM (MailHtmlR <$> encrypt k) linkWgt + , sortable Nothing (i18nCell MsgMenuMailHtml) $ \(view $ resultMail . _entityKey -> k) -> anchorCellM (MailHtmlR <$> encrypt k) (text2widget "html") + , sortable Nothing (i18nCell MsgCommSubject) $ \(preview $ resultMail . _entityVal . _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject" -> h) -> cellMaybe textCell h ] dbtSorting = mconcat [ single ("sent" , SortColumn $ queryMail >>> (E.^. SentMailSentAt)) + , single ("recipient" , sortUserNameBareM queryRecipient) ] dbtFilter = mconcat - [ single ("sent" , FilterColumn . E.mkDayFilter $ views (to queryMail) (E.^. SentMailSentAt)) + [ single ("sent" , FilterColumn . E.mkDayFilter $ views (to queryMail) (E.^. SentMailSentAt)) + , single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName)) + , single ("subject" , FilterColumn . E.mkContainsFilter $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders))) ] dbtFilterUI mPrev = mconcat [ prismAForm (singletonFilter "sent" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) -- TODO: msg + , prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlus) + , prismAForm (singletonFilter "subject" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCommSubject & setTooltip MsgTableFilterCommaPlusShort) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout} dbtIdent :: Text @@ -140,5 +164,104 @@ postMailCenterR = do $(widgetFile "mail-center") -getMailShowR :: CryptoUUIDSentMail -> Handler Html -getMailShowR _ = error "TODO: STUB" +getMailHtmlR :: CryptoUUIDSentMail -> Handler Html +getMailHtmlR = handleMailShow [typeHtml,typePlain] + +getMailPlainR :: CryptoUUIDSentMail -> Handler Html +getMailPlainR = handleMailShow [typePlain,typeHtml] + +handleMailShow :: [ContentType] -> CryptoUUIDSentMail -> Handler Html +handleMailShow prefTypes cusm = do + smid <- decrypt cusm + (sm,cn) <- runDB $ do + sm <- get404 smid + cn <- get404 $ sm ^. _sentMailContentRef + return (sm,cn) + siteLayoutMsg MsgMenuMailCenter $ do + setTitleI MsgMenuMailCenter + let mcontent = getMailContent (sentMailContentContent cn) + getHeader h = preview (_mailHeader' h) (sm ^. _sentMailHeaders . _mailHeaders') + [whamlet| +

    +
    +
    + _{MsgPrintJobCreated} +
    + ^{formatTimeW SelFormatDateTime (sm ^. _sentMailSentAt)} + $maybe r <- getHeader "From" +
    + _{MsgPrintSender} +
    + #{r} + $maybe r <- getHeader "To" +
    + _{MsgPrintRecipient} +
    + #{r} + $maybe r <- getHeader "Subject" +
    + _{MsgCommSubject} +
    + #{r} + +
    + $forall mc <- mcontent + $maybe pt <- selectAlternative prefTypes mc +

    + ^{part2widget pt} + |] + -- ^{jsonWidget (sm ^. _sentMailHeaders)} + -- ^{jsonWidget (sentMailContentContent cn)} + + +{- +alternative2widget :: Alternatives -> Widget +alternative2widget alt = -- show all parts for now TODO: select only best representation for each + [whamlet| +

    + $forall p <- alt + ^{part2widget p} +
    + |] +-} + +selectAlternative :: [ContentType] -> Alternatives -> Maybe Part +selectAlternative (fmap decodeUtf8 -> prefTypes) allAlts = aux prefTypes allAlts + where + aux ts@(ct:_) (pt:ps) + | ct == partType pt = Just pt + | otherwise = aux ts ps + aux (_:ts) [] = aux ts allAlts + aux [] (pt:_) = Just pt + aux _ [] = Nothing + +disposition2widget :: Disposition -> Widget +disposition2widget (AttachmentDisposition n) = [whamlet|

    Attachment #{n}|] +disposition2widget (InlineDisposition n) = [whamlet|

    #{n}|] +disposition2widget DefaultDisposition = mempty + + +part2widget :: Part -> Widget +part2widget Part{partContent=NestedParts ps} = + [whamlet| +
    + $forall p <- ps + ^{part2widget p} +
    +
    + |] +part2widget Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} = + [whamlet| +
    + ^{disposition2widget dispo} + ^{showBody} +
    + |] + where + showBody + | pt == decodeUtf8 typePlain = toWidget $ preEscapedToHtml $ plaintextToHtml $ decodeUtf8 pc + | pt == decodeUtf8 typeHtml = toWidget $ preEscapedToHtml $ decodeUtf8 pc -- preEscapedToHtml :: ToMarkup a => a -> Html + | pt == decodeUtf8 typeJson = + let jw :: Aeson.Value -> Widget = jsonWidget + in either str2widget jw $ Aeson.eitherDecodeStrict' pc + | otherwise = [whamlet|part2widget cannot decode parts of type #{pt} yet.|] diff --git a/src/Mail.hs b/src/Mail.hs index 4f9ab00d6..cb44ce38e 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -38,7 +38,7 @@ module Mail , setDate, setDateCurrent , getMailSmtpData , _addressName, _addressEmail - , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailReplyTo, _mailReplyTo', _mailHeaders, _mailHeader, _mailParts + , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailReplyTo, _mailReplyTo', _mailHeaders, _mailHeader, _mailHeader', _mailParts , _partType, _partEncoding, _partDisposition, _partFilename, _partHeaders, _partContent ) where @@ -140,9 +140,9 @@ import Web.HttpApiData (ToHttpApiData(toHeader)) newtype AddressEqIgnoreName = AddressEqIgnoreName { getAddress :: Address } deriving (Show, Generic) -instance Eq AddressEqIgnoreName where +instance Eq AddressEqIgnoreName where (==) = (==) `on` (addressEmail . getAddress) -instance Ord AddressEqIgnoreName where +instance Ord AddressEqIgnoreName where compare = compare `on` (addressEmail . getAddress) @@ -159,16 +159,19 @@ _partFilename = _partDisposition . dispositionFilename dispositionFilename _ DefaultDisposition = pure DefaultDisposition _mailHeader :: CI ByteString -> Traversal' Mail Text -_mailHeader hdrName = _mailHeaders . traverse . filtered (views _1 $ (== hdrName) . CI.mk) . _2 +_mailHeader = (_mailHeaders .) . _mailHeader' -_mailReplyTo' :: Lens' Mail Text +_mailHeader' :: CI ByteString -> Traversal' Headers Text +_mailHeader' hdrName = traverse . filtered (views _1 $ (== hdrName) . CI.mk) . _2 + +_mailReplyTo' :: Lens' Mail Text _mailReplyTo' = _mailHeaders . _headerReplyTo' -_headerReplyTo' :: Lens' Headers Text +_headerReplyTo' :: Lens' Headers Text -- Functor f => (Text -> f Text) -> [(ByteString, Text)] -> f [(ByteString, Text)] _headerReplyTo' f hdrs = (\x -> insertAssoc replyto x hdrs) <$> f (maybeMonoid $ lookup replyto hdrs) - where - replyto = "Reply-To" + where + replyto = "Reply-To" _mailReplyTo :: Lens' Mail Address _mailReplyTo = _mailHeaders . _headerReplyTo @@ -176,8 +179,8 @@ _mailReplyTo = _mailHeaders . _headerReplyTo _headerReplyTo :: Lens' Headers Address -- Functor f => (Address -> f Address) -> [(ByteString, Text)] -> f [(ByteString, Text)] _headerReplyTo f hdrs = (\x -> insertAssoc replyto (renderAddress x) hdrs) <$> f (fromString $ unpack $ maybeMonoid $ lookup replyto hdrs) - where - replyto = "Reply-To" + where + replyto = "Reply-To" -- _addressEmail :: Lens' Address Text might help to simplify this code? newtype MailT m a = MailT { _unMailT :: RWST MailContext MailSmtpData Mail m a } @@ -270,7 +273,7 @@ instance Exception MailException class Yesod site => YesodMail site where defaultFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Address defaultFromAddress = Address Nothing . ("yesod@" <>) . pack <$> liftIO getHostName - + envelopeFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Text envelopeFromAddress = addressEmail <$> defaultFromAddress @@ -336,12 +339,12 @@ defMailT :: ( MonadHandler m -> MailT m a -> m a defMailT ls (MailT mailC) = do - fromAddress <- defaultFromAddress - (ret, mail0, smtpData0) <- runRWST mailC ls (emptyMail fromAddress) + fromAddress <- defaultFromAddress + (ret, mail0, smtpData0) <- runRWST mailC ls (emptyMail fromAddress) mail1 <- maybeT (return mail0) $ do guardM useReplyToInstead -- if sender must be fixed within ObjectIdDomain, use replyTo instead domain <- mailObjectIdDomain - let sender = mail0 ^. _mailFrom + let sender = mail0 ^. _mailFrom isdomainaddress = (Text.isInfixOf `on` Text.toCaseFold) domain (sender ^. _addressEmail) -- not sure how to use CI.mk and isInfixOf here $logDebugS "Mail" $ "Use ReplyTo instead of Sender: " <> tshow isdomainaddress <> " From was: " <> renderAddress sender <> " From is: " <> renderAddress fromAddress guard isdomainaddress -- allowing foreign senders might be Fraport specific; maybe remove this guard @@ -378,7 +381,7 @@ instance Semigroup (PrioritisedAlternatives m) where (<>) = mappenddefault instance Monoid (PrioritisedAlternatives m) where - mempty = memptydefault + mempty = memptydefault class YesodMail site => ToMailPart site a where type MailPartReturn site a :: Type @@ -452,14 +455,14 @@ instance YesodMail site => ToMailPart site YamlValue where _partContent .= PartContent (fromStrict $ Yaml.encode val) -data NamedMailPart a = NamedMailPart { disposition :: Disposition, namedPart :: a } +data NamedMailPart a = NamedMailPart { disposition :: Disposition, namedPart :: a } instance ToMailPart site a => ToMailPart site (NamedMailPart a) where type MailPartReturn site (NamedMailPart a) = MailPartReturn site a - toMailPart nmp = do - r <- toMailPart $ namedPart nmp + toMailPart nmp = do + r <- toMailPart $ namedPart nmp _partDisposition .= disposition nmp - return r + return r addAlternatives :: (MonadMail m) @@ -546,7 +549,7 @@ lookupMailHeader :: MonadHeader m => MailHeader -> m (Maybe Text) lookupMailHeader = fmap listToMaybe . getMailHeaders mapMailHeader :: MonadHeader m => MailHeader -> (Text -> Text) -> m () -mapMailHeader header f = modifyHeaders $ adjustAssoc f header +mapMailHeader header f = modifyHeaders $ adjustAssoc f header replaceMailHeaderI :: ( RenderMessage site msg , MonadMail m @@ -642,5 +645,5 @@ getMailSmtpData = execWriterT $ do tell $ mempty { smtpRecipients = recps - , smtpEnvelopeFrom = Last $ Just from + , smtpEnvelopeFrom = Last $ Just from } diff --git a/src/Model/Types/Mail.hs b/src/Model/Types/Mail.hs index 1b6223e10..577e4ebe0 100644 --- a/src/Model/Types/Mail.hs +++ b/src/Model/Types/Mail.hs @@ -34,6 +34,7 @@ import Data.ByteString.Base32 import qualified Data.CaseInsensitive as CI +import qualified Database.Esqueleto.Experimental as E -- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@ -- @@ -121,7 +122,7 @@ instance PathPiece BounceSecret where toPathPiece = CI.foldCase . encodeBase32Unpadded . BA.convert fromPathPiece = fmap BounceSecret . digestFromByteString <=< either (const Nothing) Just . decodeBase32Unpadded . encodeUtf8 -newtype MailContent = MailContent [Alternatives] +newtype MailContent = MailContent {getMailContent :: [Alternatives]} deriving (Eq, Show, Generic) deriving newtype (ToJSON, FromJSON) deriving anyclass (Binary, NFData) @@ -140,3 +141,5 @@ instance PersistFieldSql MailContentReference where sqlType _ = sqlType $ Proxy @(Digest SHA3_512) derivePersistFieldJSON ''MailHeaders + +instance E.SqlString MailHeaders \ No newline at end of file diff --git a/src/Network/Mail/Mime/Instances.hs b/src/Network/Mail/Mime/Instances.hs index fe195fd37..6f3242574 100644 --- a/src/Network/Mail/Mime/Instances.hs +++ b/src/Network/Mail/Mime/Instances.hs @@ -56,8 +56,7 @@ instance Csv.ToNamedRecord Address where instance Csv.DefaultOrdered Address where headerOrder _ = Csv.header [ "name", "email" ] - -newtype MailHeaders = MailHeaders Headers +newtype MailHeaders = MailHeaders {toHeaders:: Headers} deriving (Eq, Ord, Read, Show, Generic) deriving anyclass (NFData) @@ -79,7 +78,7 @@ deriving anyclass instance NFData PartContent deriving anyclass instance NFData Part deriving anyclass instance NFData Address deriving anyclass instance NFData Mail - + deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece } ''Encoding diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 55228823d..fbf697fec 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -186,8 +186,8 @@ class HasEntity c record where hasEntity :: Lens' c (Entity record) --Trivial instance, usefull for lifting to maybes -instance HasEntity (Entity r) r where - hasEntity = id +instance HasEntity (Entity r) r where + hasEntity = id -- Typed convenience to avoid type signatures, due to the missing FunctionalDepenency that we do not want. hasEntityUser :: (HasEntity a User) => Lens' a (Entity User) @@ -299,6 +299,9 @@ makeLenses_ ''FallbackPersonalisedSheetFilesKey makeWrapped ''Textarea makeLenses_ ''SentMail +_mailHeaders' :: Iso' MailHeaders Headers +_mailHeaders' = coerced + makePrisms ''RoomReference makeLenses_ ''RoomReference From f929e03129378e08c8a08ed4bd6f8e8716401813 Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 5 Aug 2024 18:17:00 +0200 Subject: [PATCH 18/23] fix(build): linter likes it --- src/Foundation/Navigation.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 773b2c165..154c65e8c 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -2479,7 +2479,7 @@ pageActions PrintCenterR = do } } emailCenter = NavPageActionPrimary - { navLink = defNavLink MsgMenuMailCenter $ MailCenterR + { navLink = defNavLink MsgMenuMailCenter MailCenterR , navChildren = [] } dayLinks <- mapM toDayAck $ Map.toAscList dayMap From ab00a4f665247ebee167b80ecbe9572d3e4c3ee5 Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 6 Aug 2024 17:42:27 +0200 Subject: [PATCH 19/23] chore(mail): fix #171 by adding a route for all notifications to users and displaying them --- .../uniworx/categories/print/de-de-formal.msg | 3 +- messages/uniworx/categories/print/en-eu.msg | 3 +- .../uniworx/categories/user/de-de-formal.msg | 3 +- messages/uniworx/categories/user/en-eu.msg | 3 +- .../utils/navigation/menu/de-de-formal.msg | 3 +- .../uniworx/utils/navigation/menu/en-eu.msg | 3 +- routes | 9 +- src/Application.hs | 3 +- src/Database/Esqueleto/Utils.hs | 5 +- src/Foundation/Navigation.hs | 28 ++- src/Handler/CommCenter.hs | 172 ++++++++++++++++++ src/Handler/MailCenter.hs | 37 ++-- src/Handler/Profile.hs | 3 + src/Handler/Submission/List.hs | 22 +-- templates/adminUser.hamlet | 10 +- templates/comm-center.hamlet | 9 + .../i18n/profile-remarks/de-de-formal.hamlet | 2 + templates/i18n/profile-remarks/en-eu.hamlet | 2 + templates/profileData.hamlet | 3 +- 19 files changed, 269 insertions(+), 54 deletions(-) create mode 100644 src/Handler/CommCenter.hs create mode 100644 templates/comm-center.hamlet diff --git a/messages/uniworx/categories/print/de-de-formal.msg b/messages/uniworx/categories/print/de-de-formal.msg index 3cc18f0ee..f14def9d8 100644 --- a/messages/uniworx/categories/print/de-de-formal.msg +++ b/messages/uniworx/categories/print/de-de-formal.msg @@ -28,4 +28,5 @@ PrintLmsUser: E‑Learning Id PrintJobs: Druckaufräge PrintLetterType: Brieftypkürzel -MCActDummy: Platzhalter \ No newline at end of file +MCActDummy: Platzhalter +CCActDummy: Platzhalter \ No newline at end of file diff --git a/messages/uniworx/categories/print/en-eu.msg b/messages/uniworx/categories/print/en-eu.msg index 2b491983e..d757cf2cf 100644 --- a/messages/uniworx/categories/print/en-eu.msg +++ b/messages/uniworx/categories/print/en-eu.msg @@ -28,4 +28,5 @@ PrintLmsUser: E‑learning id PrintJobs: Print jobs PrintLetterType: Letter type shorthand -MCActDummy: Placeholder \ No newline at end of file +MCActDummy: Placeholder +CCActDummy: Placeholder \ No newline at end of file diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index f550dd4b2..b2ab14351 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -114,4 +114,5 @@ UsersRemoveSubordinates usr@Int: Alle Ansprechpartnerbeziehungen für #{tshow us UserCompanyReason: Begründung der Firmenassoziation UserCompanyReasonTooltip: Optionale Notiz für besondere Fälle. Kann ggf. autmatische Entfernung bei AVS Firmenwechsel verhindern. UserSupervisorReason: Begründung Ansprechpartner -UserSupervisorReasonTooltip: Optionale Notiz für besondere Fälle. Kann ggf. autmatische Entfernung bei AVS Firmenwechsel verhindern. \ No newline at end of file +UserSupervisorReasonTooltip: Optionale Notiz für besondere Fälle. Kann ggf. autmatische Entfernung bei AVS Firmenwechsel verhindern. +AdminUserAllNotifications: Alle Benachrichtigungen and diesen Benutzer \ No newline at end of file diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg index 6e4624edc..265344219 100644 --- a/messages/uniworx/categories/user/en-eu.msg +++ b/messages/uniworx/categories/user/en-eu.msg @@ -114,4 +114,5 @@ UsersRemoveSubordinates usr: Removed all subordinates for #{pluralENsN usr "prev UserCompanyReason: Reason for company association UserCompanyReasonTooltip: Optional note for special cases. In some case this may prevent automatic removel upon AVS user company changes. UserSupervisorReason: Reason for supervision -UserSupervisorReasonTooltip: Optional note for special cases. In some case this may prevent automatic removel upon AVS user company changes. \ No newline at end of file +UserSupervisorReasonTooltip: Optional note for special cases. In some case this may prevent automatic removel upon AVS user company changes. +AdminUserAllNotifications: All notification sent to this user \ No newline at end of file diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 9eae9e201..523db3d2d 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -143,12 +143,13 @@ MenuSap: SAP Schnittstelle MenuAvs: AVS Schnittstelle MenuAvsSynchError: AVS Problemübersicht MenuLdap: LDAP Schnittstelle -MenuApc: Druckerei +MenuApc: Druck MenuPrintSend: Manueller Briefversand MenuPrintDownload: Brief herunterladen MenuPrintLog: LPR Schnittstelle MenuPrintAck: Druckbestätigung +MenuCommCenter: Benachrichtigungen MenuMailCenter: E‑Mails MenuMailHtml !ident-ok: Html MenuMailPlain !ident-ok: Text diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 79438c351..0dd276ff8 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -143,12 +143,13 @@ MenuSap: SAP Interface MenuAvs: AVS Interface MenuAvsSynchError: AVS Problem Overview MenuLdap: LDAP Interface -MenuApc: Printing +MenuApc: Print MenuPrintSend: Send Letter MenuPrintDownload: Download Letter MenuPrintLog: LPR Interface MenuPrintAck: Acknowledge Printing +MenuCommCenter: Notifications MenuMailCenter: Email MenuMailHtml: Html MenuMailPlain: Text diff --git a/routes b/routes index 10627db43..1030745a2 100644 --- a/routes +++ b/routes @@ -77,6 +77,11 @@ /admin/problems/avs ProblemAvsSynchR GET POST /admin/problems/avs/errors ProblemAvsErrorR GET +/comm CommCenterR GET +/comm/email MailCenterR GET POST +/comm/email/html/#CryptoUUIDSentMail MailHtmlR GET +/comm/email/plain/#CryptoUUIDSentMail MailPlainR GET + /print PrintCenterR GET POST !system-printer /print/acknowledge/#Day/#Int/#Int PrintAckR GET POST !system-printer /print/acknowledge/direct PrintAckDirectR GET POST !system-printer @@ -84,10 +89,6 @@ /print/download/#CryptoUUIDPrintJob PrintDownloadR GET !system-printer /print/log PrintLogR GET !system-printer -/mail MailCenterR GET POST -/mail/html/#CryptoUUIDSentMail MailHtmlR GET -/mail/plain/#CryptoUUIDSentMail MailPlainR GET - /health HealthR GET !free /health/interface/+Texts HealthInterfaceR GET !free /instance InstanceR GET !free diff --git a/src/Application.hs b/src/Application.hs index 30f6d9469..12e0cf9c3 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -157,8 +157,9 @@ import Handler.Upload import Handler.Qualification import Handler.LMS import Handler.SAP -import Handler.PrintCenter +import Handler.CommCenter import Handler.MailCenter +import Handler.PrintCenter import Handler.ApiDocs import Handler.Swagger import Handler.Firm diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 1ce50b833..6a59f0241 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -48,7 +48,7 @@ module Database.Esqueleto.Utils , subSelectCountDistinct , selectCountRows, selectCountDistinct , selectMaybe - , str2text + , str2text, str2text' , num2text --, text2num , day, day', dayMaybe, interval, diffDays, diffTimes , exprLift @@ -712,6 +712,9 @@ selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1) str2text :: E.SqlString a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Text) str2text = E.unsafeSqlCastAs "text" +str2text' :: E.SqlString a => E.SqlExpr (E.Value (Maybe a)) -> E.SqlExpr (E.Value (Maybe Text)) +str2text' = E.unsafeSqlCastAs "text" + -- | cast numeric type to text, which is safe and allows for an inefficient but safe comparison of numbers stored as text and numbers num2text :: Num n => E.SqlExpr (E.Value n) -> E.SqlExpr (E.Value Text) num2text = E.unsafeSqlCastAs "text" diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 154c65e8c..5c3fe16c5 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -129,17 +129,18 @@ breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirmUsers $ Just FirmAll breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors $ Just $ FirmUsersR fsh breadcrumb (FirmCommR fsh)= i18nCrumb MsgMenuFirmsComm $ Just $ FirmUsersR fsh -breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing +breadcrumb CommCenterR = i18nCrumb MsgMenuCommCenter Nothing +breadcrumb MailCenterR = i18nCrumb MsgMenuMailCenter $ Just CommCenterR +breadcrumb MailHtmlR{} = i18nCrumb MsgMenuMailHtml $ Just MailCenterR +breadcrumb MailPlainR{} = i18nCrumb MsgMenuMailPlain $ Just MailCenterR + +breadcrumb PrintCenterR = i18nCrumb MsgMenuApc $ Just CommCenterR breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload $ Just PrintCenterR breadcrumb PrintAckR{} = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR -- never displayed breadcrumb PrintAckDirectR{}= i18nCrumb MsgMenuPrintAck $ Just PrintCenterR breadcrumb PrintLogR = i18nCrumb MsgMenuPrintLog $ Just PrintCenterR -breadcrumb MailCenterR = i18nCrumb MsgMenuMailCenter Nothing -breadcrumb MailHtmlR{} = i18nCrumb MsgMenuMailHtml $ Just MailCenterR -breadcrumb MailPlainR{} = i18nCrumb MsgMenuMailPlain $ Just MailCenterR - breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR breadcrumb (SchoolR ssh sRoute) = case sRoute of SchoolEditR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do @@ -2478,12 +2479,19 @@ pageActions PrintCenterR = do , navForceActive = False } } - emailCenter = NavPageActionPrimary - { navLink = defNavLink MsgMenuMailCenter MailCenterR - , navChildren = [] - } dayLinks <- mapM toDayAck $ Map.toAscList dayMap - return $ emailCenter : manualSend : printLog : printAck : take 9 dayLinks + return $ manualSend : printLog : printAck : take 9 dayLinks + +pageActions CommCenterR = return + [ NavPageActionPrimary + { navLink = defNavLink MsgMenuMailCenter MailCenterR + , navChildren = [] + } + , NavPageActionPrimary + { navLink = defNavLink MsgMenuApc PrintCenterR + , navChildren = [] + } + ] pageActions (MailHtmlR smid) = return [ NavPageActionPrimary diff --git a/src/Handler/CommCenter.hs b/src/Handler/CommCenter.hs new file mode 100644 index 000000000..6cfb16eb0 --- /dev/null +++ b/src/Handler/CommCenter.hs @@ -0,0 +1,172 @@ +-- SPDX-FileCopyrightText: 2024 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +-- TODO: remove these above +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Handler.CommCenter + ( getCommCenterR + ) where + +import Import + +import qualified Data.Set as Set +import qualified Data.Map as Map +-- import qualified Data.Aeson as Aeson +-- import qualified Data.Text as Text + +-- import Database.Persist.Sql (updateWhereCount) +-- import Database.Esqueleto.Experimental ((:&)(..)) +import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy +import qualified Database.Esqueleto.Experimental as E +import qualified Database.Esqueleto.Utils as E +import Database.Esqueleto.Utils.TH + +-- import Utils.Print + +import Handler.Utils +-- import Handler.Utils.Csv +-- import qualified Data.Csv as Csv +-- import qualified Data.CaseInsensitive as CI + +-- import Jobs.Queue +import qualified Data.Aeson as Aeson + +import Text.Blaze.Html (preEscapedToHtml) +-- import Text.Blaze.Html5 as H (html, body, pre, p, h1) +-- import Text.Blaze.Html.Renderer.String (renderHtml) +-- import Data.Text (Text) + + +import Data.Text.Lens (packed) +-- import qualified Data.Text.Lazy as LT +-- import qualified Data.Text.Lazy.Encoding as LT +import qualified Data.ByteString.Lazy as LB + + + +-- avoids repetition of local definitions +single :: (k,a) -> Map k a +single = uncurry Map.singleton + + +data CCTableAction = CCActDummy -- just a dummy, since we don't now yet which actions we will be needing + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + +instance Universe CCTableAction +instance Finite CCTableAction +nullaryPathPiece ''CCTableAction $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''CCTableAction id + +data CCTableActionData = CCActDummyData + deriving (Eq, Ord, Read, Show, Generic) + + +-- SJ: I don't know how to use E.unionAll_ with dbTable, so we simulate it by a FullOuterJoin with constant False ON-clause instead +type CCTableExpr = + ( (E.SqlExpr (Maybe (Entity User)) `E.InnerJoin` E.SqlExpr (Maybe (Entity SentMail))) + `E.FullOuterJoin` (E.SqlExpr (Maybe (Entity User)) `E.InnerJoin` E.SqlExpr (Maybe (Entity PrintJob))) + ) + +queryRecipientMail :: CCTableExpr -> E.SqlExpr (Maybe (Entity User)) +queryRecipientMail = $(sqlIJproj 2 1) . $(sqlFOJproj 2 1) + +queryMail :: CCTableExpr -> E.SqlExpr (Maybe (Entity SentMail)) +queryMail = $(sqlIJproj 2 2) . $(sqlFOJproj 2 1) + +queryRecipientPrint :: CCTableExpr -> E.SqlExpr (Maybe (Entity User)) +queryRecipientPrint = $(sqlIJproj 2 1) . $(sqlFOJproj 2 2) + +queryPrint :: CCTableExpr -> E.SqlExpr (Maybe (Entity PrintJob)) +queryPrint = $(sqlIJproj 2 2) . $(sqlFOJproj 2 2) + +type CCTableData = DBRow (Maybe (Entity User), Maybe (Entity SentMail), Maybe (Entity User), Maybe (Entity PrintJob)) + +resultRecipientMail :: Traversal' CCTableData (Entity User) +resultRecipientMail = _dbrOutput . _1 . _Just + +resultMail :: Traversal' CCTableData (Entity SentMail) +resultMail = _dbrOutput . _2 . _Just + +resultRecipientPrint :: Traversal' CCTableData (Entity User) +resultRecipientPrint = _dbrOutput . _3 . _Just + +resultPrint :: Traversal' CCTableData (Entity PrintJob) +resultPrint = _dbrOutput . _4 . _Just + + +mkCCTable :: DB (Any, Widget) +mkCCTable = do + let + dbtSQLQuery :: CCTableExpr -> E.SqlQuery (E.SqlExpr (Maybe (Entity User)), E.SqlExpr (Maybe (Entity SentMail)), E.SqlExpr (Maybe (Entity User)), E.SqlExpr (Maybe (Entity PrintJob))) + dbtSQLQuery ((recipientMail `E.InnerJoin` mail) `E.FullOuterJoin` (recipientPrint `E.InnerJoin` printJob)) = do + EL.on $ recipientMail E.?. UserId E.==. E.joinV (mail E.?. SentMailRecipient) + EL.on $ recipientPrint E.?. UserId E.==. E.joinV (printJob E.?. PrintJobRecipient) + -- EL.on $ recipientMail E.?. UserId E.==. recipientPrint E.?. UserId E.&&. E.false -- simulating E.unionAll_ by a constant false full outer join, since it is unclear how dbTable could handle E.unionAll_ + EL.on E.false -- simulating E.unionAll_ by a constant false full outer join, since it is unclear how dbTable could handle E.unionAll_ + -- E.where_ $ E.isJust (recipientMail E.?. UserId) E.||. E.isJust (recipientPrint E.?. UserId) -- not needed + -- return (E.coalesce[recipientMail, recipientPrint], mail, print) -- coalesce only works on values, not entities + return (recipientMail, mail, recipientPrint, printJob) + -- dbtRowKey = (,) <$> views (to queryMail) (E.?. SentMailId) <*> views (to queryPrint) (E.?. PrintJobId) + dbtRowKey ((_recipientMail `E.InnerJoin` mail) `E.FullOuterJoin` (_recipientPrint `E.InnerJoin` printJob)) = (mail E.?. SentMailId, printJob E.?. PrintJobId) + + dbtProj = dbtProjId + dbtColonnade = dbColonnade $ mconcat -- prefer print over email in the impossible case that both are Just + [ sortable (Just "date") (i18nCell MsgPrintJobCreated) $ \row -> + let tprint = row ^? resultPrint . _entityVal . _printJobCreated + tmail = row ^? resultMail . _entityVal . _sentMailSentAt + in maybeCell (tprint <|> tmail) dateTimeCell + , sortable (Just "recipient") (i18nCell MsgPrintRecipient) $ \row -> + let uprint = row ^? resultRecipientPrint + umail = row ^? resultRecipientMail + in maybeCell (uprint <|> umail) $ cellHasUserLink AdminUserR + , sortable Nothing (i18nCell MsgCommBody) $ \row -> if + | (Just k) <- row ^? resultPrint . _entityKey + -> anchorCellM (PrintDownloadR <$> encrypt k) $ toWgt (iconLetterOrEmail True ) <> text2widget "-link" + | (Just k) <- row ^? resultMail . _entityKey + -> anchorCellM (MailHtmlR <$> encrypt k) $ toWgt (iconLetterOrEmail False) <> text2widget "-link" + | otherwise + -> mempty + , sortable Nothing (i18nCell MsgCommSubject) $ \row -> + let tsubject = row ^? resultPrint . _entityVal . _printJobFilename . packed + msubject = row ^? resultMail . _entityVal . _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject" + in maybeCell (tsubject <|> msubject) textCell + ] + dbtSorting = mconcat + [ singletonMap "date" $ SortColumn $ \row -> E.coalesce [queryPrint row E.?. PrintJobCreated, queryMail row E.?. SentMailSentAt] + , singletonMap "recipient" $ SortColumns $ \row -> + [ SomeExprValue $ E.coalesce [queryRecipientPrint row E.?. UserSurname , queryRecipientMail row E.?. UserSurname ] + , SomeExprValue $ E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName] + ] + ] + dbtFilter = mconcat + [ single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just + $ \row -> E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName]) + , single ("subject" , FilterColumn . E.mkContainsFilterWithCommaPlus Just + $ \row -> E.coalesce [E.str2text' $ queryPrint row E.?. PrintJobFilename + ,E.str2text' $ queryMail row E.?. SentMailHeaders ]) + ] + dbtFilterUI mPrev = mconcat + [ prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlus) + , prismAForm (singletonFilter "subject" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCommSubject & setTooltip MsgTableFilterCommaPlusShort) + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout} + dbtIdent :: Text + dbtIdent = "comms" + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + dbtParams = def + psValidator = def & defaultSorting [SortDescBy "date"] + dbTable psValidator DBTable{..} + +getCommCenterR :: Handler Html +getCommCenterR = do + (_, ccTable) <- runDB mkCCTable + siteLayoutMsg MsgMenuMailCenter $ do + setTitleI MsgMenuMailCenter + $(widgetFile "comm-center") + diff --git a/src/Handler/MailCenter.hs b/src/Handler/MailCenter.hs index f638341f0..251f84108 100644 --- a/src/Handler/MailCenter.hs +++ b/src/Handler/MailCenter.hs @@ -2,6 +2,9 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +-- TODO: remove these above {-# OPTIONS_GHC -fno-warn-orphans #-} module Handler.MailCenter @@ -44,7 +47,14 @@ import Text.Blaze.Html (preEscapedToHtml) -- import qualified Data.Text.Lazy.Encoding as LT import qualified Data.ByteString.Lazy as LB +import Data.Char as C +import qualified Data.Text as T +-- import qualified Data.Text.Encoding as TE +-- import qualified Data.ByteString.Char8 as BS + +import Data.Bits +-- import Data.Word -- avoids repetition of local definitions single :: (k,a) -> Map k a @@ -96,7 +106,7 @@ mkMCTable = do dbtProj = dbtProjId dbtColonnade = mconcat [ dbSelect (applying _2) id (return . view (resultMail . _entityKey)) - , sortable (Just "sent") (i18nCell MsgPrintJobCreated) $ \( view $ resultMail . _entityVal . _sentMailSentAt -> t) -> dateTimeCell t -- TODO: msg + , sortable (Just "sent") (i18nCell MsgPrintJobCreated) $ \( view $ resultMail . _entityVal . _sentMailSentAt -> t) -> dateTimeCell t , sortable (Just "recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR , sortable Nothing (i18nCell MsgCommSubject) $ \(view resultMail -> Entity k v) -> let subject = v ^? _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject" @@ -115,7 +125,7 @@ mkMCTable = do , single ("subject" , FilterColumn . E.mkContainsFilter $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders))) ] dbtFilterUI mPrev = mconcat - [ prismAForm (singletonFilter "sent" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) -- TODO: msg + [ prismAForm (singletonFilter "sent" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) , prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlus) , prismAForm (singletonFilter "subject" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCommSubject & setTooltip MsgTableFilterCommaPlusShort) ] @@ -192,17 +202,17 @@ handleMailShow prefTypes cusm = do
    _{MsgPrintSender}
    - #{r} + #{decodeMime r} $maybe r <- getHeader "To"
    _{MsgPrintRecipient}
    - #{r} + #{decodeMime r} $maybe r <- getHeader "Subject"
    _{MsgCommSubject}
    - #{r} + #{decodeMime r}
    $forall mc <- mcontent @@ -214,17 +224,6 @@ handleMailShow prefTypes cusm = do -- ^{jsonWidget (sentMailContentContent cn)} -{- -alternative2widget :: Alternatives -> Widget -alternative2widget alt = -- show all parts for now TODO: select only best representation for each - [whamlet| -
    - $forall p <- alt - ^{part2widget p} -
    - |] --} - selectAlternative :: [ContentType] -> Alternatives -> Maybe Part selectAlternative (fmap decodeUtf8 -> prefTypes) allAlts = aux prefTypes allAlts where @@ -240,7 +239,6 @@ disposition2widget (AttachmentDisposition n) = [whamlet|

    Attachment #{n}|] disposition2widget (InlineDisposition n) = [whamlet|

    #{n}|] disposition2widget DefaultDisposition = mempty - part2widget :: Part -> Widget part2widget Part{partContent=NestedParts ps} = [whamlet| @@ -265,3 +263,8 @@ part2widget Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partD let jw :: Aeson.Value -> Widget = jsonWidget in either str2widget jw $ Aeson.eitherDecodeStrict' pc | otherwise = [whamlet|part2widget cannot decode parts of type #{pt} yet.|] + + +-- | decode the MIME encoded-word format, which is used in email headers to encode non-ASCII text. This format is specified in RFC 2047. +decodeMime :: Text -> Text +decodeMime = id -- TODO \ No newline at end of file diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 9bddff59c..69ee99847 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -46,6 +46,9 @@ import Jobs import Foundation.Yesod.Auth (updateUserLanguage) +{-# ANN module ("HLint: ignore Functor law" :: String) #-} + + data ExamOfficeSettings = ExamOfficeSettings { eosettingsGetSynced :: Bool diff --git a/src/Handler/Submission/List.hs b/src/Handler/Submission/List.hs index 4590b9f48..26476896f 100644 --- a/src/Handler/Submission/List.hs +++ b/src/Handler/Submission/List.hs @@ -48,14 +48,14 @@ import Data.List (genericLength) import qualified Data.Csv as Csv - +{-# ANN module ("HLint: ignore Functor law" :: String) #-} data CorrectionTableFilterProj = CorrectionTableFilterProj { corrProjFilterSubmission :: Maybe (Set [CI Char]) , corrProjFilterPseudonym :: Maybe (Set [CI Char]) , corrProjFilterAuthorshipStatementState :: Last AuthorshipStatementSubmissionState } - + instance Default CorrectionTableFilterProj where def = CorrectionTableFilterProj { corrProjFilterSubmission = Nothing @@ -64,7 +64,7 @@ instance Default CorrectionTableFilterProj where } makeLenses_ ''CorrectionTableFilterProj - + type CorrectionTableExpr = ( E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) @@ -135,7 +135,7 @@ resultSubmittors = _dbrOutput . _6 . itraversed resultUserUser :: Lens' CorrectionTableUserData User resultUserUser = _1 - + resultUserPseudonym :: Traversal' CorrectionTableUserData Pseudonym resultUserPseudonym = _2 . _Just @@ -207,7 +207,7 @@ instance Csv.ToNamedRecord CorrectionTableCsv where , "rating-points" Csv..= csvCorrectionRatingPoints , "rating-comment" Csv..= csvCorrectionRatingComment ] - where + where mkEmpty = \case [Nothing] -> [] x -> x @@ -269,7 +269,7 @@ data CorrectionTableCsvQualification = CorrectionTableCsvNoQualification | CorrectionTableCsvQualifySheet | CorrectionTableCsvQualifyCourse - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) deriving anyclass (Universe, Finite) correctionTableCsvHeader :: Bool -- ^ @showCorrector@ @@ -402,7 +402,7 @@ colSubmissionLink = sortable (Just "submission") (i18nCell MsgTableSubmission) $ colSelect :: forall act h epId. (Semigroup act, Monoid act, Headedness h, Ord epId) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary epId)) colSelect = dbSelect (_1 . applying _2) id $ views resultCryptoID return - + colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \x -> let tid = x ^. resultCourseTerm @@ -457,7 +457,7 @@ colRating' l = sortable (Just "rating") (i18nCell MsgTableRating) $ \x -> ] colAssigned :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \x -> maybeCell (x ^? resultSubmission . _entityVal . _submissionRatingAssigned . _Just) dateTimeCell +colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \x -> maybeCell (x ^? resultSubmission . _entityVal . _submissionRatingAssigned . _Just) dateTimeCell colRated :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colRated = sortable (Just "ratingtime") (i18nCell MsgTableRatingTime) $ \x -> maybeCell (x ^? resultSubmission . _entityVal . _submissionRatingTime . _Just) dateTimeCell @@ -515,7 +515,7 @@ colAuthorshipStatementState = sortable (Just "as-state") (i18nCell MsgSubmission csh = x ^. resultCourseShorthand shn = x ^. resultSheet . _entityVal . _sheetName cID = x ^. resultCryptoID - + asRoute = CSubmissionR tid ssh csh shn cID SubAuthorshipStatementsR in maybeCell (guardOnM (x ^. resultNonAnonymousAccess) $ x ^. resultASState) (\s -> heatC s $ anchorCell asRoute (i18n s :: Widget)) @@ -537,7 +537,7 @@ filterUIIsRated = flip (prismAForm $ singletonFilter "israted" . maybePrism _Pat filterUISubmission :: DBFilterUI filterUISubmission = flip (prismAForm $ singletonFilter "submission") $ aopt (lift `hoistField` textField) (fslI MsgTableSubmission) - + filterUIPseudonym :: DBFilterUI filterUIPseudonym = flip (prismAForm $ singletonFilter "pseudonym") $ aopt (lift `hoistField` textField) (fslI MsgSubmissionPseudonym) @@ -809,7 +809,7 @@ correctionsR whereClause displayColumns dbtFilterUI csvSettings psValidator acti fmap toTypedContent . defaultLayout $ do setTitleI MsgCourseCorrectionsTitle $(widgetFile "corrections") - + correctionsR' :: CorrectionTableWhere -> _ -> _ -> Maybe CorrectionTableCsvSettings -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler (Widget, SheetTypeSummary SqlBackendKey) correctionsR' whereClause displayColumns dbtFilterUI csvSettings psValidator actions = do currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler diff --git a/templates/adminUser.hamlet b/templates/adminUser.hamlet index dca82f0ff..7eed92fc1 100644 --- a/templates/adminUser.hamlet +++ b/templates/adminUser.hamlet @@ -8,8 +8,14 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{thisUserActWgt}
    ^{userDataWidget} -
    -

    + +

    + #{iconNotificationSent} + + _{MsgAdminUserAllNotifications} + + +

    _{MsgAdminUserRightsHeading} ^{systemFunctionsForm} ^{rightsForm} diff --git a/templates/comm-center.hamlet b/templates/comm-center.hamlet new file mode 100644 index 000000000..cc6f5e72f --- /dev/null +++ b/templates/comm-center.hamlet @@ -0,0 +1,9 @@ +$newline never + +$# SPDX-FileCopyrightText: 2024 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +
    +

    + ^{ccTable} diff --git a/templates/i18n/profile-remarks/de-de-formal.hamlet b/templates/i18n/profile-remarks/de-de-formal.hamlet index f851d9b81..443df86aa 100644 --- a/templates/i18n/profile-remarks/de-de-formal.hamlet +++ b/templates/i18n/profile-remarks/de-de-formal.hamlet @@ -9,6 +9,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

    • Nicht aufgeführt sind Zeitstempel mit Benutzerinformationen, z.B. bei der Editierung und Korrektur von Übungen, Kursleiterschaft, Raumbuchungen, etc. +
    • + Nicht aufgeführt sind die an diesen Benutzer versendeten Benachrichtigungen per E-Mail oder Briefpost.

    • Sie können die diff --git a/templates/i18n/profile-remarks/en-eu.hamlet b/templates/i18n/profile-remarks/en-eu.hamlet index 7858e784c..ee749f36c 100644 --- a/templates/i18n/profile-remarks/en-eu.hamlet +++ b/templates/i18n/profile-remarks/en-eu.hamlet @@ -9,6 +9,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

      • Timestamps with user information (e.g. editing of corrections, submission groups, rooms, ...) are not shown here. +
      • + Sent notifications by email or letter are not shown here.

      • You can request your data be deleted by opening diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 60827a7db..363bb0739 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -209,7 +209,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

        _{MsgProfileQualifications}
        - ^{qualificationsTable} + ^{qualificationsTable} ^{maybeTable MsgProfileCourses ownedCoursesTable} @@ -221,5 +221,4 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{maybeTable' MsgTableCorrector Nothing (Just (msg2widget MsgProfileCorrectorRemark <> simpleLinkI MsgProfileCorrections CorrectionsR)) correctionsTable} - ^{profileRemarks} From e35a5e99a6cea0976fd1c28f919e7d0ac0338503 Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 7 Aug 2024 11:44:39 +0200 Subject: [PATCH 20/23] fix(user): format userDisplayNames having umlaut substitutes with respect to userSurname correctly MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit we often have displayNames like "Steffen Joest" and surname "Jöst" which were previously displayed as "Steffen Joest (**Jöst**)" and which are now displayed as "Steffen **Jöst**". Also, the case of surname is left unchanged, while the displayName is converted to title --- src/Handler/Utils/Widgets.hs | 20 +++++++++++++++----- 1 file changed, 15 insertions(+), 5 deletions(-) diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index 88423194e..124b14ad1 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -94,12 +94,19 @@ nameHtml displayName surname | null surname = toHtml displayName | otherwise = case reverse $ T.splitOn surname displayName of [_notContained] - | (suffix:prefixes) <- reverse $ T.splitOn (T.toTitle surname) (T.toTitle displayName) -> + | (suffix:prefixes) <- reverse $ T.splitOn (T.toTitle surname) (T.toTitle displayName), notNull prefixes -> let prefix = T.intercalate surname $ reverse prefixes in [shamlet|$newline never - #{prefix} + #{prefix} # #{surname} - #{suffix} + \ #{suffix} + |] + | (suffix:prefixes) <- reverse $ T.splitOn (fullyNormalize surname) (fullyNormalize displayName), notNull prefixes -> + let prefix = T.intercalate surname $ reverse prefixes + in [shamlet|$newline never + #{prefix} # + #{surname} + \ #{suffix} |] | otherwise -> [shamlet|$newline never #{displayName} ( @@ -108,11 +115,14 @@ nameHtml displayName surname (suffix:prefixes) -> let prefix = T.intercalate surname $ reverse prefixes in [shamlet|$newline never - #{prefix} + #{prefix} # #{surname} - #{suffix} + \ #{suffix} |] [] -> error "Data.Text.splitOn returned empty list in violation of specification." + where + fullyNormalize :: Text -> Text + fullyNormalize = T.toTitle . T.unwords . map text2asciiAlphaNum . T.words nameHtml' :: HasUser u => u -> Html nameHtml' u = nameHtml (u ^. _userDisplayName) (u ^. _userSurname) From c1dbd61c143994ee7cff89ecc1759f6bac266114 Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 7 Aug 2024 13:52:47 +0200 Subject: [PATCH 21/23] chore(mail): minor code cleanup mailCenterR -- hiding currently unneded dbtForm -- slightly better formatting for MIME encoded word --- src/Handler/MailCenter.hs | 31 ++++++++++++++++++------------ src/Handler/Utils/Qualification.hs | 2 +- 2 files changed, 20 insertions(+), 13 deletions(-) diff --git a/src/Handler/MailCenter.hs b/src/Handler/MailCenter.hs index 251f84108..82abaf504 100644 --- a/src/Handler/MailCenter.hs +++ b/src/Handler/MailCenter.hs @@ -105,8 +105,8 @@ mkMCTable = do dbtRowKey = queryMail >>> (E.^. SentMailId) dbtProj = dbtProjId dbtColonnade = mconcat - [ dbSelect (applying _2) id (return . view (resultMail . _entityKey)) - , sortable (Just "sent") (i18nCell MsgPrintJobCreated) $ \( view $ resultMail . _entityVal . _sentMailSentAt -> t) -> dateTimeCell t + [ -- dbSelect (applying _2) id (return . view (resultMail . _entityKey)) + sortable (Just "sent") (i18nCell MsgPrintJobCreated) $ \( view $ resultMail . _entityVal . _sentMailSentAt -> t) -> dateTimeCell t , sortable (Just "recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR , sortable Nothing (i18nCell MsgCommSubject) $ \(view resultMail -> Entity k v) -> let subject = v ^? _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject" @@ -139,15 +139,17 @@ mkMCTable = do { dbParamsFormMethod = POST , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute , dbParamsFormAttrs = [] - , dbParamsFormSubmit = FormSubmit - , dbParamsFormAdditional - = let acts :: Map MCTableAction (AForm Handler MCTableActionData) - acts = mconcat - [ singletonMap MCActDummy $ pure MCActDummyData - ] - in renderAForm FormStandard - $ (, mempty) . First . Just - <$> multiActionA acts (fslI MsgTableAction) Nothing + , dbParamsFormSubmit = FormNoSubmit + , dbParamsFormAdditional = \_csrf -> return (FormMissing, mempty) + -- , dbParamsFormSubmit = FormSubmit + -- , dbParamsFormAdditional + -- = let acts :: Map MCTableAction (AForm Handler MCTableActionData) + -- acts = mconcat + -- [ singletonMap MCActDummy $ pure MCActDummyData + -- ] + -- in renderAForm FormStandard + -- $ (, mempty) . First . Just + -- <$> multiActionA acts (fslI MsgTableAction) Nothing , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def @@ -267,4 +269,9 @@ part2widget Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partD -- | decode the MIME encoded-word format, which is used in email headers to encode non-ASCII text. This format is specified in RFC 2047. decodeMime :: Text -> Text -decodeMime = id -- TODO \ No newline at end of file +decodeMime t = t +-- decodeMime t +-- | Just r <- T.stripPrefix "=?utf-8?Q?" t +-- = T.replace "_" " " $ T.replace "?=" "" r -- TODO: this only works in plain cases without special characters; e.g. umlauts are not handled correctly +-- | otherwise +-- = t diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index a2074d5da..50f3a9384 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -307,7 +307,7 @@ qualificationOption (Entity qid Qualification{..}) = qualificationsOptionList :: [Entity Qualification] -> OptionList QualificationId qualificationsOptionList = mkOptionList . map qualificationOption -{- Should we encrypt the external value or simply rely on uniqueness? +{- Should we encrypt the external value or simply rely on uniqueness? --TODO: still used in Handler.Admin.Avs qualOpt :: Entity Qualification -> Handler (Option QualificationId) qualOpt (Entity qualId qual) = do cQualId :: CryptoUUIDQualification <- encrypt qualId From 8f54ea1051ffbd33efc4e6dfe96d879f4a73783f Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 7 Aug 2024 17:50:38 +0200 Subject: [PATCH 22/23] refactor(qualifications): unify qualification selectField mechanics --- src/Handler/Admin/Avs.hs | 19 ++++++------------- src/Handler/Utils/Qualification.hs | 4 ++-- 2 files changed, 8 insertions(+), 15 deletions(-) diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index b31aecf62..cf0d3ea3a 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -59,7 +59,7 @@ instance Finite ButtonAvsTest nullaryPathPiece ''ButtonAvsTest camelToPathPiece instance Button UniWorX ButtonAvsTest where - btnLabel BtnCheckLicences = "Check all licences" -- could be msg + btnLabel BtnCheckLicences = "Show all licence difference to current AVS" -- could be msg -- btnLabel BtnSynchLicences = "Synchronize all licences" -- could be msg btnClasses BtnCheckLicences = [BCIsButton, BCPrimary] -- btnClasses BtnSynchLicences = [BCIsButton, BCDanger] @@ -270,7 +270,7 @@ postAdminAvsR = do Nothing -> return Nothing (Just BtnCheckLicences) -> do res <- try $ do - allLicences <- avsQuery AvsQueryGetAllLicences + allLicences <- avsQueryNoCache AvsQueryGetAllLicences computeDifferingLicences allLicences case res of (Right diffs) -> do @@ -531,11 +531,12 @@ instance HasUser LicenceTableData where mkLicenceTable :: AvsPersonIdMapPersonCard -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget) mkLicenceTable apidStatus dbtIdent aLic apids = do currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute - avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] [] + avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] [Asc QualificationName] now <- liftIO getCurrentTime let nowaday = utctDay now avsQids = entityKey <$> avsQualifications + qualOpts = pure $ qualificationsOptionList avsQualifications -- fltrLic qual = if -- | aLic == AvsNoLicence -> E.isNothing (qual E.?. QualificationId) E.||. E.isJust (E.joinV $ qual E.?. QualificationAvsLicence) -- could be R, F, both or none at all, but has licence in AVS -- | otherwise -> E.isNothing (qual E.?. QualificationId) E.||. (E.val aLic E.=?. E.joinV (qual E.?. QualificationAvsLicence)) -- if we suggest granting that licence, this join should deliver a value too @@ -614,14 +615,6 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) ] - qualOpt :: Entity Qualification -> Handler (Option QualificationId) - qualOpt (Entity qualId qual) = do - cQualId :: CryptoUUIDQualification <- encrypt qualId - return $ Option - { optionDisplay = CI.original $ qualificationName qual - , optionInternalValue = qualId - , optionExternalValue = tshow cQualId - } aLicQid = fmap entityKey . headMay $ filter ((== Just aLic) . qualificationAvsLicence . entityVal) avsQualifications -- Block identical to Handler/Qualifications TODO: refactor @@ -647,12 +640,12 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do [ singletonMap LicenceTableChangeAvs $ pure LicenceTableChangeAvsData , if aLic == AvsNoLicence then singletonMap LicenceTableRevokeFDrive $ LicenceTableRevokeFDriveData - <$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid + <$> apreq (selectField qualOpts) (fslI MsgQualificationName) aLicQid <*> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) else singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData - <$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid + <$> apreq (selectField qualOpts) (fslI MsgQualificationName) aLicQid <*> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing <*> apreq dayField (fslI MsgLmsQualificationValidUntil) Nothing -- apreq?! <*> aopt (convertField not not (boolField . Just $ SomeMessage MsgBoolIrrelevant)) (fslI MsgQualificationUserNoRenewal) Nothing diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index 50f3a9384..19888e2e6 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -299,8 +299,8 @@ qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationChangeReas qualificationOption :: Entity Qualification -> Option QualificationId qualificationOption (Entity qid Qualification{..}) = let qsh = ciOriginal $ unSchoolKey qualificationSchool - in Option{ optionDisplay = ciOriginal qualificationName <> " (" <> qsh <> ")" - , optionExternalValue = "(" <> ciOriginal qualificationShorthand <> "___" <> qsh <> ")" + in Option{ optionDisplay = ciOriginal qualificationName <> " (" <> qsh <> ")" + , optionExternalValue = toPathPiece $ ciOriginal qualificationShorthand <> "___" <> qsh -- both a publicly known already , optionInternalValue = qid } From 6299612adc274a369fa1ece996789e41be4d063e Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 7 Aug 2024 17:51:33 +0200 Subject: [PATCH 23/23] refactor: various minor changes, mostly some comments --- src/Handler/Course/Edit.hs | 4 ++-- src/Handler/Utils/Avs.hs | 8 ++++---- src/Handler/Utils/Form.hs | 2 +- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index c1df2fd59..138fd2c6c 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -87,8 +87,8 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB uid <- liftHandler requireAuthId (userSchools, elegibleQualifications) :: ([SchoolId], OptionList QualificationId) <- liftHandler . runDB $ do lecturerSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolLecturer]] [] - protoAdminSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]] [] - adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools + protoAdminSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]] [] -- default rights + adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools -- and user as admin rights active right now oldSchool <- forM (cfCourseId =<< template) $ fmap courseSchool . getJust let elegibleSchools = Set.fromList $ lecturerSchools ++ adminSchools userSchools = Set.toList $ maybe id Set.insert oldSchool elegibleSchools diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index aa17b586d..3122b3151 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -714,7 +714,7 @@ upsertCompanySuperior (mbCid, newAfi) mbOldAfi ) reportAdminProblem $ AdminProblemCompanySuperiorChange supid cid oldSup return (cid,supid) - | Just oldSupeEmail <- mbOldAfi ^? _Just . _avsFirmEMailSuperior . _Just -- no more superior, delete old one + | Just oldSupeEmail <- mbOldAfi ^. _Just . _avsFirmEMailSuperior -- no more superior, delete old one = do void $ runMaybeT $ do oldAfi <- MaybeT $ pure mbOldAfi @@ -928,7 +928,7 @@ retrieveDifferingLicences' getStatus = do -- , AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 4 -- AVS:1 FD:1 ] ++ [AvsPersonLicence AvsLicenceVorfeld avsid | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs] #else - allLicences <- avsQuery AvsQueryGetAllLicences + allLicences <- avsQueryNoCache AvsQueryGetAllLicences #endif lDiff <- getDifferingLicences allLicences #ifdef DEVELOPMENT @@ -960,7 +960,7 @@ getDifferingLicences (AvsResponseGetLicences licences) = do --let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld) licences -- rollfeld = Set.filter (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld -- Note: FRADrive users with 'R' also own 'F' qualification, but AvsGetResponseGetLicences yields only either - let vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) licences + let vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) licences -- antitone is ok, see test/Utils/TypesSpec -> "Ord AvsPersonLicence" rollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) vorORrollfeld' vorORrollfeld = Set.map avsLicencePersonID vorORrollfeld' rollfeld = Set.map avsLicencePersonID rollfeld' @@ -995,7 +995,7 @@ getDifferingLicences (AvsResponseGetLicences licences) = do <$> antijoinAvsLicences AvsLicenceVorfeld vorORrollfeld <*> antijoinAvsLicences AvsLicenceRollfeld rollfeld let setTo0 = vorfRevoke -- revoke driving licences - setTo1up = vorfGrant Set.\\ rollGrant -- grant apron driving licence + setTo1up = vorfGrant Set.\\ rollGrant -- grant apron driving licence setTo1down = rollRevoke Set.\\ vorfRevoke -- revoke maneuvering area licence, but retain apron driving licence setTo2 = (rollGrant Set.\\ vorfRevoke) `Set.intersection` (vorfGrant `Set.union` vorORrollfeld) -- grant maneuvering driving licence return AvsLicenceDifferences diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 52df74953..24ceb7b92 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -1489,7 +1489,7 @@ boolField' :: ( MonadHandler m , HandlerSite m ~ UniWorX ) => Field m Bool -boolField' = boolField (Just $ SomeMessage MsgBoolIrrelevant) +boolField' = boolField (Just $ SomeMessage MsgBoolIrrelevant) -- MsgBoolIrrelevant is shown if the field is optional boolField :: ( MonadHandler m , HandlerSite m ~ UniWorX

    _{MsgTableQualification} + _{MsgSortPriority} + +
    + ^{fvWidget (delButtons ! coord)} +