From a360101d4437784ae792817522dabc566aa643fe Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 9 Nov 2023 03:33:42 +0000 Subject: [PATCH 001/110] chore(release): 27.4.49 --- CHANGELOG.md | 7 +++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 11 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index bc81a5744..7238033c9 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [27.4.49](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.48...v27.4.49) (2023-11-09) + + +### Bug Fixes + +* **lms:** report log did not match qualification ([390ff31](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/390ff317ea3bb4ef8918c9cda858f5f228e4a882)) + ## [27.4.48](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.47...v27.4.48) (2023-11-07) diff --git a/nix/docker/version.json b/nix/docker/version.json index 128f6e4a8..ae41d9f2a 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.48" + "version": "27.4.49" } diff --git a/package-lock.json b/package-lock.json index 67f032ee5..a24e9106c 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.48", + "version": "27.4.49", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 04e02d31c..b11cc7651 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.48", + "version": "27.4.49", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index de481c5b4..04e5ca14e 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.48 +version: 27.4.49 dependencies: - base - yesod From 5d8802732a5dbebe99e5c2eef383039d96e8a6da Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 9 Nov 2023 18:07:39 +0100 Subject: [PATCH 002/110] debug(firm): attempt to find error when using firm communication --- package.yaml | 1 + src/Handler/Firm.hs | 4 ++-- src/Handler/Utils/Communication.hs | 10 ++++++++-- 3 files changed, 11 insertions(+), 4 deletions(-) diff --git a/package.yaml b/package.yaml index de481c5b4..fad286442 100644 --- a/package.yaml +++ b/package.yaml @@ -259,6 +259,7 @@ ghc-options: - -j - -freduction-depth=0 - -fprof-auto-calls + - -g when: - condition: flag(pedantic) ghc-options: diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 9e6cdd55e..09da67f7d 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -2,7 +2,7 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later -{-# OPTIONS -Wno-unused-top-binds -Wno-unused-imports #-} -- TODO: remove me, for debugging only +{-# OPTIONS -Wno-unused-top-binds -Wno-unused-imports -Wno-unused-binds #-} -- TODO: remove me, for debugging only {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances {-# LANGUAGE TypeApplications #-} @@ -804,7 +804,7 @@ handleFirmCommR ultDest mbFsh = do ) -} - selected <- mapM decryptUserId =<< lookupGlobalGetParams GetRecipient -- retrieve selected users + selected <- mapM decryptUserId =<< lookupGlobalGetParams GetRecipient -- retrieve selected users empys <- ifMaybeM mbCid selected (\cid -> -- get all employees or stick with selected users, if no company was pre-selected (to limit choices) E.unValue <<$>> runDB (E.select $ do (emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 893b22d14..7e81ba69a 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -134,6 +134,7 @@ crTestFirmCommunication jCompany comm = do commR :: CommunicationRoute -> Handler Html commR CommunicationRoute{..} = do + $logWarnS "COMM" "Communication handleer started" cUser <- maybeAuth MsgRenderer mr <- getMsgRenderer @@ -153,6 +154,7 @@ commR CommunicationRoute{..} = do chosen' <- fmap (maybe id cons cUser . catMaybes) $ mapM decrypt' =<< lookupGlobalGetParams GetRecipient return (suggested, chosen') + $logWarnS "COMM" "Communication handler DB done" let lookupUser :: UserId -> User @@ -236,6 +238,7 @@ commR CommunicationRoute{..} = do recipientsListMsg <- messageI Info MsgCommRecipientsList + $logWarnS "COMM" "Communication handler some definitions done" attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize let attachmentField = genericFileField $ return FileField { fieldIdent = Nothing @@ -246,6 +249,7 @@ commR CommunicationRoute{..} = do , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize , fieldAllEmptyOk = True } + $logWarnS "COMM" "Communication handler some parameters done" -SEEN ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . withButtonForm' universeF . renderAForm FormStandard $ Communication <$> recipientAForm <* aformMessage recipientsListMsg @@ -253,7 +257,8 @@ commR CommunicationRoute{..} = do <$> aopt textField (fslI MsgCommSubject & addAttr "uw-enter-as-tab" "") Nothing <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing) <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing) - ) + ) + $logWarnS "COMM" "Communication handler run form post done" -- NOT SEEN formResult commRes $ \case (comm, BtnCommunicationSend) -> do runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs @@ -262,13 +267,14 @@ commR CommunicationRoute{..} = do (comm, BtnCommunicationTest) -> do runDBJobs . runConduit $ transPipe (mapReaderT lift) (crTestJobs comm) .| sinkDBJobs addMessageI Info MsgCommTestSuccess - + $logWarnS "COMM" "Communication handler form result done" let formWdgt = wrapForm commWdgt def { formMethod = POST , formAction = SomeRoute <$> mbCurrentRoute , formEncoding = commEncoding , formSubmit = FormNoSubmit } + $logWarnS "COMM" "Communication handler finished" siteLayoutMsg crHeading $ do setTitleI crHeading let commTestTip = $(i18nWidgetFile "comm-test-tip") From 63e6d94df2fd1ce879cb59d14bc854f3c2556586 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 9 Nov 2023 17:02:17 +0000 Subject: [PATCH 003/110] fix(firm): add sql indices for frequent filters to greatly enhance performance --- src/Model/Migration/Definitions.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 5f9940449..fd2e9c810 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -141,6 +141,8 @@ migrateManual = do , ("idx_print_job_apc_ident" ,"CREATE INDEX idx_print_job_apc_ident ON \"print_job\" (\"apc_ident\")") , ("idx_user_avs_card_person_id" ,"CREATE INDEX idx_user_avs_card_person_id ON \"user_avs_card\" (\"person_id\")") , ("idx_lms_report_log_q_ident_time" ,"CREATE INDEX idx_lms_report_log_q_ident_time ON \"lms_report_log\" (\"qualification\",\"ident\",\"timestamp\")") + , ("idx_user_company_company" ,"CREATE INDEX idx_user_company_company ON \"user_company\" (\"company\")") -- composed index from unique cannot be used for frequently used filters on company + , ("idx_user_supervisor_user" ,"CREATE INDEX idx_user_supervisor_user ON \"user_supervisor\" (\"user\")") -- composed index from unique cannot be used for frequently used filters on user ] where addIndex :: Text -> Sql -> Migration From 674f6fd81f374e6e9d1719b611444a8d735c2f85 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 10 Nov 2023 08:01:02 +0000 Subject: [PATCH 004/110] fix(build) --- src/Handler/Utils/Communication.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 7e81ba69a..ee7cb9ae6 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -249,7 +249,7 @@ commR CommunicationRoute{..} = do , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize , fieldAllEmptyOk = True } - $logWarnS "COMM" "Communication handler some parameters done" -SEEN + $logWarnS "COMM" "Communication handler some parameters done" -- SEEN ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . withButtonForm' universeF . renderAForm FormStandard $ Communication <$> recipientAForm <* aformMessage recipientsListMsg @@ -258,7 +258,7 @@ commR CommunicationRoute{..} = do <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing) <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing) ) - $logWarnS "COMM" "Communication handler run form post done" -- NOT SEEN + $logWarnS "COMM" "Communication handler run form post done" -- NOT SEEN ANYMORE formResult commRes $ \case (comm, BtnCommunicationSend) -> do runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs From 71c290996da79ac3f2d5a0644ec421f703beb2a6 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 10 Nov 2023 17:00:10 +0100 Subject: [PATCH 005/110] refactor(firm): performance foreign-supervisor filter --- src/Handler/Firm.hs | 36 ++++++++++++++++++++++++------------ 1 file changed, 24 insertions(+), 12 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 09da67f7d..ce9b2afea 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -298,18 +298,30 @@ mkFirmAllTable isAdmin uid = do ) ) , single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> - let checkSuper = do - usrSpr <- E.from $ E.table @UserSupervisor - E.where_ $ E.notExists (do - spr <- E.from $ E.table @UserCompany - E.where_ $ spr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId - E.&&. spr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorSupervisor - ) E.&&. E.exists (do - usr <- E.from $ E.table @UserCompany - E.where_ $ usr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId - E.&&. usr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser - ) - in case criterion of + -- let checkSuper = do + -- usrSpr <- E.from $ E.table @UserSupervisor + -- E.where_ $ E.notExists (do + -- spr <- E.from $ E.table @UserCompany + -- E.where_ $ spr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + -- E.&&. spr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorSupervisor + -- ) E.&&. E.exists (do + -- usr <- E.from $ E.table @UserCompany + -- E.where_ $ usr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + -- E.&&. usr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser + -- ) + let checkSuper = do + usr <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + E.&&. E.exists (do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usr E.^. UserCompanyUser + E.&&. E.notExists (do + sprCmp <- E.from $ E.table @UserCompany + E.where_ $ sprCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + E.&&. sprCmp E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorSupervisor + ) + ) + in case criterion of Nothing -> E.true Just True -> E.exists checkSuper Just False -> E.notExists checkSuper From a6fb00f072c6dc92e2d5c85cbc1bd849493bdb99 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 13 Nov 2023 17:10:27 +0100 Subject: [PATCH 006/110] minor refactor --- src/Handler/Firm.hs | 2 +- src/Handler/Utils/Communication.hs | 32 ++++++++++--------- .../Handler/SendNotification/Qualification.hs | 2 +- 3 files changed, 19 insertions(+), 17 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index ce9b2afea..25f52f89f 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -298,7 +298,7 @@ mkFirmAllTable isAdmin uid = do ) ) , single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> - -- let checkSuper = do + -- let checkSuper = do -- expensive -- usrSpr <- E.from $ E.table @UserSupervisor -- E.where_ $ E.notExists (do -- spr <- E.from $ E.table @UserCompany diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index ee7cb9ae6..8da181737 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -239,25 +239,27 @@ commR CommunicationRoute{..} = do recipientsListMsg <- messageI Info MsgCommRecipientsList $logWarnS "COMM" "Communication handler some definitions done" - attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize - let attachmentField = genericFileField $ return FileField - { fieldIdent = Nothing - , fieldUnpackZips = FileFieldUserOption True False - , fieldMultiple = True - , fieldRestrictExtensions = Nothing - , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty - , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize - , fieldAllEmptyOk = True - } + -- attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize + -- let attachmentField = genericFileField $ return FileField + -- { fieldIdent = Nothing + -- , fieldUnpackZips = FileFieldUserOption True False + -- , fieldMultiple = True + -- , fieldRestrictExtensions = Nothing + -- , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty + -- , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize + -- , fieldAllEmptyOk = True + -- } $logWarnS "COMM" "Communication handler some parameters done" -- SEEN ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . withButtonForm' universeF . renderAForm FormStandard $ Communication <$> recipientAForm <* aformMessage recipientsListMsg - <*> ( CommunicationContent - <$> aopt textField (fslI MsgCommSubject & addAttr "uw-enter-as-tab" "") Nothing - <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing) - <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing) - ) + <*> (pure (CommunicationContent (Just "subject") (text2Html "body") Set.empty) :: AForm Handler CommunicationContent) + -- <*> ( CommunicationContent + -- <$> aopt textField (fslI MsgCommSubject & addAttr "uw-enter-as-tab" "") Nothing + -- <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing) + -- <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) + -- (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing) + -- ) $logWarnS "COMM" "Communication handler run form post done" -- NOT SEEN ANYMORE formResult commRes $ \case (comm, BtnCommunicationSend) -> do diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index d5d8d595e..e169f1552 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -81,7 +81,7 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do $logInfoS "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname else $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> qname - else $logErrorS "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname + else $logInfoS "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname _ -> $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> tshow nQualification From 25c4ba71360de04959039a4d7afe742927eb0b46 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 13 Nov 2023 18:07:30 +0100 Subject: [PATCH 007/110] chore(messaging): add debugging statements --- src/Handler/Firm.hs | 3 ++- src/Handler/Utils/Communication.hs | 6 +++--- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 25f52f89f..2c428eb7e 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -816,7 +816,8 @@ handleFirmCommR ultDest mbFsh = do ) -} - selected <- mapM decryptUserId =<< lookupGlobalGetParams GetRecipient -- retrieve selected users + selected <- mapM decryptUserId =<< lookupGlobalGetParams GetRecipient -- retrieve selected users + empys <- ifMaybeM mbCid selected (\cid -> -- get all employees or stick with selected users, if no company was pre-selected (to limit choices) E.unValue <<$>> runDB (E.select $ do (emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 8da181737..bd222f25c 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -152,14 +152,14 @@ commR CommunicationRoute{..} = do getEntity uid chosen' <- fmap (maybe id cons cUser . catMaybes) $ mapM decrypt' =<< lookupGlobalGetParams GetRecipient - + return (suggested, chosen') - $logWarnS "COMM" "Communication handler DB done" + $logWarnS "COMM" ("Communication handler DB done with (sugg:" <> tshow (length suggestedRecipients) <> ", chosen:" <> tshow (length chosenRecipients) <> ")") let lookupUser :: UserId -> User lookupUser lId - = entityVal . unsafeHead . filter ((== lId) . entityKey) $ concatMap (view _2) suggestedRecipients ++ chosenRecipients + = entityVal . headDef (error $ "this is it" <> show lId) . filter ((== lId) . entityKey) $ concatMap (view _2) suggestedRecipients ++ chosenRecipients let chosenRecipients' = Map.fromList $ [ ( (BoundedPosition $ RecipientGroup g, pos) From 42ff02d27e431a8855db7bf3046a1b74d297e6da Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 14 Nov 2023 12:57:51 +0100 Subject: [PATCH 008/110] fix(firm): sending messages works, but not test messages --- src/Handler/Utils/Communication.hs | 68 ++++++++++++++---------------- 1 file changed, 32 insertions(+), 36 deletions(-) diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index bd222f25c..28473dfc1 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -134,32 +134,29 @@ crTestFirmCommunication jCompany comm = do commR :: CommunicationRoute -> Handler Html commR CommunicationRoute{..} = do - $logWarnS "COMM" "Communication handleer started" - cUser <- maybeAuth - - MsgRenderer mr <- getMsgRenderer - mbCurrentRoute <- getCurrentRoute - - (suggestedRecipients, chosenRecipients) <- runDB $ do - suggestedUsers <- for crRecipients $ \(_,user) -> E.select user - let suggested = zip (view _1 <$> crRecipients) suggestedUsers - - let - decrypt' :: CryptoUUIDUser -> DB (Maybe (Entity User)) + let decrypt' :: CryptoUUIDUser -> DB (Maybe (Entity User)) decrypt' cID = do uid <- decrypt cID whenIsJust crRecipientAuth $ guardAuthResult <=< ($ uid) getEntity uid - chosen' <- fmap (maybe id cons cUser . catMaybes) $ mapM decrypt' =<< lookupGlobalGetParams GetRecipient - - return (suggested, chosen') + cUser <- maybeAuth + + MsgRenderer mr <- getMsgRenderer + mbCurrentRoute <- getCurrentRoute + + (suggestedRecipients, chosenRecipients) <- runDB $ (,) + <$> for crRecipients (\(grp,usrQry) -> (grp,) <$> E.select usrQry) + <*> fmap (maybe id cons cUser . catMaybes) (mapM decrypt' =<< lookupGlobalGetParams GetRecipient) $logWarnS "COMM" ("Communication handler DB done with (sugg:" <> tshow (length suggestedRecipients) <> ", chosen:" <> tshow (length chosenRecipients) <> ")") let - lookupUser :: UserId -> User - lookupUser lId - = entityVal . headDef (error $ "this is it" <> show lId) . filter ((== lId) . entityKey) $ concatMap (view _2) suggestedRecipients ++ chosenRecipients + lookupUser :: UserId -> (UserDisplayName,UserSurname) + lookupUser = + let usrMap = Map.fromList $ fmap (\u -> (entityKey u, entityVal u)) $ chosenRecipients ++ concatMap (view _2) suggestedRecipients + usrNames Nothing = ("???","???") -- this case only happens during runFormPost when POST Data is present and no form is displayed + usrNames (Just User{userDisplayName, userSurname}) = (userDisplayName, userSurname) + in usrNames . flip Map.lookup usrMap let chosenRecipients' = Map.fromList $ [ ( (BoundedPosition $ RecipientGroup g, pos) @@ -187,7 +184,7 @@ commR CommunicationRoute{..} = do miCell _ (Left (CI.original -> email)) initRes nudge csrf = do (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True return (tickRes, $(widgetFile "widgets/communication/recipientEmail")) - miCell _ (Right uid@(lookupUser -> User{..})) initRes nudge csrf = do + miCell _ (Right uid@(lookupUser -> (userDisplayName, userSurname))) initRes nudge csrf = do (tickRes, tickView) <- if | fmap entityKey cUser == Just uid -> mforced checkBoxField ("" & addName (nudge "tick")) True @@ -239,27 +236,26 @@ commR CommunicationRoute{..} = do recipientsListMsg <- messageI Info MsgCommRecipientsList $logWarnS "COMM" "Communication handler some definitions done" - -- attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize - -- let attachmentField = genericFileField $ return FileField - -- { fieldIdent = Nothing - -- , fieldUnpackZips = FileFieldUserOption True False - -- , fieldMultiple = True - -- , fieldRestrictExtensions = Nothing - -- , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty - -- , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize - -- , fieldAllEmptyOk = True - -- } + attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize + let attachmentField = genericFileField $ return FileField + { fieldIdent = Nothing + , fieldUnpackZips = FileFieldUserOption True False + , fieldMultiple = True + , fieldRestrictExtensions = Nothing + , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty + , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize + , fieldAllEmptyOk = True + } $logWarnS "COMM" "Communication handler some parameters done" -- SEEN ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . withButtonForm' universeF . renderAForm FormStandard $ Communication <$> recipientAForm <* aformMessage recipientsListMsg - <*> (pure (CommunicationContent (Just "subject") (text2Html "body") Set.empty) :: AForm Handler CommunicationContent) - -- <*> ( CommunicationContent - -- <$> aopt textField (fslI MsgCommSubject & addAttr "uw-enter-as-tab" "") Nothing - -- <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing) - -- <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) - -- (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing) - -- ) + <*> ( CommunicationContent + <$> aopt textField (fslI MsgCommSubject & addAttr "uw-enter-as-tab" "") Nothing + <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing) + <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) + (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing) + ) $logWarnS "COMM" "Communication handler run form post done" -- NOT SEEN ANYMORE formResult commRes $ \case (comm, BtnCommunicationSend) -> do From 65cdc8ddfef19eb3a5578c536575f91ba9717a13 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 14 Nov 2023 16:55:14 +0100 Subject: [PATCH 009/110] fix(firm): firm messaging now works fine --- .../uniworx/categories/firm/de-de-formal.msg | 1 + messages/uniworx/categories/firm/en-eu.msg | 1 + routes | 2 +- src/Foundation/Navigation.hs | 2 +- src/Handler/Firm.hs | 110 ++++++----- src/Handler/Utils/Communication.hs | 187 +++++++++--------- src/Jobs/Handler/SendCourseCommunication.hs | 4 +- src/Jobs/Types.hs | 2 +- src/Model/Types/Common.hs | 3 +- .../communication/recipientLayout.hamlet | 2 + 10 files changed, 160 insertions(+), 154 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index c50120e92..3e27e0ba5 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -21,4 +21,5 @@ FilterSupervisorForeign fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der s FilterForeignSupervisor: Hat firmenfremde Ansprechpartner FilterFirmPostalAddress: Postalische Firmenadresse vorhanden FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig +FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh} \ No newline at end of file diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 3e24de5c5..ddef25a86 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -21,4 +21,5 @@ FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh} FilterForeignSupervisor: Has company-external supervisors FilterFirmPostalAddress: Postal company addresse known FirmSupervisorOf fsh@CompanyShorthand: Supervisors belonging to #{fsh} +FirmSupervisorIndependent: Independent supervisors FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users \ No newline at end of file diff --git a/routes b/routes index 931c52909..d341734ac 100644 --- a/routes +++ b/routes @@ -114,7 +114,7 @@ /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self /firms FirmAllR GET POST !supervisor -/firms/comm FirmsCommR GET POST +/firms/comm/+Companies FirmsCommR GET POST /firm/#CompanyShorthand FirmR GET POST /firm/#CompanyShorthand/comm FirmCommR GET POST /firm/#CompanyShorthand/users FirmUsersR GET POST !supervisor diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 0c8cbd1a2..b029cc0ee 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -124,7 +124,7 @@ breadcrumb ProblemAvsSynchR = i18nCrumb MsgProblemsAvsSynchHeading $ Just breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just ProblemAvsSynchR breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing -breadcrumb FirmsCommR = i18nCrumb MsgMenuFirmsComm $ Just FirmAllR +breadcrumb FirmsCommR{} = i18nCrumb MsgMenuFirmsComm $ Just FirmAllR breadcrumb FirmR{} = i18nCrumb MsgMenuAdminHeading $ Just FirmAllR -- TODO: change heading or remove breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirmUsers $ Just FirmAllR breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors $ Just $ FirmUsersR fsh diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 2c428eb7e..bfcb14794 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -380,13 +380,13 @@ postFirmAllR = do (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins formResult firmRes $ \case (FirmAllActResetSupervisionData, fids) -> addMessage Info $ text2Html $ "Reset " <> tshow (length fids) <> " companies. TODO" - (FirmAllActNotifyData , fids) -> do + (FirmAllActNotifyData , Set.toList -> fids) -> do usrs <- runDB $ E.select $ E.distinct $ do (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) - E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList (Set.toList fids) + E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList fids return $ usr E.^. UserId cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] - redirect (FirmsCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms $(i18nWidgetFile "firm-all") @@ -792,71 +792,77 @@ postFirmSupersR fsh = do getFirmCommR, postFirmCommR :: CompanyShorthand -> Handler Html getFirmCommR = postFirmCommR -postFirmCommR fsh = handleFirmCommR (SomeRoute $ FirmUsersR fsh) (Just fsh) +postFirmCommR fsh = handleFirmCommR (SomeRoute $ FirmUsersR fsh) [fsh] -getFirmsCommR, postFirmsCommR :: Handler Html +getFirmsCommR, postFirmsCommR :: Companies -> Handler Html getFirmsCommR = postFirmsCommR -postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR) Nothing +postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR) -handleFirmCommR :: SomeRoute UniWorX -> Maybe CompanyShorthand -> Handler Html -handleFirmCommR ultDest mbFsh = do - let decryptUserId :: CryptoUUIDUser -> Handler UserId - decryptUserId = decrypt - - mbCid = CompanyKey <$> mbFsh - - {- - queryEmpys :: CompanyId -> Handler [UserId] - queryEmpys cid = E.unValue <<$>> runDB (E.select $ do - (emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) - E.where_ $ uc E.^. UserCompanyCompany E.==. E.val cid - return $ emp E.^. UserId - ) - -} - - selected <- mapM decryptUserId =<< lookupGlobalGetParams GetRecipient -- retrieve selected users - - empys <- ifMaybeM mbCid selected (\cid -> -- get all employees or stick with selected users, if no company was pre-selected (to limit choices) - E.unValue <<$>> runDB (E.select $ do +handleFirmCommR :: SomeRoute UniWorX -> Companies -> Handler Html +handleFirmCommR _ [] = invalidArgs ["At least one company name must be provided."] +handleFirmCommR ultDest cs = do + let csKey = CompanyKey <$> cs + -- get employees of chosen companies + empys <- E.unValue <<$>> runDB (E.select $ do (emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) - E.where_ $ uc E.^. UserCompanyCompany E.==. E.val cid + E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList csKey return $ emp E.^. UserId - )) - - cmpys <- E.unValue <<$>> runDB (E.select $ do + ) + -- get supervisors of employees + sprs <- E.unValue <<$>> runDB (E.select $ do + spr <- E.from $ E.table @User + E.where_ $ E.exists $ do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. spr E.^. UserId + E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList empys + return $ spr E.^. UserId + ) + -- get companies of all supervisors + sprCmpys <- E.unValue <<$>> runDB (E.select $ do cmpy <- E.from $ E.table @Company - E.where_ $ E.exists $ do + E.where_ $ E.exists $ do usrCmpy <- E.from $ E.table @UserCompany - E.where_ $ usrCmpy E.^. UserCompanyUser `E.in_` E.valList selected - E.&&. usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId + E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId + E.&&. usrCmpy E.^. UserCompanyUser `E.in_` E.valList sprs return $ cmpy E.^.CompanyId ) - let queryCmpy :: Bool -> CompanyId -> E.SqlQuery (E.SqlExpr (Entity User)) - queryCmpy sORe acid = do - (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) - E.where_ $ uc E.^. UserCompanyCompany E.==. E.val acid - E.&&. (if sORe - then -- supervisors only - E.exists $ do - usrSpr <- E.from $ E.table @UserSupervisor - E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId - E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList empys - else -- selected employees for this company only - usr E.^. UserId `E.in_` E.valList empys - ) - return usr + let + queryLoners :: E.SqlQuery (E.SqlExpr (Entity User)) -- get supervisors without any company affiliation + queryLoners = do + spr <- E.from $ E.table @User + E.where_ $ spr E.^. UserId `E.in_` E.valList empys + E.&&. E.notExists (do + sprCmp <- E.from $ E.table @UserCompany + E.where_ $ sprCmp E.^. UserCompanyUser E.==. spr E.^. UserId + ) + return $ spr + + queryCmpy :: Bool -> CompanyId -> E.SqlQuery (E.SqlExpr (Entity User)) + queryCmpy sORe acid = do + (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) + E.where_ $ uc E.^. UserCompanyCompany E.==. E.val acid + E.&&. (if sORe + then -- supervisors only + E.exists $ do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList empys + else E.true + ) + return usr commR CommunicationRoute - { crHeading = SomeMessage $ maybe MsgFirmsNotification MsgFirmNotification mbFsh + { crHeading = SomeMessage $ case cs of { [c] -> MsgFirmNotification c; _ -> MsgFirmsNotification } , crUltDest = ultDest - , crJobs = crJobsFirmCommunication mbFsh -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () - , crTestJobs = crTestFirmCommunication mbFsh -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () + , crJobs = crJobsFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () + , crTestJobs = crTestFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () , crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult , crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))] - [(RGFirmSupervisor $ unCompanyKey acid, queryCmpy True acid) | acid <- cmpys ] <> - [(RGFirmEmployees $ unCompanyKey acid, queryCmpy False acid) | acid <- cmpys, maybe True (acid ==) mbCid] + [(RGFirmSupervisor $ unCompanyKey acid, queryCmpy True acid) | acid <- sprCmpys ] ++ + (RGFirmIndependent, queryLoners) : + [(RGFirmEmployees $ unCompanyKey acid, queryCmpy False acid) | acid <- csKey ] } {- Auswahlbox für Mitteilung: diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 28473dfc1..333d088cb 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -32,7 +32,7 @@ data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrect | RGTutorialParticipants CryptoUUIDTutorial | RGExamRegistered CryptoUUIDExam | RGSheetSubmittor CryptoUUIDSheet - | RGFirmSupervisor CompanyShorthand | RGFirmEmployees CompanyShorthand + | RGFirmSupervisor CompanyShorthand | RGFirmEmployees CompanyShorthand | RGFirmIndependent deriving (Eq, Ord, Read, Show, Generic) instance LowerBounded RecipientGroup where @@ -110,8 +110,8 @@ crTestJobsCourseCommunication jCourse comm = do crJobsCourseCommunication jCourse comm' .| C.filter ((== Right jSender) . jRecipientEmail) -crJobsFirmCommunication :: Maybe CompanyShorthand -> Communication -> ConduitT () Job (YesodDB UniWorX) () -crJobsFirmCommunication jCompany Communication{..} = do +crJobsFirmCommunication :: Companies -> Communication -> ConduitT () Job (YesodDB UniWorX) () +crJobsFirmCommunication jCompanies Communication{..} = do jSender <- requireAuthId let jMailContent = cContent allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients @@ -122,12 +122,12 @@ crJobsFirmCommunication jCompany Communication{..} = do forM_ allRecipients $ \jRecipientEmail -> yield JobSendFirmCommunication{..} -crTestFirmCommunication :: Maybe CompanyShorthand -> Communication -> ConduitT () Job (YesodDB UniWorX) () -crTestFirmCommunication jCompany comm = do +crTestFirmCommunication :: Companies -> Communication -> ConduitT () Job (YesodDB UniWorX) () +crTestFirmCommunication jCompanies comm = do jSender <- requireAuthId MsgRenderer mr <- getMsgRenderer let comm' = comm & _cContent . _ccSubject %~ Just . mr . MsgCommCourseTestSubject . fromMaybe (mr MsgUtilCommFirmSubject) - crJobsFirmCommunication jCompany comm' .| C.filter ((== Right jSender) . jRecipientEmail) + crJobsFirmCommunication jCompanies comm' .| C.filter ((== Right jSender) . jRecipientEmail) @@ -139,103 +139,100 @@ commR CommunicationRoute{..} = do uid <- decrypt cID whenIsJust crRecipientAuth $ guardAuthResult <=< ($ uid) getEntity uid - cUser <- maybeAuth + (chosenRecipients, suggestedRecipients) <- runDB $ (,) + <$> (maybe id cons cUser . catMaybes <$> (mapM decrypt' =<< lookupGlobalGetParams GetRecipient)) + <*> (filter (notNull . snd) <$> for crRecipients (\(grp,usrQry) -> (grp,) <$> E.select usrQry)) + $logWarnS "COMM" ("Communication handlerwith (sugg:" <> tshow (length suggestedRecipients) <> ", chosen:" <> tshow (length chosenRecipients) <> ")") MsgRenderer mr <- getMsgRenderer mbCurrentRoute <- getCurrentRoute - (suggestedRecipients, chosenRecipients) <- runDB $ (,) - <$> for crRecipients (\(grp,usrQry) -> (grp,) <$> E.select usrQry) - <*> fmap (maybe id cons cUser . catMaybes) (mapM decrypt' =<< lookupGlobalGetParams GetRecipient) - $logWarnS "COMM" ("Communication handler DB done with (sugg:" <> tshow (length suggestedRecipients) <> ", chosen:" <> tshow (length chosenRecipients) <> ")") - let lookupUser :: UserId -> (UserDisplayName,UserSurname) - lookupUser = - let usrMap = Map.fromList $ fmap (\u -> (entityKey u, entityVal u)) $ chosenRecipients ++ concatMap (view _2) suggestedRecipients - usrNames Nothing = ("???","???") -- this case only happens during runFormPost when POST Data is present and no form is displayed + lookupUser = + let usrMap = Map.fromList $ fmap (\u -> (entityKey u, entityVal u)) $ chosenRecipients ++ concatMap (view _2) suggestedRecipients + usrNames Nothing = ("???","???") -- this case only happens during runFormPost when POST Data is present and no form is display usrNames (Just User{userDisplayName, userSurname}) = (userDisplayName, userSurname) in usrNames . flip Map.lookup usrMap - let chosenRecipients' = Map.fromList $ - [ ( (BoundedPosition $ RecipientGroup g, pos) - , (Right recp, recp `elem` map entityKey chosenRecipients) - ) - | (g, recps) <- suggestedRecipients - , (pos, recp) <- zip [0..] $ map entityKey recps - ] ++ - [ ( (BoundedPosition RecipientCustom, pos) - , (Right recp, True) - ) - | (pos, recp) <- zip [0..] . Set.toList $ Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ view _2 <$> suggestedRecipients) - ] - activeCategories = map RecipientGroup (view _1 <$> suggestedRecipients) `snoc` RecipientCustom + chosenRecipients' = Map.fromList $ + [ ( (BoundedPosition $ RecipientGroup g, pos) + , (Right recp, recp `elem` map entityKey chosenRecipients) + ) + | (g, recps) <- suggestedRecipients + , (pos, recp) <- zip [0..] $ map entityKey recps + ] ++ + [ ( (BoundedPosition RecipientCustom, pos) + , (Right recp, True) + ) + | (pos, recp) <- zip [0..] . Set.toList $ Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ view _2 <$> suggestedRecipients) + ] + activeCategories = map RecipientGroup (view _1 <$> suggestedRecipients) `snoc` RecipientCustom - let recipientAForm :: AForm Handler (Set (Either UserEmail UserId)) - recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients') - where - miAdd pos@(BoundedPosition RecipientCustom, 0) dim@1 liveliness nudge submitView = guardOn (miAllowAdd pos dim liveliness) $ \csrf -> do - (addRes, addView) <- mpreq (multiUserField True Nothing) (fslpI MsgUtilEMail (mr MsgUtilEMail) & setTooltip MsgUtilMultiEmailFieldTip & addName (nudge "email")) Nothing - let - addRes' = addRes <&> \nEmails ((Map.elems &&& maybe 0 (succ . snd . fst) . Map.lookupMax) . Map.filterWithKey (\(BoundedPosition c, _) _ -> c == RecipientCustom) -> (oEmails, kStart)) -> FormSuccess . Map.fromList . zip (map (BoundedPosition RecipientCustom, ) [kStart..]) . Set.toList $ nEmails `Set.difference` Set.fromList oEmails - return (addRes', $(widgetFile "widgets/communication/recipientAdd")) - miAdd _ _ _ _ _ = Nothing - miCell _ (Left (CI.original -> email)) initRes nudge csrf = do - (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True - return (tickRes, $(widgetFile "widgets/communication/recipientEmail")) - miCell _ (Right uid@(lookupUser -> (userDisplayName, userSurname))) initRes nudge csrf = do - (tickRes, tickView) <- if - | fmap entityKey cUser == Just uid - -> mforced checkBoxField ("" & addName (nudge "tick")) True - | otherwise - -> mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True - return (tickRes, $(widgetFile "widgets/communication/recipientName")) - miAllowAdd (BoundedPosition RecipientCustom, 0) 1 _ = True - miAllowAdd _ _ _ = False - miAddEmpty _ 0 _ = Set.singleton (BoundedPosition RecipientCustom, 0) - miAddEmpty _ _ _ = Set.empty - miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX) - miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute - miLayout :: MapLiveliness (BoundedLiveliness RecipientCategory) ListLength - -> Map (BoundedPosition RecipientCategory, ListPosition) (_, FormResult Bool) - -> Map (BoundedPosition RecipientCategory, ListPosition) Widget - -> Map (BoundedPosition RecipientCategory, ListPosition) (FieldView UniWorX) - -> Map (Natural, (BoundedPosition RecipientCategory, ListPosition)) Widget - -> Widget - miLayout liveliness cState cellWdgts _delButtons addWdgts = do - checkedIdentBase <- newIdent - let checkedCategories = Set.mapMonotonic (unBoundedPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False cState) $ Map.keysSet cState - checkedIdent c = checkedIdentBase <> "-" <> toPathPiece c - hasContent c = not (null $ categoryIndices c) || Map.member (1, (BoundedPosition c, 0)) addWdgts - categoryIndices c = Set.filter ((== c) . unBoundedPosition . fst) $ review liveCoords liveliness - rgTutorialParticipantsCaption :: CryptoUUIDTutorial -> Widget - rgTutorialParticipantsCaption cID = do - tutId <- decrypt cID - Tutorial{..} <- liftHandler . runDBRead $ get404 tutId - i18n $ MsgRGTutorialParticipants tutorialName - rgExamRegisteredCaption :: CryptoUUIDExam -> Widget - rgExamRegisteredCaption cID = do - eId <- decrypt cID - Exam{..} <- liftHandler . runDBRead $ get404 eId - i18n $ MsgRGExamRegistered examName - rgSheetSubmittorCaption :: CryptoUUIDSheet -> Widget - rgSheetSubmittorCaption cID = do - sId <- decrypt cID - Sheet{..} <- liftHandler . runDBRead $ get404 sId - i18n $ MsgRGSheetSubmittor sheetName - $(widgetFile "widgets/communication/recipientLayout") - miDelete :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId) -> (BoundedPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (BoundedPosition RecipientCategory, ListPosition) (BoundedPosition RecipientCategory, ListPosition)) - -- miDelete liveliness@(MapLiveliness lMap) (BoundedPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(BoundedPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (BoundedPosition RecipientCustom, ) . Map.mapKeysMonotonic (BoundedPosition RecipientCustom, ) <$> miDeleteList (lMap ! BoundedPosition RecipientCustom) delPos - miDelete _ _ = mzero - miIdent :: Text - miIdent = "recipients" - postProcess :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId) - postProcess = Set.fromList . map fst . filter snd . Map.elems + recipientAForm :: AForm Handler (Set (Either UserEmail UserId)) + recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients') + where + miAdd pos@(BoundedPosition RecipientCustom, 0) dim@1 liveliness nudge submitView = guardOn (miAllowAdd pos dim liveliness) $ \csrf -> do + (addRes, addView) <- mpreq (multiUserField True Nothing) (fslpI MsgUtilEMail (mr MsgUtilEMail) & setTooltip MsgUtilMultiEmailFieldTip & addName (nudge "email")) Nothing + let + addRes' = addRes <&> \nEmails ((Map.elems &&& maybe 0 (succ . snd . fst) . Map.lookupMax) . Map.filterWithKey (\(BoundedPosition c, _) _ -> c == RecipientCustom) -> (oEmails, kStart)) -> FormSuccess . Map.fromList . zip (map (BoundedPosition RecipientCustom, ) [kStart..]) . Set.toList $ nEmails `Set.difference` Set.fromList oEmails + return (addRes', $(widgetFile "widgets/communication/recipientAdd")) + miAdd _ _ _ _ _ = Nothing + miCell _ (Left (CI.original -> email)) initRes nudge csrf = do + (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True + return (tickRes, $(widgetFile "widgets/communication/recipientEmail")) + miCell _ (Right uid@(lookupUser -> (userDisplayName, userSurname))) initRes nudge csrf = do + (tickRes, tickView) <- if + | fmap entityKey cUser == Just uid + -> mforced checkBoxField ("" & addName (nudge "tick")) True + | otherwise + -> mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True + return (tickRes, $(widgetFile "widgets/communication/recipientName")) + miAllowAdd (BoundedPosition RecipientCustom, 0) 1 _ = True + miAllowAdd _ _ _ = False + miAddEmpty _ 0 _ = Set.singleton (BoundedPosition RecipientCustom, 0) + miAddEmpty _ _ _ = Set.empty + miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX) + miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute + miLayout :: MapLiveliness (BoundedLiveliness RecipientCategory) ListLength + -> Map (BoundedPosition RecipientCategory, ListPosition) (_, FormResult Bool) + -> Map (BoundedPosition RecipientCategory, ListPosition) Widget + -> Map (BoundedPosition RecipientCategory, ListPosition) (FieldView UniWorX) + -> Map (Natural, (BoundedPosition RecipientCategory, ListPosition)) Widget + -> Widget + miLayout liveliness cState cellWdgts _delButtons addWdgts = do + checkedIdentBase <- newIdent + let checkedCategories = Set.mapMonotonic (unBoundedPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False cState) $ Map.keysSet cState + checkedIdent c = checkedIdentBase <> "-" <> toPathPiece c + hasContent c = not (null $ categoryIndices c) || Map.member (1, (BoundedPosition c, 0)) addWdgts + categoryIndices c = Set.filter ((== c) . unBoundedPosition . fst) $ review liveCoords liveliness + rgTutorialParticipantsCaption :: CryptoUUIDTutorial -> Widget + rgTutorialParticipantsCaption cID = do + tutId <- decrypt cID + Tutorial{..} <- liftHandler . runDBRead $ get404 tutId + i18n $ MsgRGTutorialParticipants tutorialName + rgExamRegisteredCaption :: CryptoUUIDExam -> Widget + rgExamRegisteredCaption cID = do + eId <- decrypt cID + Exam{..} <- liftHandler . runDBRead $ get404 eId + i18n $ MsgRGExamRegistered examName + rgSheetSubmittorCaption :: CryptoUUIDSheet -> Widget + rgSheetSubmittorCaption cID = do + sId <- decrypt cID + Sheet{..} <- liftHandler . runDBRead $ get404 sId + i18n $ MsgRGSheetSubmittor sheetName + $(widgetFile "widgets/communication/recipientLayout") + miDelete :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId) -> (BoundedPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (BoundedPosition RecipientCategory, ListPosition) (BoundedPosition RecipientCategory, ListPosition)) + -- miDelete liveliness@(MapLiveliness lMap) (BoundedPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(BoundedPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (BoundedPosition RecipientCustom, ) . Map.mapKeysMonotonic (BoundedPosition RecipientCustom, ) <$> miDeleteList (lMap ! BoundedPosition RecipientCustom) delPos + miDelete _ _ = mzero + miIdent :: Text + miIdent = "recipients" + postProcess :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId) + postProcess = Set.fromList . map fst . filter snd . Map.elems recipientsListMsg <- messageI Info MsgCommRecipientsList - - $logWarnS "COMM" "Communication handler some definitions done" + attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize let attachmentField = genericFileField $ return FileField { fieldIdent = Nothing @@ -246,7 +243,7 @@ commR CommunicationRoute{..} = do , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize , fieldAllEmptyOk = True } - $logWarnS "COMM" "Communication handler some parameters done" -- SEEN + ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . withButtonForm' universeF . renderAForm FormStandard $ Communication <$> recipientAForm <* aformMessage recipientsListMsg @@ -255,8 +252,7 @@ commR CommunicationRoute{..} = do <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing) <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing) - ) - $logWarnS "COMM" "Communication handler run form post done" -- NOT SEEN ANYMORE + ) formResult commRes $ \case (comm, BtnCommunicationSend) -> do runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs @@ -265,14 +261,13 @@ commR CommunicationRoute{..} = do (comm, BtnCommunicationTest) -> do runDBJobs . runConduit $ transPipe (mapReaderT lift) (crTestJobs comm) .| sinkDBJobs addMessageI Info MsgCommTestSuccess - $logWarnS "COMM" "Communication handler form result done" + let formWdgt = wrapForm commWdgt def { formMethod = POST , formAction = SomeRoute <$> mbCurrentRoute , formEncoding = commEncoding , formSubmit = FormNoSubmit - } - $logWarnS "COMM" "Communication handler finished" + } siteLayoutMsg crHeading $ do setTitleI crHeading let commTestTip = $(i18nWidgetFile "comm-test-tip") diff --git a/src/Jobs/Handler/SendCourseCommunication.hs b/src/Jobs/Handler/SendCourseCommunication.hs index fa4fbcb69..4edaa2d4d 100644 --- a/src/Jobs/Handler/SendCourseCommunication.hs +++ b/src/Jobs/Handler/SendCourseCommunication.hs @@ -49,12 +49,12 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours dispatchJobSendFirmCommunication :: Either UserEmail UserId -> Set Address - -> Maybe CompanyShorthand + -> Companies -> UserId -> UUID -> CommunicationContent -> JobHandler UniWorX -dispatchJobSendFirmCommunication jRecipientEmail jAllRecipientAddresses _jCompany jSender jMailObjectUUID CommunicationContent{..} = JobHandlerException $ do +dispatchJobSendFirmCommunication jRecipientEmail jAllRecipientAddresses _jCompanies jSender jMailObjectUUID CommunicationContent{..} = JobHandlerException $ do -- (sender,mbComp) <- runDB $ (,) -- <$> getJust jSender -- <*> ifMaybeM jCompany Nothing get diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 6c665adb4..78b4fe50b 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -76,7 +76,7 @@ data Job } | JobSendFirmCommunication { jRecipientEmail :: Either UserEmail UserId , jAllRecipientAddresses :: Set Address - , jCompany :: Maybe CompanyShorthand + , jCompanies :: Companies , jSender :: UserId , jMailObjectUUID :: UUID , jMailContent :: CommunicationContent diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs index 836d2741e..df9bc1a79 100644 --- a/src/Model/Types/Common.hs +++ b/src/Model/Types/Common.hs @@ -42,7 +42,8 @@ type SchoolName = CI Text type SchoolShorthand = CI Text type CompanyName = CI Text -type CompanyShorthand = CI Text +type CompanyShorthand = CI Text +type Companies = [CI Text] type CourseName = CI Text type CourseShorthand = CI Text diff --git a/templates/widgets/communication/recipientLayout.hamlet b/templates/widgets/communication/recipientLayout.hamlet index 9dc2beea0..cd5546277 100644 --- a/templates/widgets/communication/recipientLayout.hamlet +++ b/templates/widgets/communication/recipientLayout.hamlet @@ -35,6 +35,8 @@ $if not (null activeCategories) _{MsgFirmSupervisorOf fsh} $of RecipientGroup (RGFirmEmployees fsh) _{MsgFirmEmployeeOf fsh} + $of RecipientGroup (RGFirmIndependent) + _{MsgFirmSupervisorIndependent} $if hasContent category
From 698a9c54970d6eae110702376bc69f66d4e7beb0 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 14 Nov 2023 17:37:05 +0100 Subject: [PATCH 010/110] refactor(firm): msg, titles and headings --- messages/uniworx/categories/firm/de-de-formal.msg | 4 +++- messages/uniworx/categories/firm/en-eu.msg | 4 +++- src/Handler/Course/Communication.hs | 4 +++- src/Handler/Firm.hs | 9 +++++---- src/Handler/Tutorial/Communication.hs | 5 +++-- src/Handler/Utils/Communication.hs | 3 ++- 6 files changed, 19 insertions(+), 10 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 3e27e0ba5..89399a379 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -15,11 +15,13 @@ FirmSuperActRMSuperDef: Standard Firmenansprechpartner entfernen FirmSuperActRMSuperAll: Als aktiven Ansprechpartner komplett entfernen FirmsNotification: Firmen Benachrichtigung versenden FirmNotification fsh@CompanyShorthand: Benachrichtigung an #{fsh} versenden +FirmsNotificationTitle: Firmen benachrichtigen +FirmNotificationTitle fsh@CompanyShorthand: #{fsh} benachrichtigen FilterSupervisor: Hat aktiven Ansprechpartner FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, #{fsh} der angehört FilterSupervisorForeign fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der selbst nicht #{fsh} angehört FilterForeignSupervisor: Hat firmenfremde Ansprechpartner -FilterFirmPostalAddress: Postalische Firmenadresse vorhanden +FilterFirmExtern: Externe Firma FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh} \ No newline at end of file diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index ddef25a86..044bebd48 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -15,11 +15,13 @@ FirmSuperActRMSuperDef: Remove as default supervisor FirmSuperActRMSuperAll: Remove all active supervisions for this company FirmsNotification: Send company notification FirmNotification fsh: Send notification to company #{fsh} +FirmsNotificationTitle: Company notification +FirmNotificationTitle fsh@CompanyShorthand: #{fsh} notification FilterSupervisor: Has active supervisor FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh} FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh} FilterForeignSupervisor: Has company-external supervisors -FilterFirmPostalAddress: Postal company addresse known +FilterFirmExtern: External company FirmSupervisorOf fsh@CompanyShorthand: Supervisors belonging to #{fsh} FirmSupervisorIndependent: Independent supervisors FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users \ No newline at end of file diff --git a/src/Handler/Course/Communication.hs b/src/Handler/Course/Communication.hs index 07bce86e7..a584267a5 100644 --- a/src/Handler/Course/Communication.hs +++ b/src/Handler/Course/Communication.hs @@ -64,8 +64,10 @@ postCCommR tid ssh csh = do return (cid, tuts, exams, sheets) + let heading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommCourseHeading commR CommunicationRoute - { crHeading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommCourseHeading + { crHeading = heading + , crTitle = heading , crUltDest = SomeRoute $ CourseR tid ssh csh CCommR , crJobs = crJobsCourseCommunication cid , crTestJobs = crTestJobsCourseCommunication cid diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index bfcb14794..7ad115f43 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -333,7 +333,7 @@ mkFirmAllTable isAdmin uid = do , prismAForm (singletonFilter "company-number") mPrev $ aopt textField (fslI MsgTableCompanyNo) , prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) , prismAForm (singletonFilter "foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterForeignSupervisor) - , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmPostalAddress) + , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } acts :: Map FirmAllAction (AForm Handler FirmAllActionData) @@ -601,7 +601,7 @@ postFirmUsersR fsh = do redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) siteLayout (citext2widget companyName) $ do - setTitle $ toHtml $ CI.original companyShorthand <> " (" <> tshow companyAvsId <> ")" + setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId $(widgetFile "firm-users") @@ -768,7 +768,7 @@ postFirmSupersR fsh = do siteLayout (citext2widget fsh) $ do - setTitle $ citext2Html fsh + setTitle $ citext2Html $ fsh <> " Supers" -- TODO: factor out company info section hamlet here and from user table [whamlet|
@@ -854,7 +854,8 @@ handleFirmCommR ultDest cs = do return usr commR CommunicationRoute - { crHeading = SomeMessage $ case cs of { [c] -> MsgFirmNotification c; _ -> MsgFirmsNotification } + { crHeading = SomeMessage $ case cs of { [c] -> MsgFirmNotification c ; _ -> MsgFirmsNotification } + , crTitle = SomeMessage $ case cs of { [c] -> MsgFirmNotificationTitle c ; _ -> MsgFirmsNotificationTitle } , crUltDest = ultDest , crJobs = crJobsFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () , crTestJobs = crTestFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () diff --git a/src/Handler/Tutorial/Communication.hs b/src/Handler/Tutorial/Communication.hs index ede48066a..ed5349e03 100644 --- a/src/Handler/Tutorial/Communication.hs +++ b/src/Handler/Tutorial/Communication.hs @@ -32,9 +32,10 @@ postTCommR tid ssh csh tutn = do ) return (tutData, usertuts) - + let heading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommTutorialHeading commR CommunicationRoute - { crHeading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommTutorialHeading + { crHeading = heading + , crTitle = heading , crUltDest = SomeRoute $ CTutorialR tid ssh csh tutn TCommR , crJobs = crJobsCourseCommunication cid , crTestJobs = crTestJobsCourseCommunication cid diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 333d088cb..d94f79706 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -80,6 +80,7 @@ data CommunicationRoute = CommunicationRoute , crRecipientAuth :: Maybe (UserId -> DB AuthResult) -- ^ Only resolve userids given as GET-Parameter if they fulfil this criterion , crJobs, crTestJobs :: Communication -> ConduitT () Job (YesodDB UniWorX) () , crHeading :: SomeMessage UniWorX + , crTitle :: SomeMessage UniWorX , crUltDest :: SomeRoute UniWorX } @@ -269,7 +270,7 @@ commR CommunicationRoute{..} = do , formSubmit = FormNoSubmit } siteLayoutMsg crHeading $ do - setTitleI crHeading + setTitleI crTitle let commTestTip = $(i18nWidgetFile "comm-test-tip") [whamlet| $newline never From ecde6b0faca4828bc3a17a9d94ea86c547748456 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 14 Nov 2023 18:25:03 +0100 Subject: [PATCH 011/110] chore(firm): add supervisor reset utility functions --- src/Handler/Firm.hs | 54 +++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 52 insertions(+), 2 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 7ad115f43..dc46d5f9a 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -28,11 +28,11 @@ import qualified Data.Map as Map -- import qualified Data.Text as T import qualified Data.CaseInsensitive as CI -- import qualified Data.Conduit.List as C --- import Database.Persist.Sql (updateWhereCount) +import Database.Persist.Sql (deleteWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Legacy as EL (from, on) --- import qualified Database.Esqueleto.PostgreSQL as E +import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH @@ -42,6 +42,56 @@ single :: (k,a) -> Map k a single = uncurry Map.singleton +--------------------------- +-- Firm specific utilities +-- for filters and counts see before FirmAllR Handlers + +-- remove supervisors: +deleteSupervisors :: NonEmpty UserId -> DB Int64 +deleteSupervisors usrs = deleteWhereCount [UserSupervisorUser <-. toList usrs] + +-- reset supervisors given employees of a company to default company supervision, deleting all other supervisors +resetSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64 +resetSupervisors cid employees = do + nr_del <- deleteSupervisors employees + nr_add <- addDefaultSupervisors cid employees + return $ max nr_del nr_add + +-- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company +addDefaultSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64 +addDefaultSupervisors cid employees = do + E.insertSelectWithConflictCount UniqueUserSupervisor + (do + (spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees + E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid + E.&&. spr E.^. UserCompanySupervisor + return $ UserSupervisor + E.<# (spr E.^. UserCompanyUser) + E.<&> usr + E.<&> (spr E.^. UserCompanySupervisorReroute) + ) + (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] ) + +-- like `addDefaultSupervisors`, but selects all employees from database +addDefaultSupervisorsAll :: CompanyId -> DB Int64 +addDefaultSupervisorsAll cid = do + E.insertSelectWithConflictCount UniqueUserSupervisor + (do + (spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany) + E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid + E.&&. spr E.^. UserCompanySupervisor + return $ UserSupervisor + E.<# (spr E.^. UserCompanyUser) + E.<&> (usr E.^. UserCompanyUser) + E.<&> (spr E.^. UserCompanySupervisorReroute) + ) + (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] ) + + + +------------------ +-- Debug Handler + getFirmR, postFirmR :: CompanyShorthand -> Handler Html getFirmR = postFirmR postFirmR fsh = do From 6761767c6ca8cab62a22aa6f755e6231e07ab411 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 15 Nov 2023 12:42:04 +0100 Subject: [PATCH 012/110] fix(lms): LMS restart failing due to old LmsUser entry --- src/Jobs/Handler/LMS.hs | 35 +++++++++++++++++++++-------------- 1 file changed, 21 insertions(+), 14 deletions(-) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 06451d5a6..bb1e1c1ce 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -142,6 +142,7 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act pure lui now <- liftIO getCurrentTime let identsInUse = Set.fromList (E.unValue <$> identsInUseVs) + uniqLmsUse = UniqueLmsQualificationUser qid uid mkLmsUser lpin lid = LmsUser { lmsUserQualification = qid , lmsUserUser = uid @@ -157,26 +158,32 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act , lmsUserEnded = Nothing , lmsUserResetTries = False , lmsUserLocked = True -- initially display locked, since it is not yet available until the first feedback - } + } -- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser)) startLmsUser = do - lpw <- randomLMSpw + lpw <- randomLMSpw maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut qprefix identsInUse) -- runMaybeT $ do -- lid <- MaybeT $ randomLMSIdentBu qprefix identsInUse -- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid - inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser - case inserted of - Nothing -> do - uuid :: CryptoUUIDUser <- encrypt uid - $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> "!" - (Just Entity{entityKey=lkey, entityVal=LmsUser{lmsUserIdent=lid, lmsUserUser=luid, lmsUserQualification=lqid}}) -> -- lmsUser started, but not yet notified - audit $ TransactionLmsStart - { transactionQualification = lqid - , transactionLmsIdent = lid - , transactionLmsUser = luid - , transactionLmsUserKey = lkey - } + getBy uniqLmsUse >>= \case + Just Entity{entityVal=LmsUser{..}} + | isNothing lmsUserEnded, isNothing lmsUserStatus || lmsUserStatus == Just LmsSuccess -> do + uuid :: CryptoUUIDUser <- encrypt uid + $logErrorS "LMS" $ "Generating fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> " due to LMS still existing!" + other -> do + when (isJust other) $ deleteBy uniqLmsUse + untilJustMaxM maxLmsUserIdentRetries startLmsUser >>= \case + Nothing -> do + uuid :: CryptoUUIDUser <- encrypt uid + $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> " for unknown reason!" + (Just Entity{entityKey=lkey, entityVal=LmsUser{lmsUserIdent=lid, lmsUserUser=luid, lmsUserQualification=lqid}}) -> -- lmsUser started, but not yet notified + audit $ TransactionLmsStart + { transactionQualification = lqid + , transactionLmsIdent = lid + , transactionLmsUser = luid + , transactionLmsUserKey = lkey + } -- purge LmsIdent after QualificationAuditDuration expired From 8c4f848675e1125547d1fdfa05560affe4794118 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 15 Nov 2023 15:30:37 +0100 Subject: [PATCH 013/110] fix(avs): preserve unset pin passwords in update --- src/Handler/Utils/Avs.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index ce86e627d..42275f139 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -494,7 +494,7 @@ upsertAvsUserById api = do whenIsJust pinCard $ \pCard -> -- update pin, but only if it was unset or set to the value of an old card unlessM (exists [UserAvsCardCardNo ==. getFullCardNo pCard]) $ do let oldPins = Just . personCard2pin . userAvsCardCard . entityVal <$> oldCards - updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. Nothing:oldPins] + updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. oldPins] -- check for old pin ensures that unset/manually set passwords remain unchanged [UserPinPassword =. userPin] insert_ $ UserAvsCard api (getFullCardNo pCard) pCard now upsertUserCompany uid mbCompany userFirmAddr From 612d97538411788a24412f40cf54fb471197025e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 15 Nov 2023 18:02:52 +0100 Subject: [PATCH 014/110] chore(firm): reset supervisors for FirmAllR working --- .../uniworx/categories/firm/de-de-formal.msg | 6 ++- messages/uniworx/categories/firm/en-eu.msg | 6 ++- src/Database/Esqueleto/Utils.hs | 4 +- src/Handler/Firm.hs | 42 ++++++++++++++----- 4 files changed, 44 insertions(+), 14 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 89399a379..459750323 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -8,8 +8,11 @@ FirmAddress: Postanschrift FirmDefaultPreferenceInfo: Diese Voreinstellungen gelten nur für neue Firmenangehörige FirmAllActNotify: Mitteilung versenden FirmAllActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen +FirmAllActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten? +FirmAllActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig FirmUserActNotify: Mitteilung versenden FirmUserActMkSuper: Zum Firmenansprechpartner ernennen +FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{bool mempty (", " <> tshow rem <> " zuvor gelöscht") (rem > 0)} FirmSuperActNotify: Mitteilung versenden FirmSuperActRMSuperDef: Standard Firmenansprechpartner entfernen FirmSuperActRMSuperAll: Als aktiven Ansprechpartner komplett entfernen @@ -24,4 +27,5 @@ FilterForeignSupervisor: Hat firmenfremde Ansprechpartner FilterFirmExtern: Externe Firma FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit -FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh} \ No newline at end of file +FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh} +NoCompanySelected: Bitte wählen Sie mindestens eine Firm aus. \ No newline at end of file diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 044bebd48..6d497c91e 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -9,6 +9,9 @@ FirmDefaultPreferenceInfo: Default setting for new company associates only FirmAllActNotify: Send message FirmAllActResetSupervision: Reset supervisors for all company associates FirmUserActNotify: Send message +FirmAllActResetSuperKeep: Additionally keep existing supervisors of company associates? +FirmAllActResetMutualSupervision: Supervisors supervise each other +FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> tshow rem <> " deleted before") (rem > 0)} FirmUserActMkSuper: Mark as company supervisor FirmSuperActNotify: Send message FirmSuperActRMSuperDef: Remove as default supervisor @@ -24,4 +27,5 @@ FilterForeignSupervisor: Has company-external supervisors FilterFirmExtern: External company FirmSupervisorOf fsh@CompanyShorthand: Supervisors belonging to #{fsh} FirmSupervisorIndependent: Independent supervisors -FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users \ No newline at end of file +FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users +NoCompanySelected: Select at least one company, please. \ No newline at end of file diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 3cba53920..2e97195e8 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -227,8 +227,8 @@ explicitUnsafeCoerceSqlExprValue typ (E.ERaw _m1 f1) = E.ERaw E.noMeta $ \_nPare ) and, or :: Foldable f => f (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool) -and = F.foldr (E.&&.) true -or = F.foldr (E.||.) false +and = F.foldl' (E.&&.) true -- we can use foldl' since Postgresql reorders conditions anyway +or = F.foldl' (E.||.) false -- | Given a test and a set of values, check whether anyone succeeds the test -- WARNING: SQL leaves it explicitely unspecified whether `||` is short curcuited (i.e. lazily evaluated) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index dc46d5f9a..e7020fab4 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -70,16 +70,18 @@ addDefaultSupervisors cid employees = do E.<&> usr E.<&> (spr E.^. UserCompanySupervisorReroute) ) - (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] ) + (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications]) -- like `addDefaultSupervisors`, but selects all employees from database -addDefaultSupervisorsAll :: CompanyId -> DB Int64 -addDefaultSupervisorsAll cid = do +addDefaultSupervisorsAll :: (MonoFoldable mono, CompanyId ~ Element mono) => Bool -> mono -> DB Int64 +addDefaultSupervisorsAll mutualSupervision cids = do E.insertSelectWithConflictCount UniqueUserSupervisor (do (spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany) - E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid - E.&&. spr E.^. UserCompanySupervisor + E.where_ $ E.and $ guardMonoid (not mutualSupervision) [ E.not_ $ usr E.^. UserCompanySupervisor ] + <> [ spr E.^. UserCompanyCompany `E.in_` E.vals cids + , spr E.^. UserCompanySupervisor + ] return $ UserSupervisor E.<# (spr E.^. UserCompanyUser) E.<&> (usr E.^. UserCompanyUser) @@ -160,8 +162,11 @@ nullaryPathPiece ''FirmAllAction $ camelToPathPiece' 3 embedRenderMessage ''UniWorX ''FirmAllAction id data FirmAllActionData = FirmAllActNotifyData - | FirmAllActResetSupervisionData - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + | FirmAllActResetSupervisionData + { firmAllActResetKeepOldSupers :: Maybe Bool + , firmAllActResetMutualSupervision :: Maybe Bool + } + deriving (Eq, Ord, Read, Show, Generic) -- just in case for future extensions type AllCompanyTableExpr = E.SqlExpr (Entity Company) @@ -389,7 +394,9 @@ mkFirmAllTable isAdmin uid = do acts :: Map FirmAllAction (AForm Handler FirmAllActionData) acts = mconcat [ singletonMap FirmAllActNotify $ pure FirmAllActNotifyData - , singletonMap FirmAllActResetSupervision $ pure FirmAllActResetSupervisionData + , singletonMap FirmAllActResetSupervision $ FirmAllActResetSupervisionData + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep) (Just $ Just False) + <*> aopt checkBoxField (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True ) ] dbtParams = DBParamsForm { dbParamsFormMethod = POST @@ -429,7 +436,21 @@ postFirmAllR = do isAdmin <- hasReadAccessTo AdminR (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins formResult firmRes $ \case - (FirmAllActResetSupervisionData, fids) -> addMessage Info $ text2Html $ "Reset " <> tshow (length fids) <> " companies. TODO" + (_, fids) | null fids -> addMessageI Error MsgNoCompanySelected + + (FirmAllActResetSupervisionData{..}, fids) -> runDB $ do + delSupers <- if firmAllActResetKeepOldSupers == Just False + then E.deleteCount $ do + spr <- E.from $ E.table @UserSupervisor + E.where_ $ E.exists $ do + usr <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids + E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser + else return 0 + newSupers <- addDefaultSupervisorsAll (firmAllActResetMutualSupervision /= Just False) fids + addMessageI Info $ MsgFirmResetSupervision newSupers delSupers + reloadKeepGetParams FirmAllR -- reload to reflect changes + (FirmAllActNotifyData , Set.toList -> fids) -> do usrs <- runDB $ E.select $ E.distinct $ do (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) @@ -437,6 +458,7 @@ postFirmAllR = do return $ usr E.^. UserId cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms $(i18nWidgetFile "firm-all") @@ -887,7 +909,7 @@ handleFirmCommR ultDest cs = do sprCmp <- E.from $ E.table @UserCompany E.where_ $ sprCmp E.^. UserCompanyUser E.==. spr E.^. UserId ) - return $ spr + return spr queryCmpy :: Bool -> CompanyId -> E.SqlQuery (E.SqlExpr (Entity User)) queryCmpy sORe acid = do From 715b751363e1fd646a20b76413623ad1baf145b7 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 16 Nov 2023 18:49:41 +0100 Subject: [PATCH 015/110] chore(firm): add columns and filters and refactor some --- .../uniworx/categories/firm/de-de-formal.msg | 4 +- messages/uniworx/categories/firm/en-eu.msg | 4 +- src/Handler/Firm.hs | 322 +++++++++++------- src/Handler/Utils/Table/Pagination.hs | 9 +- src/Utils/Icon.hs | 5 +- 5 files changed, 209 insertions(+), 135 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 459750323..71c910999 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -28,4 +28,6 @@ FilterFirmExtern: Externe Firma FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh} -NoCompanySelected: Bitte wählen Sie mindestens eine Firm aus. \ No newline at end of file +NoCompanySelected: Bitte wählen Sie mindestens eine Firm aus. +TableIsDefaultSupervisor: Standardansprechpartner +TableIsDefaultReroute: Standardumleitung \ No newline at end of file diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 6d497c91e..7491437fe 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -28,4 +28,6 @@ FilterFirmExtern: External company FirmSupervisorOf fsh@CompanyShorthand: Supervisors belonging to #{fsh} FirmSupervisorIndependent: Independent supervisors FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users -NoCompanySelected: Select at least one company, please. \ No newline at end of file +NoCompanySelected: Select at least one company, please. +TableIsDefaultSupervisor: Default supervisor +TableIsDefaultReroute: Default reroute \ No newline at end of file diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index e7020fab4..17990295c 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -41,6 +41,11 @@ import Database.Esqueleto.Utils.TH single :: (k,a) -> Map k a single = uncurry Map.singleton +decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId +decryptUser = decrypt + +encryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m CryptoUUIDUser +encryptUser = encrypt --------------------------- -- Firm specific utilities @@ -90,6 +95,120 @@ addDefaultSupervisorsAll mutualSupervision cids = do (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] ) +------------------------------ +-- repeatedly useful queries + +fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery () +fromUserCompany mbFltr cmpy = do + usrCmpy <- E.from $ E.table @UserCompany + let basecond = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId + E.where_ $ maybe basecond ((basecond E.&&.).($ usrCmpy)) mbFltr + +firmCountUsers :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountUsers = E.subSelectCount . fromUserCompany Nothing + +firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor)) +-- firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +-- firmCountSupervisors cmpy = E.subSelectCount $ E.distinct $ do +-- usrCmpy <- E.from $ E.table @UserCompany +-- E.where_ $ (usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId) +-- E.&&. (usrCmpy E.^. UserCompanySupervisor E.==. E.true) +-- return $ usrCmpy E.^. UserCompanyUser + +firmHasSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Bool) +firmHasSupervisors = E.exists . fromUserCompany (Just (E.^. UserCompanySupervisor)) + + +firmCountDefaultReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountDefaultReroutes = E.subSelectCount . fromUserCompany (Just (\uc -> uc E.^. UserCompanySupervisor E.&&. uc E.^. UserCompanySupervisorReroute)) + +firmHasDefaultReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Bool) +firmHasDefaultReroutes = E.exists . fromUserCompany (Just (\uc -> uc E.^. UserCompanySupervisor E.&&. uc E.^. UserCompanySupervisorReroute)) + +firmCountEmployeeSupervised :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountEmployeeSupervised = E.subSelectCount . fromUserCompany (Just fltr) + where + fltr :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool) + fltr usrc = E.exists $ do + usrSuper <- E.from $ E.table @UserSupervisor + E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser + +firmCountEmployeeRerouted :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountEmployeeRerouted = E.subSelectCount . fromUserCompany (Just fltr) + where + fltr usrc = E.exists $ do + usrSuper <- E.from $ E.table @UserSupervisor + E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser + E.&&. usrSuper E.^. UserSupervisorRerouteNotifications + +firmCountEmployeeRerPost :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountEmployeeRerPost = E.subSelectCount . fromUserCompany (Just fltr) + where + fltr usrc = E.exists $ do + (usrSuper :& usr) <- + E.from $ E.table @UserSupervisor + `E.innerJoin` E.table @User + `E.on` (\(usrSuper :& usr) -> usrSuper E.^. UserSupervisorSupervisor E.==. usr E.^. UserId) + E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser + E.&&. usrSuper E.^. UserSupervisorRerouteNotifications + E.&&. usr E.^. UserPrefersPostal + E.&&. E.isJust (usr E.^. UserPostAddress) + + +-- firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +-- firmCountForeignSupervisors cmpy = E.coalesceDefault +-- [E.subSelect $ do +-- usrSuper <- E.from $ E.table @UserSupervisor +-- E.groupBy (usrSuper E.^. UserSupervisorSupervisor) +-- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) +-- E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy) +-- return E.countRows +-- ] (E.val 0) + +firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountForeignSupervisors cmpy = E.subSelectCountDistinct $ do + usrSuper <- E.from $ E.table @UserSupervisor + E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) + E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy) + pure $ usrSuper E.^. UserSupervisorSupervisor + +-- firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +-- firmCountActiveReroutes cmpy = E.subSelectCountDistinct $ do +-- usrSuper <- E.from $ E.table @UserSupervisor +-- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) +-- E.&&. usrSuper E.^. UserSupervisorRerouteNotifications +-- pure $ usrSuper E.^. UserSupervisorSupervisor + +firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountActiveReroutes cmpy = E.subSelectCount $ do + usrSuper <- E.from $ E.table @UserSupervisor + E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) + E.&&. usrSuper E.^. UserSupervisorRerouteNotifications + +firmQuerySupervisedBy :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlQuery () +firmQuerySupervisedBy cid mbFltr usr = do + (usrSpr :& usrCmp) <- E.from $ E.table @UserSupervisor + `E.innerJoin` E.table @UserCompany + `E.on` (\(usrSpr :& usrCmp) -> usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser) + let basecond = usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + E.&&. usrCmp E.^. UserCompanyCompany E.==. E.val cid + E.where_ $ maybe basecond ((basecond E.&&.).($ usrSpr)) mbFltr + +firmCountForSupervisor :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlExpr (E.Value Word64) +firmCountForSupervisor = ((E.subSelectCount .) .) . firmQuerySupervisedBy + +firmCountUserSupervisors :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64) +firmCountUserSupervisors usrCmp = E.subSelectCount $ do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser + +firmCountUserSupervisorsReroute :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64) +firmCountUserSupervisorsReroute usrCmp = E.subSelectCount $ do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser + E.&&. usrSpr E.^. UserSupervisorRerouteNotifications + ------------------ -- Debug Handler @@ -190,95 +309,6 @@ resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Bool resultAllCompanyDefaultReroutes = _dbrOutput . _4 . _unValue -fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery () -fromUserCompany mbFltr cmpy = do - usrCmpy <- E.from $ E.table @UserCompany - let basecond = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId - E.where_ $ maybe basecond ((basecond E.&&.).($ usrCmpy)) mbFltr - -firmCountUsers :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -firmCountUsers = E.subSelectCount . fromUserCompany Nothing - -firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor)) --- firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) --- firmCountSupervisors cmpy = E.subSelectCount $ E.distinct $ do --- usrCmpy <- E.from $ E.table @UserCompany --- E.where_ $ (usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId) --- E.&&. (usrCmpy E.^. UserCompanySupervisor E.==. E.true) --- return $ usrCmpy E.^. UserCompanyUser - -firmHasSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Bool) -firmHasSupervisors = E.exists . fromUserCompany (Just (E.^. UserCompanySupervisor)) - - -firmCountDefaultReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -firmCountDefaultReroutes = E.subSelectCount . fromUserCompany (Just (\uc -> uc E.^. UserCompanySupervisor E.&&. uc E.^. UserCompanySupervisorReroute)) - -firmHasDefaultReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Bool) -firmHasDefaultReroutes = E.exists . fromUserCompany (Just (\uc -> uc E.^. UserCompanySupervisor E.&&. uc E.^. UserCompanySupervisorReroute)) - -firmCountEmployeeSupervised :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -firmCountEmployeeSupervised = E.subSelectCount . fromUserCompany (Just fltr) - where - fltr :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool) - fltr usrc = E.exists $ do - usrSuper <- E.from $ E.table @UserSupervisor - E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser - -firmCountEmployeeRerouted :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -firmCountEmployeeRerouted = E.subSelectCount . fromUserCompany (Just fltr) - where - fltr usrc = E.exists $ do - usrSuper <- E.from $ E.table @UserSupervisor - E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser - E.&&. usrSuper E.^. UserSupervisorRerouteNotifications - -firmCountEmployeeRerPost :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -firmCountEmployeeRerPost = E.subSelectCount . fromUserCompany (Just fltr) - where - fltr usrc = E.exists $ do - (usrSuper :& usr) <- - E.from $ E.table @UserSupervisor - `E.innerJoin` E.table @User - `E.on` (\(usrSuper :& usr) -> usrSuper E.^. UserSupervisorSupervisor E.==. usr E.^. UserId) - E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser - E.&&. usrSuper E.^. UserSupervisorRerouteNotifications - E.&&. usr E.^. UserPrefersPostal - E.&&. E.isJust (usr E.^. UserPostAddress) - - --- firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) --- firmCountForeignSupervisors cmpy = E.coalesceDefault --- [E.subSelect $ do --- usrSuper <- E.from $ E.table @UserSupervisor --- E.groupBy (usrSuper E.^. UserSupervisorSupervisor) --- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) --- E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy) --- return E.countRows --- ] (E.val 0) - -firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -firmCountForeignSupervisors cmpy = E.subSelectCountDistinct $ do - usrSuper <- E.from $ E.table @UserSupervisor - E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) - E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy) - pure $ usrSuper E.^. UserSupervisorSupervisor - --- firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) --- firmCountActiveReroutes cmpy = E.subSelectCountDistinct $ do --- usrSuper <- E.from $ E.table @UserSupervisor --- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) --- E.&&. usrSuper E.^. UserSupervisorRerouteNotifications --- pure $ usrSuper E.^. UserSupervisorSupervisor - -firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -firmCountActiveReroutes cmpy = E.subSelectCount $ do - usrSuper <- E.from $ E.table @UserSupervisor - E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) - E.&&. usrSuper E.^. UserSupervisorRerouteNotifications - - mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget) mkFirmAllTable isAdmin uid = do -- now <- liftIO getCurrentTime @@ -438,17 +468,18 @@ postFirmAllR = do formResult firmRes $ \case (_, fids) | null fids -> addMessageI Error MsgNoCompanySelected - (FirmAllActResetSupervisionData{..}, fids) -> runDB $ do - delSupers <- if firmAllActResetKeepOldSupers == Just False - then E.deleteCount $ do - spr <- E.from $ E.table @UserSupervisor - E.where_ $ E.exists $ do - usr <- E.from $ E.table @UserCompany - E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids - E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser - else return 0 - newSupers <- addDefaultSupervisorsAll (firmAllActResetMutualSupervision /= Just False) fids - addMessageI Info $ MsgFirmResetSupervision newSupers delSupers + (FirmAllActResetSupervisionData{..}, fids) -> do + runDB $ do + delSupers <- if firmAllActResetKeepOldSupers == Just False + then E.deleteCount $ do + spr <- E.from $ E.table @UserSupervisor + E.where_ $ E.exists $ do + usr <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids + E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser + else return 0 + newSupers <- addDefaultSupervisorsAll (firmAllActResetMutualSupervision /= Just False) fids + addMessageI Info $ MsgFirmResetSupervision newSupers delSupers reloadKeepGetParams FirmAllR -- reload to reflect changes (FirmAllActNotifyData , Set.toList -> fids) -> do @@ -508,20 +539,23 @@ instance HasUser UserCompanyTableData where hasUser = resultUserUser . _entityVal -firmCountUserSupervisors :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64) -firmCountUserSupervisors usrCmp = E.subSelectCount $ do - usrSpr <- E.from $ E.table @UserSupervisor - E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser - -firmCountUserSupervisorsReroute :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64) -firmCountUserSupervisorsReroute usrCmp = E.subSelectCount $ do - usrSpr <- E.from $ E.table @UserSupervisor - E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser - E.&&. usrSpr E.^. UserSupervisorRerouteNotifications - mkFirmUserTable :: Bool -> CompanyId -> DB (FormResult (FirmUserActionData, Set UserId), Widget) mkFirmUserTable isAdmin cid = do let + mkSprOption (E.Value uid, E.Value udn) = do + uuid <- toPathPiece <$> encryptUser uid + return Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid } + procOptions = fmap mkOptionList . traverse mkSprOption + + rawSupers <- E.select $ do + usr <- E.from $ E.table @User + E.where_ $ E.exists $ firmQuerySupervisedBy cid Nothing usr + return (usr E.^. UserId, usr E.^. UserDisplayName) + let + -- supervisorField :: Field Handler UserId + supervisorField = selectField $ procOptions rawSupers + supervisorsField = multiSelectField $ procOptions rawSupers + fsh = unCompanyKey cid resultDBTable = DBTable{..} where @@ -586,11 +620,30 @@ mkFirmUserTable isAdmin cid = do Nothing -> E.true Just True -> E.exists checkSuper Just False -> E.notExists checkSuper + , singletonMap "supervisor-is" $ FilterColumn $ \row (getLast -> criterion) -> + case criterion of + Just uid -> do + -- uid <- decryptUser uuid + E.exists $ do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId + E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid + _otherwise -> E.true + , singletonMap "supervisors-are" $ FilterColumn $ \row criteria -> + case criteria of + _ | Set.null criteria -> E.true + | otherwise -> do + -- uids <- traverse decryptUser criteria + E.exists $ do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId + E.&&. usrSpr E.^. UserSupervisorSupervisor `E.in_` E.vals criteria ] -- superField = selectField $ ???? dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev - , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift termField) (fslI MsgTableTerm) + , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) + -- , prismAForm (multiFilter "supervisors-are" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor) , prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor) , prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh) , prismAForm (singletonFilter "has-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorForeign fsh) @@ -694,12 +747,18 @@ data FirmSuperActionData = FirmSuperActNotifyData | FirmSuperActRMSuperAllData deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) -type SuperCompanyTableExpr = E.SqlExpr (Entity User) +type SuperCompanyTableExpr = E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserCompany)) querySuperUser :: SuperCompanyTableExpr -> E.SqlExpr (Entity User) -querySuperUser = id +querySuperUser = $(sqlLOJproj 2 1) -type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64, [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)]) +querySuperUserCompany :: SuperCompanyTableExpr -> E.SqlExpr (Maybe (Entity UserCompany)) +querySuperUserCompany = $(sqlLOJproj 2 2) + +type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64 + , [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)] + , E.Value (Maybe Bool), E.Value (Maybe Bool) -- Maybe (Entity UserCompany) + ) resultSuperUser :: Lens' SuperCompanyTableData (Entity User) resultSuperUser = _dbrOutput . _1 @@ -713,6 +772,11 @@ resultSuperCompanyReroutes = _dbrOutput . _3 . _unValue resultSuperCompanies :: Lens' SuperCompanyTableData [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)] resultSuperCompanies = _dbrOutput . _4 +resultSuperCompanyDefaultSuper :: Lens' SuperCompanyTableData (Maybe Bool) +resultSuperCompanyDefaultSuper = _dbrOutput . _5 . _unValue + +resultSuperCompanyDefaultReroute :: Lens' SuperCompanyTableData (Maybe Bool) +resultSuperCompanyDefaultReroute = _dbrOutput . _6 . _unValue instance HasEntity SuperCompanyTableData User where hasEntity = resultSuperUser @@ -720,17 +784,6 @@ instance HasEntity SuperCompanyTableData User where instance HasUser SuperCompanyTableData where hasUser = resultSuperUser . _entityVal -firmQuerySupervisedBy :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlQuery () -firmQuerySupervisedBy cid mbFltr usr = do - (usrSpr :& usrCmp) <- E.from $ E.table @UserSupervisor - `E.innerJoin` E.table @UserCompany - `E.on` (\(usrSpr :& usrCmp) -> usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser) - let basecond = usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId - E.&&. usrCmp E.^. UserCompanyCompany E.==. E.val cid - E.where_ $ maybe basecond ((basecond E.&&.).($ usrSpr)) mbFltr - -firmCountForSupervisor :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlExpr (E.Value Word64) -firmCountForSupervisor = ((E.subSelectCount .) .) . firmQuerySupervisedBy mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Set UserId), Widget) mkFirmSuperTable isAdmin cid = do @@ -738,20 +791,23 @@ mkFirmSuperTable isAdmin cid = do -- fsh = unCompanyKey cid resultDBTable = DBTable{..} where - dbtSQLQuery = \usr -> do + dbtSQLQuery = \(usr `E.LeftOuterJoin` usrCmp) -> do + EL.on $ usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.?=. E.val cid E.where_ $ E.exists $ firmQuerySupervisedBy cid Nothing usr return ( usr , usr & firmCountForSupervisor cid Nothing , usr & firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications)) + , usrCmp E.?. UserCompanySupervisor + , usrCmp E.?. UserCompanySupervisorReroute ) dbtRowKey = querySuperUser >>> (E.^. UserId) - dbtProj = dbtProjSimple $ \(usr, supervised, rerouted) -> do + dbtProj = dbtProjSimple $ \(usr, supervised, rerouted, supervisor, reroute) -> do cmps <- E.select $ do (cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany) E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val (entityKey usr) E.orderBy [E.asc $ cmp E.^. CompanyName] return (cmp E.^. CompanyName, cmp E.^. CompanyShorthand, usrCmp E.^. UserCompanySupervisor) - return (usr, supervised, rerouted, cmps) + return (usr, supervised, rerouted, cmps, supervisor, reroute) dbtColonnade = formColonnade $ mconcat [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey)) , colUserNameModalHdr MsgTableSupervisor ForProfileDataR @@ -761,8 +817,10 @@ mkFirmSuperTable isAdmin cid = do , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultSuperUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultSuperUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b , colUserEmail - , sortable (Just "supervised") (i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr - , sortable (Just "rerouted") (i18nCell MsgTableCompanyNrEmpRerouted ) $ \(view resultSuperCompanyReroutes -> nr) -> wgtCell $ word2widget nr + , sortable (Just "supervised") (i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr + , sortable (Just "rerouted") (i18nCell MsgTableCompanyNrEmpRerouted ) $ \(view resultSuperCompanyReroutes -> nr) -> wgtCell $ word2widget nr + , sortable (Just "def-super") (i18nCell MsgTableIsDefaultSupervisor) $ \(view resultSuperCompanyDefaultSuper -> mb) -> case mb of { Nothing -> iconCell IconSupervisorForeign; Just True -> iconCell IconSupervisor; Just False -> iconSpacerCell } + , sortable (Just "def-reroute") (i18nCell MsgTableIsDefaultReroute) $ \(view resultSuperCompanyDefaultReroute -> mb) -> tickmarkCell (mb == Just True) ] dbtSorting = mconcat [ single $ sortUserNameLink querySuperUser @@ -778,6 +836,8 @@ mkFirmSuperTable isAdmin cid = do E.orderBy [E.asc $ cmp E.^. CompanyName] return (cmp E.^. CompanyName) ) + , singletonMap "def-super" $ SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisor) + , singletonMap "def-reroute" $ SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisorReroute) ] dbtFilter = mconcat [ single $ fltrUserNameEmail querySuperUser diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 2e44c6323..415fb255b 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -37,7 +37,7 @@ module Handler.Utils.Table.Pagination , dbtProjFilteredPostId, dbtProjFilteredPostSimple , noCsvEncode, simpleCsvEncode, simpleCsvEncodeM , withCsvExtraRep - , singletonFilter + , singletonFilter, multiFilter , DBParams(..) , cellAttrs, cellContents , addCellClass @@ -647,6 +647,13 @@ singletonFilter key = prism' fromInner (fmap Just . fromOuter) fromInner = maybe Map.empty $ Map.singleton key . pure fromOuter = Map.lookup key >=> listToMaybe +multiFilter :: Ord k => k -> Prism' (Map k [v]) (Maybe [v]) +-- ^ for use with @prismAForm@ +multiFilter key = prism' fromInner fromOuter + where + -- prism' :: (Maybe [v] -> (Map k [v])) -> ((Map k [v]) -> Maybe (Maybe [v])) -> Prism' (Map k [v]) (Maybe [v]) + fromInner = maybe Map.empty (Map.singleton key) + fromOuter = Just . Map.lookup key data DBTCsvEncode r' k' csv = forall exportData filename sheetName. ( ToNamedRecord csv, CsvColumnsExplained csv diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 982d19b5f..0018e74e0 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -109,12 +109,14 @@ data Icon | IconLetter | IconAt | IconSupervisor + | IconSupervisorForeign -- | IconWaitingForUser | IconExpired | IconLocked | IconUnlocked | IconResetTries -- also see IconReset | IconCompany + deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic) deriving anyclass (Universe, Finite, NFData) @@ -201,12 +203,13 @@ iconText = \case IconLetter -> "mail-bulk" -- Problem "envelope" already used for email as well IconAt -> "at" -- alternative for IconEmail to distinguish from IconLetter IconSupervisor -> "head-side" -- must be notably different to user + IconSupervisorForeign -> "alien" -- IconWaitingForUser -> "user-cog" -- Waiting on a user to do something IconExpired -> "hourglass-end" IconLocked -> "lock" IconUnlocked -> "lock-open-alt" IconResetTries -> "trash-undo" - IconCompany -> "building" + IconCompany -> "building" nullaryPathPiece ''Icon $ camelToPathPiece' 1 deriveLift ''Icon From 44c4b3b6a8a6e7a8154bb10a9b0bfbeab61b232f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 17 Nov 2023 18:54:34 +0100 Subject: [PATCH 016/110] chore(firm): implement several table actions; add supervisor form --- .../uniworx/categories/firm/de-de-formal.msg | 8 +- messages/uniworx/categories/firm/en-eu.msg | 8 +- messages/uniworx/utils/utils/de-de-formal.msg | 3 + messages/uniworx/utils/utils/en-eu.msg | 3 + src/Foundation/I18n.hs | 5 + src/Handler/Firm.hs | 167 +++++++++++++----- src/Handler/Utils/Form.hs | 15 +- src/Utils/Form.hs | 1 + .../i18n/firm-supervisors/de-de-formal.hamlet | 27 +++ templates/i18n/firm-supervisors/en-eu.hamlet | 26 +++ 10 files changed, 212 insertions(+), 51 deletions(-) create mode 100644 templates/i18n/firm-supervisors/de-de-formal.hamlet create mode 100644 templates/i18n/firm-supervisors/en-eu.hamlet diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 71c910999..49fc0d066 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -11,6 +11,7 @@ FirmAllActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurück FirmAllActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten? FirmAllActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig FirmUserActNotify: Mitteilung versenden +FirmUserActResetSupervision: Ansprechpartner auf Firmenstandard zurücksetzen FirmUserActMkSuper: Zum Firmenansprechpartner ernennen FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{bool mempty (", " <> tshow rem <> " zuvor gelöscht") (rem > 0)} FirmSuperActNotify: Mitteilung versenden @@ -30,4 +31,9 @@ FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh} NoCompanySelected: Bitte wählen Sie mindestens eine Firm aus. TableIsDefaultSupervisor: Standardansprechpartner -TableIsDefaultReroute: Standardumleitung \ No newline at end of file +TableIsDefaultReroute: Standardumleitung +ASReqPostal: Benachrichtigungseinstellung +ASReqPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner +ASReqEmpty: Es konnten keine Ansprechpartner hinzugefügt werden +ASReqSetSupers n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner eingetragen #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert. +RemoveDefaultSupervisors n@Int64: #{n} Standard Ansprechpartner entfernt, aber noch nicht deaktiviert. \ No newline at end of file diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 7491437fe..39e46d552 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -11,6 +11,7 @@ FirmAllActResetSupervision: Reset supervisors for all company associates FirmUserActNotify: Send message FirmAllActResetSuperKeep: Additionally keep existing supervisors of company associates? FirmAllActResetMutualSupervision: Supervisors supervise each other +FirmUserActResetSupervision: Reset supervisors to company default FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> tshow rem <> " deleted before") (rem > 0)} FirmUserActMkSuper: Mark as company supervisor FirmSuperActNotify: Send message @@ -30,4 +31,9 @@ FirmSupervisorIndependent: Independent supervisors FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users NoCompanySelected: Select at least one company, please. TableIsDefaultSupervisor: Default supervisor -TableIsDefaultReroute: Default reroute \ No newline at end of file +TableIsDefaultReroute: Default reroute +ASReqPostal: Notification type +ASReqPostalTip: Affects all notifications to this person, not just reroutes to this supervisor +ASReqEmpty: No supervisors added +ASReqSetSupers n postal: #{n} default company supervisors set #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated. +RemoveDefaultSupervisors n: #{n} default supervisors removed, but not yet deactivated. \ No newline at end of file diff --git a/messages/uniworx/utils/utils/de-de-formal.msg b/messages/uniworx/utils/utils/de-de-formal.msg index c02cbe1fb..f25770b33 100644 --- a/messages/uniworx/utils/utils/de-de-formal.msg +++ b/messages/uniworx/utils/utils/de-de-formal.msg @@ -18,6 +18,8 @@ CommRecipients: Empfänger:innen CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht CommRecipientsList: Die an Sie selbst verschickte Kopie der Nachricht wird, zu Archivierungszwecken, eine vollständige Liste aller Empfänger:innen enthalten. Die Empfängerliste wird im CSV-Format an die E-Mail angehängt. Andere Empfänger:innen erhalten die Liste nicht. Bitte entfernen Sie dementsprechend den Anhang bevor Sie die E-Mail weiterleiten oder anderweitig mit Dritten teilen. UtilEMail: E-Mail +UtilPostal: Brief +UtilUnchanged: Nicht verändern UtilMultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Adressen möglich RGTutorialParticipants tutn@TutorialName: Kursteilnehmer:innen (#{tutn}) RGExamRegistered examn@ExamName: Angemeldet zur Prüfung „#{examn}“ @@ -94,6 +96,7 @@ RoomReferenceLinkLink !ident-ok: Link RoomReferenceLinkLinkPlaceholder !ident-ok: URL RoomReferenceLinkInstructions: Anweisungen RoomReferenceLinkInstructionsPlaceholder: Anweisungen +UtilEmptyChoice: Auswahl war leer #invitation.hs InvitationAction: Aktion diff --git a/messages/uniworx/utils/utils/en-eu.msg b/messages/uniworx/utils/utils/en-eu.msg index 1135dbade..97f5daa22 100644 --- a/messages/uniworx/utils/utils/en-eu.msg +++ b/messages/uniworx/utils/utils/en-eu.msg @@ -18,6 +18,8 @@ CommRecipients: Recipients CommRecipientsTip: You always receive a copy of the message CommRecipientsList: For archival purposes the copy of the message sent to you will contain a complete list of all recipients. The list of recipients will be attached to the email in CSV-format. Other recipients do not receive the list. Thus, please remove the attachment before you forward the email or otherwise share it with third parties. UtilEMail: Email +UtilPostal: Postal +UtilUnchanged: No change UtilMultiEmailFieldTip: Multiple emails addresses may be specified (comma-separated) RGTutorialParticipants tutn: Course participants (#{tutn}) RGExamRegistered examn: Registered for exam “#{examn}” @@ -94,6 +96,7 @@ RoomReferenceLinkLink: Link RoomReferenceLinkLinkPlaceholder: URL RoomReferenceLinkInstructions: Instructions RoomReferenceLinkInstructionsPlaceholder: Instructions +UtilEmptyChoice: Empty selection #invitation.hs InvitationAction: Action diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index a7fd0ac1d..8c8a0137b 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -203,6 +203,11 @@ maybeToMessage :: ToMessage m => Text -> Maybe m -> Text -> Text maybeToMessage _ Nothing _ = mempty maybeToMessage before (Just x) after = before <> toMessage x <> after +maybeBoolMessage :: Maybe Bool -> Text -> Text -> Text -> Text +maybeBoolMessage Nothing n _ _ = n +maybeBoolMessage (Just True) _ t _ = t +maybeBoolMessage (Just False) _ _ f = f + newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier deriving stock (Eq, Ord, Read, Show) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 17990295c..c55eee0fb 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -21,6 +21,7 @@ import Import -- import Jobs import Handler.Utils import Handler.Utils.Communication +import Handler.Utils.Avs (guessAvsUser) import qualified Data.Set as Set import qualified Data.Map as Map @@ -28,7 +29,7 @@ import qualified Data.Map as Map -- import qualified Data.Text as T import qualified Data.CaseInsensitive as CI -- import qualified Data.Conduit.List as C -import Database.Persist.Sql (deleteWhereCount) +import Database.Persist.Sql (deleteWhereCount, updateWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Legacy as EL (from, on) @@ -77,16 +78,18 @@ addDefaultSupervisors cid employees = do ) (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications]) --- like `addDefaultSupervisors`, but selects all employees from database -addDefaultSupervisorsAll :: (MonoFoldable mono, CompanyId ~ Element mono) => Bool -> mono -> DB Int64 +-- like `addDefaultSupervisors`, but selects all employees of given companies from database +addDefaultSupervisorsAll :: (CompanyId ~ Element mono, MonoFoldable mono) => Bool -> mono -> DB Int64 addDefaultSupervisorsAll mutualSupervision cids = do E.insertSelectWithConflictCount UniqueUserSupervisor (do (spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany) - E.where_ $ E.and $ guardMonoid (not mutualSupervision) [ E.not_ $ usr E.^. UserCompanySupervisor ] - <> [ spr E.^. UserCompanyCompany `E.in_` E.vals cids - , spr E.^. UserCompanySupervisor - ] + E.where_ $ E.and $ guardMonoid (not mutualSupervision) + [ E.not_ $ usr E.^. UserCompanySupervisor ] + <> [ spr E.^. UserCompanySupervisor + , spr E.^. UserCompanyCompany `E.in_` E.vals cids + , usr E.^. UserCompanyCompany `E.in_` E.vals cids + ] return $ UserSupervisor E.<# (spr E.^. UserCompanyUser) E.<&> (usr E.^. UserCompanyUser) @@ -216,12 +219,12 @@ firmCountUserSupervisorsReroute usrCmp = E.subSelectCount $ do getFirmR, postFirmR :: CompanyShorthand -> Handler Html getFirmR = postFirmR postFirmR fsh = do - let fshId = CompanyKey fsh + let cid = CompanyKey fsh cusers <- runDB $ do - cusers <- selectList [UserCompanyCompany ==. fshId] [] + cusers <- selectList [UserCompanyCompany ==. cid] [] selectList [UserId <-. fmap (userCompanyUser . entityVal) cusers] [Asc UserDisplayName] csuper <- runDB $ do - csuper <- selectList [UserCompanyCompany ==. fshId, UserCompanySupervisor ==. True] [] + csuper <- selectList [UserCompanyCompany ==. cid, UserCompanySupervisor ==. True] [] selectList [UserId <-. fmap (userCompanyUser . entityVal) csuper] [Asc UserDisplayName] cactSuper <- runDB $ E.select $ do (usr :& spr :& scmpy) <- E.from $ @@ -253,7 +256,7 @@ postFirmR fsh = do
  • #{nr} Employees supervised by ^{nameWidget dn sn} # #{iconLetterOrEmail prefPost} # $maybe csh <- mbCsh - $if csh /= fshId + $if csh /= cid from foreign company #{unCompanyKey csh} $else from this company @@ -478,8 +481,8 @@ postFirmAllR = do E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser else return 0 - newSupers <- addDefaultSupervisorsAll (firmAllActResetMutualSupervision /= Just False) fids - addMessageI Info $ MsgFirmResetSupervision newSupers delSupers + newSupers <- addDefaultSupervisorsAll (firmAllActResetMutualSupervision /= Just False) fids + addMessageI Info $ MsgFirmResetSupervision delSupers newSupers reloadKeepGetParams FirmAllR -- reload to reflect changes (FirmAllActNotifyData , Set.toList -> fids) -> do @@ -499,6 +502,7 @@ postFirmAllR = do -- Firm Users Table data FirmUserAction = FirmUserActNotify + | FirmUserActResetSupervision | FirmUserActMkSuper deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -507,8 +511,14 @@ nullaryPathPiece ''FirmUserAction $ camelToPathPiece' 3 embedRenderMessage ''UniWorX ''FirmUserAction id data FirmUserActionData = FirmUserActNotifyData + | FirmUserActResetSupervisionData + { firmUserActResetKeepOldSupers :: Maybe Bool + -- , firmUserActResetMutualSupervision :: Maybe Bool + } | FirmUserActMkSuperData - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + { firmUserActMkSuperReroute :: Maybe Bool } + + deriving (Eq, Ord, Read, Show, Generic) type UserCompanyTableExpr = E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity UserCompany) @@ -651,8 +661,12 @@ mkFirmUserTable isAdmin cid = do dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } acts :: Map FirmUserAction (AForm Handler FirmUserActionData) acts = mconcat - [ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData - , singletonMap FirmUserActMkSuper $ pure FirmUserActMkSuperData + [ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData + , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep) (Just $ Just False) + -- <*> aopt checkBoxField (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True ) + , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData + <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) ] dbtParams = DBParamsForm { dbParamsFormMethod = POST @@ -720,10 +734,23 @@ postFirmUsersR fsh = do <*> mkFirmUserTable isAdmin cid formResult fusrRes $ \case - (FirmUserActMkSuperData, fids) -> addMessage Info $ text2Html $ "Make " <> tshow (length fids) <> " employees to supervisors. TODO" - (FirmUserActNotifyData , fids) -> do - cuids <- traverse encrypt $ Set.toList fids :: Handler [CryptoUUIDUser] + (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice + (FirmUserActMkSuperData{..}, uids) -> do + nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. firmUserActMkSuperReroute] + addMessageI Info $ MsgASReqSetSupers nrMkSuper Nothing + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + (FirmUserActNotifyData , uids) -> do + cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + (FirmUserActResetSupervisionData{..}, Set.toList -> uids') -> do + let uids = fromList uids' -- guaranteed to be non-empty due to first case clause + runDB $ do + delSupers <- if firmUserActResetKeepOldSupers == Just False + then deleteSupervisors uids + else return 0 + newSupers <- addDefaultSupervisors cid uids + addMessageI Info $ MsgFirmResetSupervision delSupers newSupers + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes siteLayout (citext2widget companyName) $ do setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId @@ -745,7 +772,33 @@ embedRenderMessage ''UniWorX ''FirmSuperAction id data FirmSuperActionData = FirmSuperActNotifyData | FirmSuperActRMSuperDefData | FirmSuperActRMSuperAllData - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + deriving (Eq, Ord, Read, Show, Generic) + + +data AddSupervisorRequest = AddSupervisorRequest + { asReqSupers :: Set Text + , asReqReroute :: Bool + , asReqPostal :: Maybe Bool + } deriving (Eq, Ord, Show, Generic) + +instance Default AddSupervisorRequest where + def = AddSupervisorRequest + { asReqSupers = mempty + , asReqReroute = True + , asReqPostal = Nothing + } + +postalEmailField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Bool +postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgUtilEMail) $ Just $ SomeMessage MsgUtilUnchanged + +makeAddSupervisorForm :: Maybe AddSupervisorRequest -> Form AddSupervisorRequest +makeAddSupervisorForm template html = do + flip (renderAForm FormStandard) html $ AddSupervisorRequest + <$> areq (textField & cfAnySeparatedSet) + (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) (asReqSupers <$> template) + <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (asReqReroute <$> template) + <*> aopt postalEmailField (fslI MsgASReqPostal & setTooltip MsgASReqPostalTip) (asReqPostal <$> template) + type SuperCompanyTableExpr = E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserCompany)) @@ -886,41 +939,59 @@ getFirmSupersR, postFirmSupersR :: CompanyShorthand -> Handler Html getFirmSupersR = postFirmSupersR postFirmSupersR fsh = do isAdmin <- hasReadAccessTo AdminR - let fshId = CompanyKey fsh + let cid = CompanyKey fsh (Company{..},(fsprRes,fsprTable)) <- runDB $ (,) - <$> get404 fshId - <*> mkFirmSuperTable isAdmin fshId + <$> get404 cid + <*> mkFirmSuperTable isAdmin cid formResult fsprRes $ \case - (FirmSuperActRMSuperDefData, fids) -> addMessage Info $ text2Html $ "Remove " <> tshow (length fids) <> " default supervisors. TODO" - (FirmSuperActRMSuperAllData, fids) -> addMessage Info $ text2Html $ "Make " <> tshow (length fids) <> " default and active supervisors. TODO" - (FirmSuperActNotifyData , fids) -> do - cuids <- traverse encrypt $ Set.toList fids :: Handler [CryptoUUIDUser] + (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice + (FirmSuperActRMSuperDefData, uids) -> do + nrRmSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False] + addMessageI Info $ MsgRemoveDefaultSupervisors nrRmSuper + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + (FirmSuperActRMSuperAllData, uids) -> addMessage Info $ text2Html $ "Make " <> tshow (length uids) <> " default and active supervisors. TODO" + (FirmSuperActNotifyData , uids) -> do + cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + ((asReqRes, asReqWgt), asReqEnctype) <- runFormPost . identifyForm FIDAddSupervisor $ makeAddSupervisorForm (Just def) + let addSuperAnchor = "add-supervisors-form" :: Text + routeAddSuperForm = FirmSupersR fsh :#: addSuperAnchor + addSuperForm = wrapForm asReqWgt FormSettings + { formMethod = POST + , formAction = Just . SomeRoute $ routeAddSuperForm + , formEncoding = asReqEnctype + , formAttrs = [] + , formSubmit = FormSubmit + , formAnchor = Just addSuperAnchor + } + formResult asReqRes $ \AddSupervisorRequest{..} -> do + avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser asReqSupers + let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers + usersFound = mapMaybe snd usersFound' + unless (null usersNotFound) $ + let msgContent = [whamlet| + $newline never +
      + $forall (usr,_) <- usersNotFound +
    • #{usr} + |] + in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) + when (null usersFound) $ do + addMessageI Warning MsgASReqEmpty + redirect routeAddSuperForm + runDB $ do + putMany [UserCompany uid cid True asReqReroute | uid <- usersFound] + whenIsJust asReqPostal $ \prefPostal -> + updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal] + addMessageI Info $ MsgASReqSetSupers (fromIntegral $ length usersFound) asReqPostal + redirect $ FirmSupersR fsh siteLayout (citext2widget fsh) $ do - setTitle $ citext2Html $ fsh <> " Supers" - -- TODO: factor out company info section hamlet here and from user table - [whamlet| -
      -

      !!!STUB!!!TO DO!!! -
      -
      - $maybe fem <- companyEmail -
      - _{MsgFirmEmail} #{iconLetterOrEmail False} -
      - #{mailtoHtml fem} - $maybe addr <- companyPostAddress -
      - _{MsgFirmAddress} #{iconLetterOrEmail True} -
      - #{addr} -
      - ^{fsprTable} - |] - + setTitle $ citext2Html $ fsh <> " Supers" + $(i18nWidgetFile "firm-supervisors") + getFirmCommR, postFirmCommR :: CompanyShorthand -> Handler Html getFirmCommR = postFirmCommR diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 28b1b9d32..f992e76d8 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -1498,7 +1498,20 @@ boolField mkNone = radioGroupField mkNone $ do _other -> Nothing } - +-- | like `boolField` but with custom labels +boolFieldCustom :: (MonadHandler m, HandlerSite m ~ UniWorX) + => SomeMessage UniWorX -> SomeMessage UniWorX -> Maybe (SomeMessage UniWorX) -> Field m Bool +boolFieldCustom mkTrue mkFalse mkNone = radioGroupField mkNone $ do + mr <- getMessageRender + return OptionList + { olOptions = [ Option (mr mkFalse) False "false" + , Option (mr mkTrue) True "true" + ] + , olReadExternal = \case + "false" -> Just False + "true" -> Just True + _other -> Nothing + } sectionedFuncForm :: forall f k v m sec. ( TraversableWithIndex k f diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 2d00d373e..69ec53464 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -316,6 +316,7 @@ data FormIdentifier | FIDBtnAvsImportUnknown | FIDBtnAvsRevokeUnknown | FIDHijackUser + | FIDAddSupervisor deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where diff --git a/templates/i18n/firm-supervisors/de-de-formal.hamlet b/templates/i18n/firm-supervisors/de-de-formal.hamlet new file mode 100644 index 000000000..d81248e80 --- /dev/null +++ b/templates/i18n/firm-supervisors/de-de-formal.hamlet @@ -0,0 +1,27 @@ +$newline never + +$# SPDX-FileCopyrightText: 2023 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +
      + Bitte beachten, dass Ansprechpartner-Beziehung unabhängig von Firmenzugehörigkeit zwischen Einzelpersonen bestehen. + Daraus folgt zum Beispiel, dass wenn x ein Standard-Ansprechpartner für Firma a ist + und wenn y sowohl Firma a als auch b angehört, + dass dann x als firmenfremd in der Liste der Ansprechpartner von Firma b angezeigt wird. +
      +
      + $maybe fem <- companyEmail +
      + _{MsgFirmEmail} #{iconLetterOrEmail False} +
      + #{mailtoHtml fem} + $maybe addr <- companyPostAddress +
      + _{MsgFirmAddress} #{iconLetterOrEmail True} +
      + #{addr} +
      + ^{fsprTable} +
      + ^{addSuperForm} \ No newline at end of file diff --git a/templates/i18n/firm-supervisors/en-eu.hamlet b/templates/i18n/firm-supervisors/en-eu.hamlet new file mode 100644 index 000000000..400fc543b --- /dev/null +++ b/templates/i18n/firm-supervisors/en-eu.hamlet @@ -0,0 +1,26 @@ +$newline never + +$# SPDX-FileCopyrightText: 2023 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +
      + Note that supervision is company independent. + For example, if x is a regular supervisor for company a and y belongs to companies a and b, + then x will be listed as a foreign supervisor for company b. +
      +
      + $maybe fem <- companyEmail +
      + _{MsgFirmEmail} #{iconLetterOrEmail False} +
      + #{mailtoHtml fem} + $maybe addr <- companyPostAddress +
      + _{MsgFirmAddress} #{iconLetterOrEmail True} +
      + #{addr} +
      + ^{fsprTable} +
      + ^{addSuperForm} From 4fa7385154852cbf838e8ce841a74de5501df46c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 17 Nov 2023 18:55:03 +0100 Subject: [PATCH 017/110] fix build --- src/Handler/Firm.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index c55eee0fb..a37f59caa 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -735,15 +735,14 @@ postFirmUsersR fsh = do formResult fusrRes $ \case (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice - (FirmUserActMkSuperData{..}, uids) -> do - nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. firmUserActMkSuperReroute] + (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do + nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)] addMessageI Info $ MsgASReqSetSupers nrMkSuper Nothing reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes (FirmUserActNotifyData , uids) -> do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) - (FirmUserActResetSupervisionData{..}, Set.toList -> uids') -> do - let uids = fromList uids' -- guaranteed to be non-empty due to first case clause + (FirmUserActResetSupervisionData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do -- set guaranteed to be non-empty due to first case clause runDB $ do delSupers <- if firmUserActResetKeepOldSupers == Just False then deleteSupervisors uids @@ -946,11 +945,11 @@ postFirmSupersR fsh = do formResult fsprRes $ \case (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice - (FirmSuperActRMSuperDefData, uids) -> do + (FirmSuperActRMSuperDefData, Set.toList -> uids) -> do nrRmSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False] addMessageI Info $ MsgRemoveDefaultSupervisors nrRmSuper reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes - (FirmSuperActRMSuperAllData, uids) -> addMessage Info $ text2Html $ "Make " <> tshow (length uids) <> " default and active supervisors. TODO" + (FirmSuperActRMSuperAllData, uids) -> addMessage Warning $ text2Html $ "TODO Make " <> tshow (length uids) <> " default and active supervisors. TODO" (FirmSuperActNotifyData , uids) -> do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) From 8f8b6d84ae8676d725f4dafd99f74d4d9a5f8024 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 17 Nov 2023 18:26:26 +0000 Subject: [PATCH 018/110] chore(release): 27.4.50 --- CHANGELOG.md | 15 +++++++++++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 19 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 7238033c9..08967c314 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,21 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [27.4.50](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.49...v27.4.50) (2023-11-17) + + +### Bug Fixes + +* **avs:** preserve unset pin passwords in update ([8c4f848](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8c4f848675e1125547d1fdfa05560affe4794118)) +* **build:** fix whitespace in routes ([a24e44e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a24e44efc9a20d3934d96640bb9e21b3b6d55b96)) +* **build:** minor ([954a239](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/954a23936a35ea6c32247d7e191312e63888c12d)) +* **firm:** add sql indices for frequent filters to greatly enhance performance ([63e6d94](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/63e6d94df2fd1ce879cb59d14bc854f3c2556586)) +* **firm:** firm messaging now works fine ([65cdc8d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/65cdc8ddfef19eb3a5578c536575f91ba9717a13)) +* **firm:** foreign supervisor counts correct and sortable ([601ce7a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/601ce7abdf2a392d30f1ff799a2338968be795f1)) +* **firm:** sending messages works, but not test messages ([42ff02d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/42ff02d27e431a8855db7bf3046a1b74d297e6da)) +* **lms:** improve sorting for firm all ([3865bda](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3865bda64d488c161b55e1f6eb48ca1b742dff98)) +* **lms:** LMS restart failing due to old LmsUser entry ([6761767](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6761767c6ca8cab62a22aa6f755e6231e07ab411)) + ## [27.4.49](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.48...v27.4.49) (2023-11-09) diff --git a/nix/docker/version.json b/nix/docker/version.json index ae41d9f2a..2140ac34f 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.49" + "version": "27.4.50" } diff --git a/package-lock.json b/package-lock.json index a24e9106c..0f9458042 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.49", + "version": "27.4.50", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index b11cc7651..06948aab1 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.49", + "version": "27.4.50", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 51bf68fd4..4cacc5a3b 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.49 +version: 27.4.50 dependencies: - base - yesod From 0f9a7a8c53d216ca7a6d0a25462b19ab1fa00bb4 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 20 Nov 2023 15:02:44 +0100 Subject: [PATCH 019/110] fix(firm): show default supervisors with no employees too --- src/Handler/Firm.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index a37f59caa..479b2009f 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -845,7 +845,8 @@ mkFirmSuperTable isAdmin cid = do where dbtSQLQuery = \(usr `E.LeftOuterJoin` usrCmp) -> do EL.on $ usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.?=. E.val cid - E.where_ $ E.exists $ firmQuerySupervisedBy cid Nothing usr + E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor) + E.||. E.exists (firmQuerySupervisedBy cid Nothing usr) return ( usr , usr & firmCountForSupervisor cid Nothing , usr & firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications)) From b7d6474acefbafb700241ec4cf60166965c1ac1c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 21 Nov 2023 13:33:12 +0100 Subject: [PATCH 020/110] refactor(firm): messaging performance --- src/Handler/Firm.hs | 89 +++++++++++++++++++-------------------------- src/Utils.hs | 3 ++ 2 files changed, 40 insertions(+), 52 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 479b2009f..1c2a8943a 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -1006,56 +1006,42 @@ postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR) handleFirmCommR :: SomeRoute UniWorX -> Companies -> Handler Html handleFirmCommR _ [] = invalidArgs ["At least one company name must be provided."] handleFirmCommR ultDest cs = do - let csKey = CompanyKey <$> cs - -- get employees of chosen companies - empys <- E.unValue <<$>> runDB (E.select $ do - (emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) - E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList csKey - return $ emp E.^. UserId - ) - -- get supervisors of employees - sprs <- E.unValue <<$>> runDB (E.select $ do - spr <- E.from $ E.table @User - E.where_ $ E.exists $ do - usrSpr <- E.from $ E.table @UserSupervisor - E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. spr E.^. UserId - E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList empys - return $ spr E.^. UserId - ) - -- get companies of all supervisors - sprCmpys <- E.unValue <<$>> runDB (E.select $ do - cmpy <- E.from $ E.table @Company - E.where_ $ E.exists $ do - usrCmpy <- E.from $ E.table @UserCompany - E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId - E.&&. usrCmpy E.^. UserCompanyUser `E.in_` E.valList sprs - return $ cmpy E.^.CompanyId - ) let - queryLoners :: E.SqlQuery (E.SqlExpr (Entity User)) -- get supervisors without any company affiliation - queryLoners = do - spr <- E.from $ E.table @User - E.where_ $ spr E.^. UserId `E.in_` E.valList empys - E.&&. E.notExists (do - sprCmp <- E.from $ E.table @UserCompany - E.where_ $ sprCmp E.^. UserCompanyUser E.==. spr E.^. UserId - ) - return spr - - queryCmpy :: Bool -> CompanyId -> E.SqlQuery (E.SqlExpr (Entity User)) - queryCmpy sORe acid = do - (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) - E.where_ $ uc E.^. UserCompanyCompany E.==. E.val acid - E.&&. (if sORe - then -- supervisors only - E.exists $ do - usrSpr <- E.from $ E.table @UserSupervisor - E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId - E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList empys - else E.true - ) + queryGiven :: [UserId] -> E.SqlQuery (E.SqlExpr (Entity User)) -- get users from a list of UserIds + queryGiven usrs = do + usr <- E.from $ E.table @User + E.where_ $ usr E.^. UserId `E.in_` E.valList usrs return usr - + mkCompanyUsrList :: [(E.Value (Maybe CompanyId), E.Value UserId)] -> Map.Map (Maybe CompanyId) [UserId] + mkCompanyUsrList l = Map.fromAscListWith (++) [(c,[u]) | (E.Value c, E.Value u) <- l] + toGrp = maybe RGFirmIndependent (RGFirmSupervisor . unCompanyKey) + csKeys = CompanyKey <$> cs + mbUser <- maybeAuthId + -- get employees of chosen companies + empys <- mkCompanyUsrList <$> runDB (E.select $ do + (emp :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& cmp) -> emp E.^. UserId E.==. cmp E.^. UserCompanyUser) + E.where_ $ cmp E.^. UserCompanyCompany `E.in_` E.valList csKeys + E.orderBy [E.ascNullsFirst $ cmp E.^. UserCompanyCompany] + return (E.just $ cmp E.^. UserCompanyCompany, emp E.^. UserId) + ) + -- get supervisors of employees + --sprs <- mkCompanyUsrList <$> runDB (E.select $ do + sprs' <- runDB (E.select $ do + (spr :& cmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(spr :& cmp) -> spr E.^. UserId E.=?. cmp E.?. UserCompanyUser) + E.where_ $ (E.isTrue (cmp E.?. UserCompanySupervisor) E.&&. cmp E.?. UserCompanyCompany `E.in_` E.justValList csKeys) + E.||. (spr E.^. UserId E.=?. E.val mbUser) + E.||. E.exists (do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. spr E.^. UserId + E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList (concat $ Map.elems empys) + ) + E.orderBy [E.ascNullsFirst $ cmp E.?. UserCompanyCompany] + return (cmp E.?. UserCompanyCompany, spr E.^. UserId) + ) + $logInfoS "Firm" "!!!Messaging here!!!" + unless (checkAsc (fst <$> sprs')) ($logErrorS "Firm" ("Supervisor list isn't ascending!!!" <> tshow (fst <$> sprs'))) -- TODO: REMOVE THIS CHECK AND THE FOLLOWING LINE FOR PRODUCTION !!! + let sprs = mkCompanyUsrList sprs' + commR CommunicationRoute { crHeading = SomeMessage $ case cs of { [c] -> MsgFirmNotification c ; _ -> MsgFirmsNotification } , crTitle = SomeMessage $ case cs of { [c] -> MsgFirmNotificationTitle c ; _ -> MsgFirmsNotificationTitle } @@ -1063,10 +1049,9 @@ handleFirmCommR ultDest cs = do , crJobs = crJobsFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () , crTestJobs = crTestFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () , crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult - , crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))] - [(RGFirmSupervisor $ unCompanyKey acid, queryCmpy True acid) | acid <- sprCmpys ] ++ - (RGFirmIndependent, queryLoners) : - [(RGFirmEmployees $ unCompanyKey acid, queryCmpy False acid) | acid <- csKey ] + , crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))] + [(toGrp acid, queryGiven usrs) | (acid, usrs) <- Map.toAscList sprs ] ++ + [(RGFirmEmployees $ unCompanyKey acid, queryGiven usrs) | (Just acid, usrs) <- Map.toAscList empys ] } {- Auswahlbox für Mitteilung: diff --git a/src/Utils.hs b/src/Utils.hs index 44b863ae9..6ec20b881 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -771,6 +771,9 @@ pattern NonEmpty :: forall a. a -> [a] -> NonEmpty a pattern NonEmpty x xs = x :| xs {-# COMPLETE NonEmpty #-} +checkAsc :: Ord a => [a] -> Bool +checkAsc (x:r@(y:_)) = x<=y && checkAsc r +checkAsc _ = True ---------- -- Sets -- From b9f2d3bda4fe80017c40438583e6e139a022fd0a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 21 Nov 2023 16:53:06 +0100 Subject: [PATCH 021/110] chore(firm): add setting for global communications cc --- src/Handler/Firm.hs | 8 ++------ src/Handler/Utils/Communication.hs | 14 +++++++++----- src/Settings.hs | 2 ++ 3 files changed, 13 insertions(+), 11 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 1c2a8943a..f8cf257dc 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -1025,8 +1025,7 @@ handleFirmCommR ultDest cs = do return (E.just $ cmp E.^. UserCompanyCompany, emp E.^. UserId) ) -- get supervisors of employees - --sprs <- mkCompanyUsrList <$> runDB (E.select $ do - sprs' <- runDB (E.select $ do + sprs <- mkCompanyUsrList <$> runDB (E.select $ do (spr :& cmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(spr :& cmp) -> spr E.^. UserId E.=?. cmp E.?. UserCompanyUser) E.where_ $ (E.isTrue (cmp E.?. UserCompanySupervisor) E.&&. cmp E.?. UserCompanyCompany `E.in_` E.justValList csKeys) E.||. (spr E.^. UserId E.=?. E.val mbUser) @@ -1037,10 +1036,7 @@ handleFirmCommR ultDest cs = do ) E.orderBy [E.ascNullsFirst $ cmp E.?. UserCompanyCompany] return (cmp E.?. UserCompanyCompany, spr E.^. UserId) - ) - $logInfoS "Firm" "!!!Messaging here!!!" - unless (checkAsc (fst <$> sprs')) ($logErrorS "Firm" ("Supervisor list isn't ascending!!!" <> tshow (fst <$> sprs'))) -- TODO: REMOVE THIS CHECK AND THE FOLLOWING LINE FOR PRODUCTION !!! - let sprs = mkCompanyUsrList sprs' + ) commR CommunicationRoute { crHeading = SomeMessage $ case cs of { [c] -> MsgFirmNotification c ; _ -> MsgFirmsNotification } diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index d94f79706..70c8e45e2 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -139,7 +139,7 @@ commR CommunicationRoute{..} = do decrypt' cID = do uid <- decrypt cID whenIsJust crRecipientAuth $ guardAuthResult <=< ($ uid) - getEntity uid + getEntity uid cUser <- maybeAuth (chosenRecipients, suggestedRecipients) <- runDB $ (,) <$> (maybe id cons cUser . catMaybes <$> (mapM decrypt' =<< lookupGlobalGetParams GetRecipient)) @@ -148,7 +148,8 @@ commR CommunicationRoute{..} = do MsgRenderer mr <- getMsgRenderer mbCurrentRoute <- getCurrentRoute - + globalCC <- getsYesod $ view _appCommunicationGlobalCC + let lookupUser :: UserId -> (UserDisplayName,UserSurname) lookupUser = @@ -156,7 +157,7 @@ commR CommunicationRoute{..} = do usrNames Nothing = ("???","???") -- this case only happens during runFormPost when POST Data is present and no form is display usrNames (Just User{userDisplayName, userSurname}) = (userDisplayName, userSurname) in usrNames . flip Map.lookup usrMap - + chosenRecipients' = Map.fromList $ [ ( (BoundedPosition $ RecipientGroup g, pos) , (Right recp, recp `elem` map entityKey chosenRecipients) @@ -165,9 +166,12 @@ commR CommunicationRoute{..} = do , (pos, recp) <- zip [0..] $ map entityKey recps ] ++ [ ( (BoundedPosition RecipientCustom, pos) - , (Right recp, True) + , (recp, True) ) - | (pos, recp) <- zip [0..] . Set.toList $ Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ view _2 <$> suggestedRecipients) + | (pos, recp) <- zip [0..] + ( mcons (Left <$> globalCC) + (Right <$> Set.toList (Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ view _2 <$> suggestedRecipients))) + ) ] activeCategories = map RecipientGroup (view _1 <$> suggestedRecipients) `snoc` RecipientCustom diff --git a/src/Settings.hs b/src/Settings.hs index 5b6c139cb..0916f439f 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -245,6 +245,7 @@ data AppSettings = AppSettings , appJobMaxFlush :: Maybe Natural , appCommunicationAttachmentsMaxSize :: Maybe Natural + , appCommunicationGlobalCC :: Maybe UserEmail , appFileChunkingParams :: FastCDCParameters @@ -804,6 +805,7 @@ instance FromJSON AppSettings where appJobMaxFlush <- o .:? "job-max-flush" appCommunicationAttachmentsMaxSize <- o .:? "communication-attachments-max-size" + appCommunicationGlobalCC <- o .:? "communication-global-cc" appLegalExternal <- o .: "legal-external" From 83bab6b86bd4743114c733ac952dee9539e97938 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 21 Nov 2023 18:45:51 +0100 Subject: [PATCH 022/110] chore(firm): implement fix #67 Maske Firmen --- .../uniworx/categories/firm/de-de-formal.msg | 9 +- messages/uniworx/categories/firm/en-eu.msg | 9 +- .../utils/table_column/de-de-formal.msg | 3 +- messages/uniworx/utils/table_column/en-eu.msg | 3 +- src/Handler/Firm.hs | 86 +++++++++++++++---- src/Handler/Utils/Table/Cells.hs | 10 +++ src/Utils/Form.hs | 1 + src/Utils/Icon.hs | 4 +- templates/firm-users.hamlet | 5 +- 9 files changed, 103 insertions(+), 27 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 49fc0d066..8c9cf7a8e 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -16,7 +16,7 @@ FirmUserActMkSuper: Zum Firmenansprechpartner ernennen FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{bool mempty (", " <> tshow rem <> " zuvor gelöscht") (rem > 0)} FirmSuperActNotify: Mitteilung versenden FirmSuperActRMSuperDef: Standard Firmenansprechpartner entfernen -FirmSuperActRMSuperAll: Als aktiven Ansprechpartner komplett entfernen +FirmSuperActRMSuperActive: Auch aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden FirmsNotification: Firmen Benachrichtigung versenden FirmNotification fsh@CompanyShorthand: Benachrichtigung an #{fsh} versenden FirmsNotificationTitle: Firmen benachrichtigen @@ -32,8 +32,9 @@ FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh} NoCompanySelected: Bitte wählen Sie mindestens eine Firm aus. TableIsDefaultSupervisor: Standardansprechpartner TableIsDefaultReroute: Standardumleitung -ASReqPostal: Benachrichtigungseinstellung -ASReqPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner +FormReqPostal: Benachrichtigungseinstellung +FormReqPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner ASReqEmpty: Es konnten keine Ansprechpartner hinzugefügt werden ASReqSetSupers n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner eingetragen #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert. -RemoveDefaultSupervisors n@Int64: #{n} Standard Ansprechpartner entfernt, aber noch nicht deaktiviert. \ No newline at end of file +RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber noch nicht deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)} +FirmUserChanges n@Int64: Benachrichtigungseinstellung für #{n} Firmenangehörige wurden geändert \ No newline at end of file diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 39e46d552..0d7ef77eb 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -16,7 +16,7 @@ FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> FirmUserActMkSuper: Mark as company supervisor FirmSuperActNotify: Send message FirmSuperActRMSuperDef: Remove as default supervisor -FirmSuperActRMSuperAll: Remove all active supervisions for this company +FirmSuperActRMSuperActive: Also remove active supervisions within this company FirmsNotification: Send company notification FirmNotification fsh: Send notification to company #{fsh} FirmsNotificationTitle: Company notification @@ -32,8 +32,9 @@ FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users NoCompanySelected: Select at least one company, please. TableIsDefaultSupervisor: Default supervisor TableIsDefaultReroute: Default reroute -ASReqPostal: Notification type -ASReqPostalTip: Affects all notifications to this person, not just reroutes to this supervisor +FormReqPostal: Notification type +FormReqPostalTip: Affects all notifications to this person, not just reroutes to this supervisor ASReqEmpty: No supervisors added ASReqSetSupers n postal: #{n} default company supervisors set #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated. -RemoveDefaultSupervisors n: #{n} default supervisors removed, but not yet deactivated. \ No newline at end of file +RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisons terminated") (nact > 0)} +FirmUserChanges n: Notification settings changed for #{n} company associates \ No newline at end of file diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 295648b7e..71e251d18 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -104,4 +104,5 @@ TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} Jobs entfernt TableFilterComma: Es können mehrere alternative Suchkriterien mit Komma getrennt angegeben werden, wovon mindestens eines erfüllt werden muss. TableFilterCommaPlus: Mehrere alternative Suchkriterien mit Komma trennen. Mindestens ein Suchkriterium muss erfüllt werden, zusätzlich zu allen Suchkriterien mit vorangestelltem Plus-Symbol. TableFilterCommaName: Mehrere Namen mit Komma trennen. -TableFilterCommaNameNr: Mehrere Namen oder Nummern mit Komma trennen. Nummern werden nur exakt gesucht. \ No newline at end of file +TableFilterCommaNameNr: Mehrere Namen oder Nummern mit Komma trennen. Nummern werden nur exakt gesucht. +TableUserEdit: Benutzer bearbeiten \ No newline at end of file diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 3b7962522..b000a6d7d 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -104,4 +104,5 @@ TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} queued jobs deleted TableFilterComma: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled. TableFilterCommaPlus: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled in addition to all criteria preceded by a plus symbol. TableFilterCommaName: Separate names by comma. -TableFilterCommaNameNr: Separate names and numbers by comma. Numbers have to match exact. \ No newline at end of file +TableFilterCommaNameNr: Separate names and numbers by comma. Numbers have to match exact. +TableUserEdit: Edit user \ No newline at end of file diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index f8cf257dc..f102c1734 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -50,7 +50,10 @@ encryptUser = encrypt --------------------------- -- Firm specific utilities --- for filters and counts see before FirmAllR Handlers +-- for filters and counts also see before FirmAllR Handlers + +postalEmailField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Bool +postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgUtilEMail) $ Just $ SomeMessage MsgUtilUnchanged -- remove supervisors: deleteSupervisors :: NonEmpty UserId -> DB Int64 @@ -501,6 +504,25 @@ postFirmAllR = do ----------------------- -- Firm Users Table +data FirmUserChangeRequest = FirmUserChangeRequest + { fucrPostalPref :: Maybe Bool + , fucrPostalAddr :: Maybe StoredMarkup + } + deriving (Eq, Ord, Show, Generic) + +instance Default FirmUserChangeRequest where + def = FirmUserChangeRequest + { fucrPostalPref = Nothing + , fucrPostalAddr = Nothing + } + +makeFirmUserChangeRequestForm :: Maybe FirmUserChangeRequest -> Form FirmUserChangeRequest +makeFirmUserChangeRequestForm template html = do + flip (renderAForm FormStandard) html $ FirmUserChangeRequest + <$> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) (fucrPostalPref <$> template) + <*> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) (fucrPostalAddr <$> template) + + data FirmUserAction = FirmUserActNotify | FirmUserActResetSupervision | FirmUserActMkSuper @@ -518,7 +540,7 @@ data FirmUserActionData = FirmUserActNotifyData | FirmUserActMkSuperData { firmUserActMkSuperReroute :: Maybe Bool } - deriving (Eq, Ord, Read, Show, Generic) + deriving (Eq, Ord, Show, Generic) type UserCompanyTableExpr = E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity UserCompany) @@ -584,6 +606,7 @@ mkFirmUserTable isAdmin cid = do , sortable (Just "reroutes") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultUserCompanyReroutes -> nr) -> wgtCell $ word2widget nr , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUserUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b , colUserEmail + , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultUserUser -> entUsr) -> cellEditUserModal entUsr ] dbtSorting = mconcat [ single $ sortUserNameLink queryUserUser @@ -750,6 +773,29 @@ postFirmUsersR fsh = do newSupers <- addDefaultSupervisors cid uids addMessageI Info $ MsgFirmResetSupervision delSupers newSupers reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + + ((fucrRes, fucrWgt), fucrEnctype) <- runFormPost . identifyForm FIDFirmUserChangeRequest $ makeFirmUserChangeRequestForm (Just def) + let addFormAnchor = "firm-user-change-form" :: Text + routeForm = FirmUsersR fsh :#: addFormAnchor + fucrForm = wrapForm fucrWgt FormSettings + { formMethod = POST + , formAction = Just . SomeRoute $ routeForm + , formEncoding = fucrEnctype + , formAttrs = [] + , formSubmit = FormSubmit + , formAnchor = Just addFormAnchor + } + formResult fucrRes $ \FirmUserChangeRequest{..} -> when (isJust fucrPostalAddr || isJust fucrPostalAddr) $ do + let changes = foldMap (\pp -> [UserPrefersPostal E.=. E.val pp]) fucrPostalPref <> + foldMap (\pa -> [UserPostAddress E.=. E.justVal pa]) fucrPostalAddr -- seems weird, but: Nothing means no change, and not delete address! + nrChanged <- runDB $ E.updateCount $ \usr -> do + E.set usr changes + E.where_ $ E.exists $ do + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid + E.&&. usrCmpy E.^. UserCompanyUser E.==. usr E.^. UserId + addMessageI Info $ MsgFirmUserChanges nrChanged + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes siteLayout (citext2widget companyName) $ do setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId @@ -761,7 +807,7 @@ postFirmUsersR fsh = do data FirmSuperAction = FirmSuperActNotify | FirmSuperActRMSuperDef - | FirmSuperActRMSuperAll + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -770,8 +816,9 @@ embedRenderMessage ''UniWorX ''FirmSuperAction id data FirmSuperActionData = FirmSuperActNotifyData | FirmSuperActRMSuperDefData - | FirmSuperActRMSuperAllData - deriving (Eq, Ord, Read, Show, Generic) + { firmSuperActRMSuperActive :: Maybe Bool } + + deriving (Eq, Ord, Show, Generic) data AddSupervisorRequest = AddSupervisorRequest @@ -787,16 +834,13 @@ instance Default AddSupervisorRequest where , asReqPostal = Nothing } -postalEmailField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Bool -postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgUtilEMail) $ Just $ SomeMessage MsgUtilUnchanged - makeAddSupervisorForm :: Maybe AddSupervisorRequest -> Form AddSupervisorRequest makeAddSupervisorForm template html = do flip (renderAForm FormStandard) html $ AddSupervisorRequest <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) (asReqSupers <$> template) <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (asReqReroute <$> template) - <*> aopt postalEmailField (fslI MsgASReqPostal & setTooltip MsgASReqPostalTip) (asReqPostal <$> template) + <*> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) (asReqPostal <$> template) type SuperCompanyTableExpr = E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserCompany)) @@ -874,6 +918,7 @@ mkFirmSuperTable isAdmin cid = do , sortable (Just "rerouted") (i18nCell MsgTableCompanyNrEmpRerouted ) $ \(view resultSuperCompanyReroutes -> nr) -> wgtCell $ word2widget nr , sortable (Just "def-super") (i18nCell MsgTableIsDefaultSupervisor) $ \(view resultSuperCompanyDefaultSuper -> mb) -> case mb of { Nothing -> iconCell IconSupervisorForeign; Just True -> iconCell IconSupervisor; Just False -> iconSpacerCell } , sortable (Just "def-reroute") (i18nCell MsgTableIsDefaultReroute) $ \(view resultSuperCompanyDefaultReroute -> mb) -> tickmarkCell (mb == Just True) + , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultSuperUser -> entUsr) -> cellEditUserModal entUsr ] dbtSorting = mconcat [ single $ sortUserNameLink querySuperUser @@ -902,8 +947,8 @@ mkFirmSuperTable isAdmin cid = do acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData) acts = mconcat [ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData - , singletonMap FirmSuperActRMSuperDef $ pure FirmSuperActRMSuperDefData - , singletonMap FirmSuperActRMSuperAll $ pure FirmSuperActRMSuperAllData + , singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData + <$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True) ] dbtParams = DBParamsForm { dbParamsFormMethod = POST @@ -946,11 +991,22 @@ postFirmSupersR fsh = do formResult fsprRes $ \case (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice - (FirmSuperActRMSuperDefData, Set.toList -> uids) -> do - nrRmSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False] - addMessageI Info $ MsgRemoveDefaultSupervisors nrRmSuper + (FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do + (nrRmSuper,nrRmActual) <- runDB $ (,) + <$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False] + <*> if firmSuperActRMSuperActive /= Just True + then return 0 + else E.deleteCount $ do + spr <- E.from $ E.table @UserSupervisor + E.where_ $ spr E.^. UserSupervisorSupervisor `E.in_` E.vals uids + E.&&. E.exists (do + usr <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid + E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser + ) + addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes - (FirmSuperActRMSuperAllData, uids) -> addMessage Warning $ text2Html $ "TODO Make " <> tshow (length uids) <> " default and active supervisors. TODO" + (FirmSuperActNotifyData , uids) -> do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index cf5051ef5..2dee91389 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -229,6 +229,16 @@ cellHasUserModal toLink user = modal nWdgt (Left $ SomeRoute $ toLink uuid) in cell lWdgt +-- | like `cellHasUserModal` but with fixed route and showing an edit icon instead +cellEditUserModal :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c +cellEditUserModal user = + let userEntity = user ^. hasEntityUser + uid = userEntity ^. _entityKey + nWdgt = toWidget $ icon IconUserEdit + lWdgt = do + uuid <- liftHandler $ encrypt uid + modal nWdgt (Left $ SomeRoute $ ForProfileR uuid) + in cell lWdgt cellHasMatrikelnummer :: (IsDBTable m a, HasUser u) => u -> DBCell m a cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 69ec53464..43b1ad82d 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -317,6 +317,7 @@ data FormIdentifier | FIDBtnAvsRevokeUnknown | FIDHijackUser | FIDAddSupervisor + | FIDFirmUserChangeRequest deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 0018e74e0..fb2771e85 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -116,6 +116,7 @@ data Icon | IconUnlocked | IconResetTries -- also see IconReset | IconCompany + | IconUserEdit deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic) deriving anyclass (Universe, Finite, NFData) @@ -209,7 +210,8 @@ iconText = \case IconLocked -> "lock" IconUnlocked -> "lock-open-alt" IconResetTries -> "trash-undo" - IconCompany -> "building" + IconCompany -> "building" + IconUserEdit -> "user-edit" nullaryPathPiece ''Icon $ camelToPathPiece' 1 deriveLift ''Icon diff --git a/templates/firm-users.hamlet b/templates/firm-users.hamlet index 9acaf1c2f..981255a1f 100644 --- a/templates/firm-users.hamlet +++ b/templates/firm-users.hamlet @@ -65,4 +65,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

      _{MsgFirmAssociates}

      - ^{fusrTable} \ No newline at end of file + ^{fusrTable} + +

      + ^{fucrForm} \ No newline at end of file From 5163ed06c6b6e0652ba2f137f7350483470e1078 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 21 Nov 2023 18:49:33 +0100 Subject: [PATCH 023/110] fix(build) --- src/Handler/Firm.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index f102c1734..d4e9176f6 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -785,7 +785,7 @@ postFirmUsersR fsh = do , formSubmit = FormSubmit , formAnchor = Just addFormAnchor } - formResult fucrRes $ \FirmUserChangeRequest{..} -> when (isJust fucrPostalAddr || isJust fucrPostalAddr) $ do + formResult fucrRes $ \FirmUserChangeRequest{..} -> when (isJust fucrPostalPref || isJust fucrPostalAddr) $ do let changes = foldMap (\pp -> [UserPrefersPostal E.=. E.val pp]) fucrPostalPref <> foldMap (\pa -> [UserPostAddress E.=. E.justVal pa]) fucrPostalAddr -- seems weird, but: Nothing means no change, and not delete address! nrChanged <- runDB $ E.updateCount $ \usr -> do From cf5759bc606779548dbec9a6786764fec3b9c80e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 22 Nov 2023 17:02:12 +0100 Subject: [PATCH 024/110] chore(firm): hide general actions --- templates/firm-users.hamlet | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/templates/firm-users.hamlet b/templates/firm-users.hamlet index 981255a1f..2346ac4dd 100644 --- a/templates/firm-users.hamlet +++ b/templates/firm-users.hamlet @@ -68,4 +68,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{fusrTable}
      - ^{fucrForm} \ No newline at end of file +

      + Heading TODO +
      + ^{fucrForm} \ No newline at end of file From 4ae59fc1fa658e1462139ddddd6dc80308d85872 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 22 Nov 2023 17:03:01 +0100 Subject: [PATCH 025/110] fix(cache): remove risky caching for submissions --- src/Handler/Submission/List.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Submission/List.hs b/src/Handler/Submission/List.hs index 72c17f0e5..4590b9f48 100644 --- a/src/Handler/Submission/List.hs +++ b/src/Handler/Submission/List.hs @@ -397,7 +397,7 @@ colSubmissionLink = sortable (Just "submission") (i18nCell MsgTableSubmission) $ csh = x ^. resultCourseShorthand shn = x ^. resultSheet . _entityVal . _sheetName subCID = x ^. resultCryptoID - in anchorCellC $cacheIdentHere (CSubmissionR tid ssh csh shn subCID SubShowR) (toPathPiece subCID) + in anchorCell (CSubmissionR tid ssh csh shn subCID SubShowR) (toPathPiece subCID) 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 From 7fc6e431311979919d8d753a6a6d4651668d64b7 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 22 Nov 2023 17:58:03 +0100 Subject: [PATCH 026/110] chore(profile): allow editing phone numbers --- models/users.model | 2 +- src/Handler/Profile.hs | 22 ++++++++++++++++------ src/Utils.hs | 6 ++++++ 3 files changed, 23 insertions(+), 7 deletions(-) diff --git a/models/users.model b/models/users.model index 8a686feac..b29f71eb3 100644 --- a/models/users.model +++ b/models/users.model @@ -34,7 +34,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create timeFormat DateTimeFormat "default='%R'" -- preferred Time-only display format for user; user-defined downloadFiles Bool default=false -- Should files be opened in browser or downloaded? (users often oblivious that their browser has a setting for this) languages Languages Maybe -- Preferred language; user-defined - notificationSettings NotificationSettings "default='{}'::jsonb" -- Bit-array for which events email notifications are requested by user; user-defined + notificationSettings NotificationSettings "default='{}'::jsonb" -- Bit-array for which events email notifications are requested by user; user-defined; missing fields in json object will be parsed to default trigger warningDays NominalDiffTime default=1209600 -- timedistance to pending deadlines for homepage infos csvOptions CsvOptions "default='{}'::jsonb" sex Sex Maybe -- currently ignored diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index e0a12e0b1..a92c54571 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -70,6 +70,9 @@ data SettingsForm = SettingsForm , stgPrefersPostal :: Bool , stgPostAddress :: Maybe StoredMarkup + , stgTelephone :: Maybe Text + , stgMobile :: Maybe Text + , stgExamOfficeSettings :: ExamOfficeSettings , stgSchools :: Set SchoolId , stgNotificationSettings :: NotificationSettings @@ -129,9 +132,12 @@ makeSettingForm template html = do <*> apopt checkBoxField (fslI MsgShowSex & setTooltip MsgShowSexTip) (stgShowSex <$> template) <* aformSection MsgFormNotifications - <*> aopt (textField & cfStrip) (fslI MsgPDFPassword & setTooltip MsgPDFPasswordTip) (stgPinPassword <$> template) + <*> aopt (textField & cfStrip) (fslI MsgPDFPassword & setTooltip MsgPDFPasswordTip) (stgPinPassword <$> template) <*> apopt checkBoxField (fslI MsgPrefersPostalExp & setTooltip MsgPostalTip) (stgPrefersPostal <$> template) - <*> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) (stgPostAddress <$> template) + <*> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) (stgPostAddress <$> template) + + <*> aopt (textField & cfStrip) (fslI MsgUserTelephone) (stgTelephone <$> template) + <*> aopt (textField & cfStrip) (fslI MsgUserMobile ) (stgMobile <$> template) <*> examOfficeForm (stgExamOfficeSettings <$> template) <*> schoolsForm (stgSchools <$> template) @@ -362,14 +368,14 @@ validateSettings User{..} = do validEmail' userDisplayEmail' userPostAddress' <- use _stgPostAddress - let postalNotSet = isNothing userPostAddress' + let postalNotSet = isNothing userPostAddress' -- TODO $ canonical userPostAddress' postalIsValid = validPostAddress userPostAddress' guardValidation MsgUserPostalInvalid $ postalNotSet || postalIsValid userPrefersPostal' <- use _stgPrefersPostal guardValidation MsgUserPrefersPostalInvalid $ - not $ userPrefersPostal' && (postalNotSet || isJust userCompanyDepartment) + not $ userPrefersPostal' && postalNotSet && isNothing userCompanyDepartment userPinPassword' <- use _stgPinPassword let pinBad = validCmdArgument =<< userPinPassword' @@ -439,6 +445,8 @@ serveProfileR (uid, user@User{..}) = do , stgPinPassword = userPinPassword , stgPostAddress = userPostAddress , stgPrefersPostal = userPrefersPostal + , stgTelephone = userTelephone + , stgMobile = userMobile , stgExamOfficeSettings = ExamOfficeSettings { eosettingsGetSynced = userExamOfficeGetSynced , eosettingsGetLabels = userExamOfficeGetLabels @@ -467,9 +475,11 @@ serveProfileR (uid, user@User{..}) = do , UserWarningDays =. stgWarningDays , UserNotificationSettings =. stgNotificationSettings , UserShowSex =. stgShowSex - , UserPinPassword =. stgPinPassword - , UserPostAddress =. stgPostAddress + , UserPinPassword =. stgPinPassword -- TODO & canonical + , UserPostAddress =. stgPostAddress -- TODO & canonical , UserPrefersPostal =. stgPrefersPostal + , UserTelephone =. stgTelephone & canonical + , UserMobile =. stgMobile & canonical , UserExamOfficeGetSynced =. (stgExamOfficeSettings & eosettingsGetSynced) , UserExamOfficeGetLabels =. (stgExamOfficeSettings & eosettingsGetLabels) ] diff --git a/src/Utils.hs b/src/Utils.hs index 6ec20b881..b879a2164 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1986,3 +1986,9 @@ instance {-# OVERLAPPABLE #-} (Canonical mono, MonoFoldable mono, Eq mono) => Ca -- this instance is more of a convenient abuse of the class (expand to Foldable) instance (Ord a, Canonical a) => Canonical (Set a) where canonical = Set.map canonical + +instance Canonical (Maybe Text) where + canonical Nothing = Nothing + canonical (Just t) = + let t' = Text.strip t + in if Text.null t' then Nothing else Just t' From c5c4a62de0c92bde660f177d062c4874e232d8bc Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 22 Nov 2023 17:59:15 +0100 Subject: [PATCH 027/110] chore(firm): various - multiSelectField working - section hiding demo working - modal links access rights checking --- src/Handler/Firm.hs | 35 +++++++++++++++++++------------- src/Handler/Utils/Table/Cells.hs | 19 +++++++++-------- src/Handler/Utils/Widgets.hs | 9 ++++++++ src/Utils/Frontend/Modal.hs | 2 +- 4 files changed, 42 insertions(+), 23 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index d4e9176f6..9e4c7655d 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -325,7 +325,12 @@ mkFirmAllTable isAdmin uid = do unless isAdmin $ E.where_ $ E.exists $ do -- only show associated companies usrCmpy <- E.from $ E.table @UserCompany E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId - E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid + E.&&. ((usrCmpy E.^. UserCompanyUser E.==. E.val uid E.&&. usrCmpy E.^. UserCompanySupervisor) + E.||. E.exists (do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmpy E.^. UserCompanyUser + E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid + )) return ( cmpy -- 1 , cmpy & firmCountUsers -- 2 , cmpy & firmHasSupervisors -- 3 @@ -598,7 +603,7 @@ mkFirmUserTable isAdmin cid = do dbtRowKey = queryUserUser >>> (E.^. UserId) dbtProj = dbtProjId dbtColonnade = formColonnade $ mconcat - [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey)) + [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey)) , colUserNameModalHdr MsgTableCompanyUser ForProfileDataR , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinked entUsr , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultUserUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t @@ -676,7 +681,7 @@ mkFirmUserTable isAdmin cid = do dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) - -- , prismAForm (multiFilter "supervisors-are" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor) + , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor) , prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor) , prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh) , prismAForm (singletonFilter "has-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorForeign fsh) @@ -785,17 +790,19 @@ postFirmUsersR fsh = do , formSubmit = FormSubmit , formAnchor = Just addFormAnchor } - formResult fucrRes $ \FirmUserChangeRequest{..} -> when (isJust fucrPostalPref || isJust fucrPostalAddr) $ do - let changes = foldMap (\pp -> [UserPrefersPostal E.=. E.val pp]) fucrPostalPref <> - foldMap (\pa -> [UserPostAddress E.=. E.justVal pa]) fucrPostalAddr -- seems weird, but: Nothing means no change, and not delete address! - nrChanged <- runDB $ E.updateCount $ \usr -> do - E.set usr changes - E.where_ $ E.exists $ do - usrCmpy <- E.from $ E.table @UserCompany - E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid - E.&&. usrCmpy E.^. UserCompanyUser E.==. usr E.^. UserId - addMessageI Info $ MsgFirmUserChanges nrChanged - reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + formResult fucrRes $ \FirmUserChangeRequest{fucrPostalPref=fucrPPref, fucrPostalAddr=fucrPAddr} -> do + -- let fucrPAddr = canonical fucrPAddr' TODO + when (isJust fucrPPref || isJust fucrPAddr) $ do + let changes = foldMap (\pp -> [UserPrefersPostal E.=. E.val pp]) fucrPPref <> + foldMap (\pa -> [UserPostAddress E.=. E.justVal pa]) fucrPAddr -- seems weird, but: Nothing means no change, and not delete address! + nrChanged <- runDB $ E.updateCount $ \usr -> do + E.set usr changes + E.where_ $ E.exists $ do + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid + E.&&. usrCmpy E.^. UserCompanyUser E.==. usr E.^. UserId + addMessageI Info $ MsgFirmUserChanges nrChanged + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes siteLayout (citext2widget companyName) $ do setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 2dee91389..2cab48fc2 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -226,7 +226,7 @@ cellHasUserModal toLink user = nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname) lWdgt = do uuid <- liftHandler $ encrypt uid - modal nWdgt (Left $ SomeRoute $ toLink uuid) + modalAccess False nWdgt nWdgt $ toLink uuid in cell lWdgt -- | like `cellHasUserModal` but with fixed route and showing an edit icon instead @@ -234,10 +234,10 @@ cellEditUserModal :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c cellEditUserModal user = let userEntity = user ^. hasEntityUser uid = userEntity ^. _entityKey - nWdgt = toWidget $ icon IconUserEdit + nWdgt = toWidget $ icon IconUserEdit lWdgt = do uuid <- liftHandler $ encrypt uid - modal nWdgt (Left $ SomeRoute $ ForProfileR uuid) + modalAccess True nWdgt mempty $ ForProfileR uuid in cell lWdgt cellHasMatrikelnummer :: (IsDBTable m a, HasUser u) => u -> DBCell m a cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer @@ -246,7 +246,7 @@ cellHasMatrikelnummerLinked :: (IsDBTable m a, HasEntity u User) => u -> DBCell cellHasMatrikelnummerLinked usr | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey - modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid) + modalAccess False (text2widget matNr) mempty (AdminAvsUserR uuid) | otherwise = mempty where usrEntity = usr ^. hasEntityUser @@ -364,7 +364,7 @@ qualificationValidUntilCell' mbToLink d qb qu = cell $ case mbToLink of Nothing -> headWgt <> dateWgt Just toLink -> do uuid <- liftHandler $ encrypt $ qu ^. hasQualificationUser . _qualificationUserUser - let modalWgt = modal dateWgt (Left $ SomeRoute $ toLink uuid) + let modalWgt = modalAccess False dateWgt dateWgt $ toLink uuid headWgt <> modalWgt where dateWgt = formatTimeW SelFormatDate (qu ^. hasQualificationUser . _qualificationUserValidUntil) @@ -385,7 +385,8 @@ qualificationValidReasonCell' mbToLink showReason d qb qu = ic <> foldMap blc qb dc tstamp | Just toLink <- mbToLink = cell $ do uuid <- liftHandler $ encrypt uid - modal (formatTimeW SelFormatDate tstamp) (Left $ SomeRoute $ toLink uuid) + let dWgt = formatTimeW SelFormatDate tstamp + modalAccess False dWgt dWgt $ toLink uuid -- anchorCellM (toLink <$> encrypt uid) | otherwise = dateCell tstamp uid = qu ^. hasQualificationUser . _qualificationUserUser @@ -403,7 +404,8 @@ qualificationValidReasonCell'' mbToLink showReason d qb qu extValid = ic <> icEr dc tstamp | Just toLink <- mbToLink = cell $ do uuid <- liftHandler $ encrypt uid - modal (formatTimeW SelFormatDate tstamp) (Left $ SomeRoute $ toLink uuid) + let dWgt = formatTimeW SelFormatDate tstamp + modalAccess False dWgt dWgt $ toLink uuid -- anchorCellM (toLink <$> encrypt uid) | otherwise = dateCell tstamp uid = qu ^. hasQualificationUser . _qualificationUserUser @@ -463,7 +465,8 @@ avsPersonNoCell = numCell . view _userAvsNoPerson avsPersonNoLinkedCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c avsPersonNoLinkedCell a = cell $ do uuid <- liftHandler $ encrypt $ a ^. _userAvsUser - modal (toWgt $ toMessage $ a ^. _userAvsNoPerson) (Left $ SomeRoute $ AdminAvsUserR uuid) + let nWgt = toWgt $ toMessage $ a ^. _userAvsNoPerson + modalAccess False nWgt nWgt $ AdminAvsUserR uuid avsPersonCardCell :: (IsDBTable m c) => Set AvsDataPersonCard -> DBCell m c avsPersonCardCell cards = wgtCell diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index 23a4b3a37..61c3c298e 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -123,6 +123,15 @@ editedByW fmt tm usr = do [whamlet|_{MsgUtilEditedBy usr ft}|] +-- | like `modal`, but checks access rights to the link +modalAccess :: Bool -> Widget -> Widget -> Route UniWorX -> Widget +modalAccess writeAccess wdgtYes wdgtNo route = do + authOk <- liftHandler $ bool hasReadAccessTo hasWriteAccessTo writeAccess route + if authOk + then modal wdgtYes (Left $ SomeRoute route) + else wdgtNo + + ---------- -- HEAT -- ---------- diff --git a/src/Utils/Frontend/Modal.hs b/src/Utils/Frontend/Modal.hs index c7c3ad8d0..304326ccc 100644 --- a/src/Utils/Frontend/Modal.hs +++ b/src/Utils/Frontend/Modal.hs @@ -38,7 +38,7 @@ customModal Modal{..} = do route <- traverse toTextUrl $ modalContent ^? _Left modalTrigger route triggerId' --- | Create a link to a modal +-- | Create a link to a modal, does not check link, see `Handler.Utils.Widget.modalAccess` for a checking variant modal :: WidgetFor site () -- ^ Widget that represents the link -> Either (SomeRoute site) (WidgetFor site ()) -- ^ Modal contant: either dynamic link or static widget -> WidgetFor site () -- ^ result widget From 400a3449c5e68994ba0e872b590bef9c0acaf728 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 23 Nov 2023 13:27:57 +0100 Subject: [PATCH 028/110] refactor(firm): fix build too --- .../uniworx/categories/firm/de-de-formal.msg | 2 ++ messages/uniworx/categories/firm/en-eu.msg | 2 ++ src/Handler/Firm.hs | 2 ++ src/Handler/Profile.hs | 8 +++---- src/Model/Types/Markup.hs | 7 ++++++ src/Utils.hs | 11 +++++---- templates/firm-contact-info.hamlet | 23 +++++++++++++++++++ templates/firm-users.hamlet | 13 +---------- .../i18n/firm-supervisors/de-de-formal.hamlet | 16 ++++--------- templates/i18n/firm-supervisors/en-eu.hamlet | 16 ++++--------- 10 files changed, 55 insertions(+), 45 deletions(-) create mode 100644 templates/firm-contact-info.hamlet diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 8c9cf7a8e..5d81a2b03 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -3,6 +3,8 @@ # SPDX-License-Identifier: AGPL-3.0-or-later FirmAssociates: Firmenangehörige +FirmContact: Firmenkontakt +FirmNoContact: Keine allgemeinen Kontaktinformationen bekannt. FirmEmail: Allgemeine Email FirmAddress: Postanschrift FirmDefaultPreferenceInfo: Diese Voreinstellungen gelten nur für neue Firmenangehörige diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 0d7ef77eb..250b9ca38 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -3,6 +3,8 @@ # SPDX-License-Identifier: AGPL-3.0-or-later FirmAssociates: Company associated users +FirmContact: Company Contact +FirmNoContact: No general contact information known. FirmEmail: General company email FirmAddress: Postal address FirmDefaultPreferenceInfo: Default setting for new company associates only diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 9e4c7655d..9442d841a 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -806,6 +806,7 @@ postFirmUsersR fsh = do siteLayout (citext2widget companyName) $ do setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId + let firmContactInfo = $(widgetFile "firm-contact-info") $(widgetFile "firm-users") @@ -1053,6 +1054,7 @@ postFirmSupersR fsh = do siteLayout (citext2widget fsh) $ do setTitle $ citext2Html $ fsh <> " Supers" + let firmContactInfo = $(widgetFile "firm-contact-info") $(i18nWidgetFile "firm-supervisors") diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index a92c54571..3a0103c58 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -475,11 +475,11 @@ serveProfileR (uid, user@User{..}) = do , UserWarningDays =. stgWarningDays , UserNotificationSettings =. stgNotificationSettings , UserShowSex =. stgShowSex - , UserPinPassword =. stgPinPassword -- TODO & canonical - , UserPostAddress =. stgPostAddress -- TODO & canonical + , UserPinPassword =. (stgPinPassword & canonical) + , UserPostAddress =. (stgPostAddress & canonical) , UserPrefersPostal =. stgPrefersPostal - , UserTelephone =. stgTelephone & canonical - , UserMobile =. stgMobile & canonical + , UserTelephone =. (stgTelephone & canonical) + , UserMobile =. (stgMobile & canonical) , UserExamOfficeGetSynced =. (stgExamOfficeSettings & eosettingsGetSynced) , UserExamOfficeGetLabels =. (stgExamOfficeSettings & eosettingsGetLabels) ] diff --git a/src/Model/Types/Markup.hs b/src/Model/Types/Markup.hs index c5555ceba..0715b65b5 100644 --- a/src/Model/Types/Markup.hs +++ b/src/Model/Types/Markup.hs @@ -50,6 +50,13 @@ data StoredMarkup = StoredMarkup deriving (Read, Show, Generic) deriving anyclass (Binary, Hashable, NFData) +instance Canonical (Maybe StoredMarkup) where + canonical Nothing = Nothing + canonical r@(Just s@StoredMarkup{..}) = let mi' = LT.strip markupInput in if + | LT.null mi' -> Nothing + | markupInput == mi' -> r + | otherwise -> Just s{markupInput = mi'} + htmlToStoredMarkup :: Html -> StoredMarkup htmlToStoredMarkup html = StoredMarkup { markupInputFormat = MarkupHtml diff --git a/src/Utils.hs b/src/Utils.hs index b879a2164..324f71aa7 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1987,8 +1987,9 @@ instance {-# OVERLAPPABLE #-} (Canonical mono, MonoFoldable mono, Eq mono) => Ca instance (Ord a, Canonical a) => Canonical (Set a) where canonical = Set.map canonical -instance Canonical (Maybe Text) where - canonical Nothing = Nothing - canonical (Just t) = - let t' = Text.strip t - in if Text.null t' then Nothing else Just t' +instance Canonical (Maybe Text) where -- a split into Canonical Text and Canonical a => Maybe seems nicer, but the latter instance would be troublesome + canonical Nothing = Nothing + canonical r@(Just t) = let t' = Text.strip t in if + | Text.null t' -> Nothing + | t == t' -> r + | otherwise -> Just t' diff --git a/templates/firm-contact-info.hamlet b/templates/firm-contact-info.hamlet new file mode 100644 index 000000000..8aea13ab1 --- /dev/null +++ b/templates/firm-contact-info.hamlet @@ -0,0 +1,23 @@ +$newline never + +$# SPDX-FileCopyrightText: 2023 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +
      +

      _{MsgFirmContact} +
      + $maybe fem <- companyEmail +
      + _{MsgFirmEmail} #{iconLetterOrEmail False} +
      + #{mailtoHtml fem} + $maybe addr <- companyPostAddress +
      + _{MsgFirmAddress} #{iconLetterOrEmail True} +
      + #{addr} + $nothing + $maybe _ <- companyEmail + $nothing + _{MsgFirmNoContact} diff --git a/templates/firm-users.hamlet b/templates/firm-users.hamlet index 2346ac4dd..19c41bb64 100644 --- a/templates/firm-users.hamlet +++ b/templates/firm-users.hamlet @@ -4,18 +4,7 @@ $# SPDX-FileCopyrightText: 2023 Steffen Jost $# $# SPDX-License-Identifier: AGPL-3.0-or-later -
      -
      - $maybe fem <- companyEmail -
      - _{MsgFirmEmail} #{iconLetterOrEmail False} -
      - #{mailtoHtml fem} - $maybe addr <- companyPostAddress -
      - _{MsgFirmAddress} #{iconLetterOrEmail True} -
      - #{addr} +^{firmContactInfo}
      diff --git a/templates/i18n/firm-supervisors/de-de-formal.hamlet b/templates/i18n/firm-supervisors/de-de-formal.hamlet index d81248e80..5e432e780 100644 --- a/templates/i18n/firm-supervisors/de-de-formal.hamlet +++ b/templates/i18n/firm-supervisors/de-de-formal.hamlet @@ -9,19 +9,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later Daraus folgt zum Beispiel, dass wenn x ein Standard-Ansprechpartner für Firma a ist und wenn y sowohl Firma a als auch b angehört, dass dann x als firmenfremd in der Liste der Ansprechpartner von Firma b angezeigt wird. -
      -
      - $maybe fem <- companyEmail -
      - _{MsgFirmEmail} #{iconLetterOrEmail False} -
      - #{mailtoHtml fem} - $maybe addr <- companyPostAddress -
      - _{MsgFirmAddress} #{iconLetterOrEmail True} -
      - #{addr} + +^{firmContactInfo} +
      ^{fsprTable} +
      ^{addSuperForm} \ No newline at end of file diff --git a/templates/i18n/firm-supervisors/en-eu.hamlet b/templates/i18n/firm-supervisors/en-eu.hamlet index 400fc543b..b34a75431 100644 --- a/templates/i18n/firm-supervisors/en-eu.hamlet +++ b/templates/i18n/firm-supervisors/en-eu.hamlet @@ -8,19 +8,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later Note that supervision is company independent. For example, if x is a regular supervisor for company a and y belongs to companies a and b, then x will be listed as a foreign supervisor for company b. -
      -
      - $maybe fem <- companyEmail -
      - _{MsgFirmEmail} #{iconLetterOrEmail False} -
      - #{mailtoHtml fem} - $maybe addr <- companyPostAddress -
      - _{MsgFirmAddress} #{iconLetterOrEmail True} -
      - #{addr} + +^{firmContactInfo} +
      ^{fsprTable} +
      ^{addSuperForm} From dc6079ec3b4eae32fe0e4325f958955edbcef965 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 23 Nov 2023 18:05:16 +0100 Subject: [PATCH 029/110] chore(nix): attempt to create alias for killall-uni2work --- shell.nix | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/shell.nix b/shell.nix index 0988cc475..9acbf8a78 100644 --- a/shell.nix +++ b/shell.nix @@ -257,6 +257,10 @@ let done ''; + environment.interactiveShellInit = '' + alias killuni2work='killall-uni2work' + ''; + diffRunning = pkgs.writeScriptBin "diff-running" '' #!${pkgs.zsh}/bin/zsh From 8973ea5849a69b72b559bae20f3c6f9564f8030f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 23 Nov 2023 18:06:00 +0100 Subject: [PATCH 030/110] refactor(firm): WIP generalize firm actions --- .../uniworx/categories/firm/de-de-formal.msg | 6 + messages/uniworx/categories/firm/en-eu.msg | 8 +- src/Handler/Firm.hs | 183 ++++++++++++++---- src/Handler/Utils.hs | 4 +- src/Utils/Form.hs | 1 + .../i18n/firm-supervisors/de-de-formal.hamlet | 2 + templates/i18n/firm-supervisors/en-eu.hamlet | 4 +- 7 files changed, 161 insertions(+), 47 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 5d81a2b03..d5cda6037 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -8,6 +8,12 @@ FirmNoContact: Keine allgemeinen Kontaktinformationen bekannt. FirmEmail: Allgemeine Email FirmAddress: Postanschrift FirmDefaultPreferenceInfo: Diese Voreinstellungen gelten nur für neue Firmenangehörige +FirmAction: Firmenweite Aktion +FirmActNotify: Mitteilung versenden +FirmActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen +FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten? +FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig +FirmActAddSupervisors: Ansprechpartner hinzufügen FirmAllActNotify: Mitteilung versenden FirmAllActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen FirmAllActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten? diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 250b9ca38..953055b25 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -8,11 +8,17 @@ FirmNoContact: No general contact information known. FirmEmail: General company email FirmAddress: Postal address FirmDefaultPreferenceInfo: Default setting for new company associates only +FirmAction: Companywide action +FirmActNotify: Send message +FirmActResetSupervision: Reset supervisors for all company associates +FirmActResetSuperKeep: Additionally keep existing supervisors of company associates? +FirmActResetMutualSupervision: Supervisors supervise each other +FirmActAddSupervisors: Add supervisors FirmAllActNotify: Send message FirmAllActResetSupervision: Reset supervisors for all company associates -FirmUserActNotify: Send message FirmAllActResetSuperKeep: Additionally keep existing supervisors of company associates? FirmAllActResetMutualSupervision: Supervisors supervise each other +FirmUserActNotify: Send message FirmUserActResetSupervision: Reset supervisors to company default FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> tshow rem <> " deleted before") (rem > 0)} FirmUserActMkSuper: Mark as company supervisor diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 9442d841a..12efe6594 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -48,12 +48,134 @@ decryptUser = decrypt encryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m CryptoUUIDUser encryptUser = encrypt +postalEmailField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Bool +postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgUtilEMail) $ Just $ SomeMessage MsgUtilUnchanged + +--------------------------------- +-- General firm affecting actions + +data FirmAction = FirmActNotify + | FirmActResetSupervision + -- | FirmActAddSupervisors + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + deriving anyclass (Universe, Finite) + +nullaryPathPiece ''FirmAction $ camelToPathPiece' 3 +embedRenderMessage ''UniWorX ''FirmAction id + +data FirmActionData = FirmActNotifyData + | FirmActResetSupervisionData + { firmActResetKeepOldSupers :: Maybe Bool + , firmActResetMutualSupervision :: Maybe Bool + } + -- | FirmActAddSupervisorsData + -- { firmActAddSupervisorIds :: Set Text + -- , firmActAddSupervisorReroute :: Bool + -- , firmActAddSupervisorPostal :: Maybe Bool + -- } + deriving (Eq, Ord, Read, Show, Generic) + +firmActionMap :: [FirmAction] -> Map FirmAction (AForm Handler FirmActionData) +firmActionMap acts = mconcat (mkAct <$> acts) + where + mkAct FirmActNotify = singletonMap FirmActNotify $ pure FirmActNotifyData + mkAct FirmActResetSupervision = singletonMap FirmActResetSupervision $ FirmActResetSupervisionData + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) + <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) + -- mkAct FirmActAddSupervisors = singletonMap FirmActAddSupervisors $ FirmActAddSupervisorsData + -- <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) (Just mempty) + -- <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) + -- <*> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) (Just Nothing) + +firmActionForm :: [FirmAction] -> AForm Handler FirmActionData +firmActionForm acts = multiActionA (firmActionMap acts) (fslI MsgTableAction) Nothing + + +makeFirmActionForm :: CompanyId -> [FirmAction] -> Form (FirmActionData, Set CompanyId) +makeFirmActionForm cid acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm acts + +-- makeFirmActionTableForm :: Monoid t => [FirmAction] -> Text.Blaze.Internal.Markup -> Control.Monad.Trans.RWS.Lazy.RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints Handler (FormResult (First FirmActionData, t), WidgetFor UniWorX ()) +-- makeFirmActionTableForm acts = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm acts + +firmActionHandler :: Route UniWorX -> FormResult (FirmActionData, Set CompanyId) -> Handler () +firmActionHandler route = flip formResult faHandler + where + faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected + faHandler (FirmActResetSupervisionData{..}, fids) = do + runDB $ do + delSupers <- if firmActResetKeepOldSupers == Just False + then E.deleteCount $ do + spr <- E.from $ E.table @UserSupervisor + E.where_ $ E.exists $ do + usr <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids + E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser + else return 0 + newSupers <- addDefaultSupervisorsAll (firmActResetMutualSupervision /= Just False) fids + addMessageI Info $ MsgFirmResetSupervision delSupers newSupers + reloadKeepGetParams route -- reload to reflect changes + + faHandler (FirmActNotifyData, Set.toList -> fids) = do + usrs <- runDB $ E.select $ E.distinct $ do + (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) + E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList fids + return $ usr E.^. UserId + cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] + redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + + -- faHandler (FirmActAddSupervisorsData{..}, Set.toList -> [cid]) = do + -- avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds + -- let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers + -- usersFound = mapMaybe snd usersFound' + -- unless (null usersNotFound) $ + -- let msgContent = [whamlet| + -- $newline never + --
        + -- $forall (usr,_) <- usersNotFound + --
      • #{usr} + -- |] + -- in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) + -- when (null usersFound) $ do + -- addMessageI Warning MsgASReqEmpty + -- reloadKeepGetParams route + -- runDB $ do + -- putMany [UserCompany uid cid True firmActAddSupervisorReroute | uid <- usersFound] + -- whenIsJust firmActAddSupervisorPostal $ \prefPostal -> + -- updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal] + -- addMessageI Info $ MsgASReqSetSupers (fromIntegral $ length usersFound) firmActAddSupervisorPostal + -- redirect route + -- faHandler _ = addMessageI Error MsgErrorUnknownFormAction + + +runFirmActionFormPost :: CompanyId -> Route UniWorX -> [FirmAction] -> Handler Widget +runFirmActionFormPost cid route acts = do + -- ((faRes, faWgt), faEnctype) <- runFormPost . identifyForm FIDFirmAction $ makeFirmActionForm cid acts + ((faRes, faWgt), faEnctype) <- runFormPost $ makeFirmActionForm cid acts + let faAnchor = "firm-action-form" :: Text + faRoute = route :#: faAnchor + faForm = wrapForm faWgt FormSettings + { formMethod = POST + , formAction = Just . SomeRoute $ faRoute + , formEncoding = faEnctype + , formAttrs = [] + , formSubmit = FormSubmit + , formAnchor = Just faAnchor + } + firmActionHandler route faRes + return [whamlet| +
        +

        + _{MsgFirmAction} +
        + ^{faForm} + |] + + --------------------------- -- Firm specific utilities -- for filters and counts also see before FirmAllR Handlers -postalEmailField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Bool -postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgUtilEMail) $ Just $ SomeMessage MsgUtilUnchanged + -- remove supervisors: deleteSupervisors :: NonEmpty UserId -> DB Int64 @@ -315,7 +437,7 @@ resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Bool resultAllCompanyDefaultReroutes = _dbrOutput . _4 . _unValue -mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget) +mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmActionData, Set CompanyId), Widget) mkFirmAllTable isAdmin uid = do -- now <- liftIO getCurrentTime let @@ -432,21 +554,14 @@ mkFirmAllTable isAdmin uid = do , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - acts :: Map FirmAllAction (AForm Handler FirmAllActionData) - acts = mconcat - [ singletonMap FirmAllActNotify $ pure FirmAllActNotifyData - , singletonMap FirmAllActResetSupervision $ FirmAllActResetSupervisionData - <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep) (Just $ Just False) - <*> aopt checkBoxField (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True ) - ] dbtParams = DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Nothing , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit - , dbParamsFormAdditional - = renderAForm FormStandard $ (, mempty) . First . Just - <$> multiActionA acts (fslI MsgTableAction) Nothing + -- , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm [FirmActNotify, FirmActResetSupervision] + , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just + <$> multiActionA (firmActionMap [FirmActNotify, FirmActResetSupervision]) (fslI MsgTableAction) Nothing , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def @@ -457,14 +572,14 @@ mkFirmAllTable isAdmin uid = do dbtCsvDecode = Nothing dbtExtraReps = [] - postprocess :: FormResult (First FirmAllActionData, DBFormResult CompanyId Bool AllCompanyTableData) - -> FormResult ( FirmAllActionData, Set CompanyId) + postprocess :: FormResult (First FirmActionData, DBFormResult CompanyId Bool AllCompanyTableData) + -> FormResult ( FirmActionData, Set CompanyId) postprocess inp = do (First (Just act), cmpMap) <- inp let cmpSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) cmpMap return (act, cmpSet) - -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) + -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmActionData, DBFormResult CompanyId Bool FirmActionData)) resultDBTableValidator = def & defaultSorting [SortAscBy "short"] over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable @@ -475,32 +590,8 @@ getFirmAllR = postFirmAllR postFirmAllR = do uid <- requireAuthId isAdmin <- hasReadAccessTo AdminR - (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins - formResult firmRes $ \case - (_, fids) | null fids -> addMessageI Error MsgNoCompanySelected - - (FirmAllActResetSupervisionData{..}, fids) -> do - runDB $ do - delSupers <- if firmAllActResetKeepOldSupers == Just False - then E.deleteCount $ do - spr <- E.from $ E.table @UserSupervisor - E.where_ $ E.exists $ do - usr <- E.from $ E.table @UserCompany - E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids - E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser - else return 0 - newSupers <- addDefaultSupervisorsAll (firmAllActResetMutualSupervision /= Just False) fids - addMessageI Info $ MsgFirmResetSupervision delSupers newSupers - reloadKeepGetParams FirmAllR -- reload to reflect changes - - (FirmAllActNotifyData , Set.toList -> fids) -> do - usrs <- runDB $ E.select $ E.distinct $ do - (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) - E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList fids - return $ usr E.^. UserId - cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] - redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) - + (_firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins + -- firmActionHandler FirmAllR firmRes siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms $(i18nWidgetFile "firm-all") @@ -1019,6 +1110,8 @@ postFirmSupersR fsh = do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) [FirmActNotify, FirmActResetSupervision] -- TODO ,FirmActAddSupervisors] + ((asReqRes, asReqWgt), asReqEnctype) <- runFormPost . identifyForm FIDAddSupervisor $ makeAddSupervisorForm (Just def) let addSuperAnchor = "add-supervisors-form" :: Text routeAddSuperForm = FirmSupersR fsh :#: addSuperAnchor @@ -1056,7 +1149,11 @@ postFirmSupersR fsh = do setTitle $ citext2Html $ fsh <> " Supers" let firmContactInfo = $(widgetFile "firm-contact-info") $(i18nWidgetFile "firm-supervisors") - + + +------------------------ +-- Firm Communications + getFirmCommR, postFirmCommR :: CompanyShorthand -> Handler Html getFirmCommR = postFirmCommR diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 2460eb65d..715c910a5 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -146,7 +146,7 @@ redirectAlternatives = go reload :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a reload r = getCurrentRoute >>= redirect . fromMaybe r --- | like `reload`, preserving all GET parameters +-- | like `reload` to current route, but also preserving all GET parameters, using the current route, if known reloadKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a reloadKeepGetParams r = liftHandler $ do getps <- reqGetParams <$> getRequest @@ -155,7 +155,7 @@ reloadKeepGetParams r = liftHandler $ do -- RECALL: redirect GET parameters are used like so: -- redirect (UsersR, [("users-user-company","fraport")]) redirect (route, getps) --- | redirect preserving all GET parameters +-- | like `reloadKeepGetParams`, but always leading to the specific route instead of the current route redirectKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a redirectKeepGetParams route = liftHandler $ do getps <- reqGetParams <$> getRequest diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 43b1ad82d..39107331e 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -318,6 +318,7 @@ data FormIdentifier | FIDHijackUser | FIDAddSupervisor | FIDFirmUserChangeRequest + | FIDFirmAction deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where diff --git a/templates/i18n/firm-supervisors/de-de-formal.hamlet b/templates/i18n/firm-supervisors/de-de-formal.hamlet index 5e432e780..bd9fdf4db 100644 --- a/templates/i18n/firm-supervisors/de-de-formal.hamlet +++ b/templates/i18n/firm-supervisors/de-de-formal.hamlet @@ -12,6 +12,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{firmContactInfo} +^{formFirmAction} +
        ^{fsprTable} diff --git a/templates/i18n/firm-supervisors/en-eu.hamlet b/templates/i18n/firm-supervisors/en-eu.hamlet index b34a75431..8edcdeeec 100644 --- a/templates/i18n/firm-supervisors/en-eu.hamlet +++ b/templates/i18n/firm-supervisors/en-eu.hamlet @@ -11,8 +11,10 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{firmContactInfo} +^{formFirmAction} +
        ^{fsprTable} - +
        ^{addSuperForm} From b10cbc39cca0d4e23c0d2a3f8b65d9f3343e6bd4 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 23 Nov 2023 18:22:00 +0100 Subject: [PATCH 031/110] refactor(firm): FirmAllR messaging working old way --- src/Handler/Firm.hs | 48 +++++++++++++++++++++++++++++++++++++++------ 1 file changed, 42 insertions(+), 6 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 12efe6594..5014bec27 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -437,7 +437,7 @@ resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Bool resultAllCompanyDefaultReroutes = _dbrOutput . _4 . _unValue -mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmActionData, Set CompanyId), Widget) +mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget) mkFirmAllTable isAdmin uid = do -- now <- liftIO getCurrentTime let @@ -554,14 +554,25 @@ mkFirmAllTable isAdmin uid = do , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + acts :: Map FirmAllAction (AForm Handler FirmAllActionData) + acts = mconcat + [ singletonMap FirmAllActNotify $ pure FirmAllActNotifyData + , singletonMap FirmAllActResetSupervision $ FirmAllActResetSupervisionData + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep) (Just $ Just False) + <*> aopt checkBoxField (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True ) + ] + dbtParams = DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Nothing , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit -- , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm [FirmActNotify, FirmActResetSupervision] - , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just - <$> multiActionA (firmActionMap [FirmActNotify, FirmActResetSupervision]) (fslI MsgTableAction) Nothing + -- , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just + -- <$> multiActionA (firmActionMap [FirmActNotify, FirmActResetSupervision]) (fslI MsgTableAction) Nothing + , dbParamsFormAdditional + = renderAForm FormStandard $ (, mempty) . First . Just + <$> multiActionA acts (fslI MsgTableAction) Nothing , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def @@ -572,8 +583,8 @@ mkFirmAllTable isAdmin uid = do dbtCsvDecode = Nothing dbtExtraReps = [] - postprocess :: FormResult (First FirmActionData, DBFormResult CompanyId Bool AllCompanyTableData) - -> FormResult ( FirmActionData, Set CompanyId) + postprocess :: FormResult (First FirmAllActionData, DBFormResult CompanyId Bool AllCompanyTableData) + -> FormResult ( FirmAllActionData, Set CompanyId) postprocess inp = do (First (Just act), cmpMap) <- inp let cmpSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) cmpMap @@ -590,8 +601,33 @@ getFirmAllR = postFirmAllR postFirmAllR = do uid <- requireAuthId isAdmin <- hasReadAccessTo AdminR - (_firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins + (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins -- firmActionHandler FirmAllR firmRes + formResult firmRes $ \case + (_, fids) | null fids -> addMessageI Error MsgNoCompanySelected + + (FirmAllActResetSupervisionData{..}, fids) -> do + runDB $ do + delSupers <- if firmAllActResetKeepOldSupers == Just False + then E.deleteCount $ do + spr <- E.from $ E.table @UserSupervisor + E.where_ $ E.exists $ do + usr <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids + E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser + else return 0 + newSupers <- addDefaultSupervisorsAll (firmAllActResetMutualSupervision /= Just False) fids + addMessageI Info $ MsgFirmResetSupervision delSupers newSupers + reloadKeepGetParams FirmAllR -- reload to reflect changes + + (FirmAllActNotifyData , Set.toList -> fids) -> do + usrs <- runDB $ E.select $ E.distinct $ do + (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) + E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList fids + return $ usr E.^. UserId + cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] + redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms $(i18nWidgetFile "firm-all") From 577a2fb45d8274f26677275f9fc892ac64afa3e6 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 23 Nov 2023 18:29:12 +0100 Subject: [PATCH 032/110] refactor(firm): FirmAllR messaging no longer works now What did change? Nothing here is essential?! --- src/Handler/Firm.hs | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 5014bec27..bbb69ad23 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -437,7 +437,7 @@ resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Bool resultAllCompanyDefaultReroutes = _dbrOutput . _4 . _unValue -mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget) +mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmActionData, Set CompanyId), Widget) mkFirmAllTable isAdmin uid = do -- now <- liftIO getCurrentTime let @@ -554,12 +554,12 @@ mkFirmAllTable isAdmin uid = do , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - acts :: Map FirmAllAction (AForm Handler FirmAllActionData) + acts :: Map FirmAction (AForm Handler FirmActionData) acts = mconcat - [ singletonMap FirmAllActNotify $ pure FirmAllActNotifyData - , singletonMap FirmAllActResetSupervision $ FirmAllActResetSupervisionData - <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep) (Just $ Just False) - <*> aopt checkBoxField (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True ) + [ singletonMap FirmActNotify $ pure FirmActNotifyData + , singletonMap FirmActResetSupervision $ FirmActResetSupervisionData + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) + <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) ] dbtParams = DBParamsForm @@ -583,8 +583,8 @@ mkFirmAllTable isAdmin uid = do dbtCsvDecode = Nothing dbtExtraReps = [] - postprocess :: FormResult (First FirmAllActionData, DBFormResult CompanyId Bool AllCompanyTableData) - -> FormResult ( FirmAllActionData, Set CompanyId) + postprocess :: FormResult (First FirmActionData, DBFormResult CompanyId Bool AllCompanyTableData) + -> FormResult ( FirmActionData, Set CompanyId) postprocess inp = do (First (Just act), cmpMap) <- inp let cmpSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) cmpMap @@ -606,9 +606,9 @@ postFirmAllR = do formResult firmRes $ \case (_, fids) | null fids -> addMessageI Error MsgNoCompanySelected - (FirmAllActResetSupervisionData{..}, fids) -> do + (FirmActResetSupervisionData{..}, fids) -> do runDB $ do - delSupers <- if firmAllActResetKeepOldSupers == Just False + delSupers <- if firmActResetKeepOldSupers == Just False then E.deleteCount $ do spr <- E.from $ E.table @UserSupervisor E.where_ $ E.exists $ do @@ -616,11 +616,11 @@ postFirmAllR = do E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser else return 0 - newSupers <- addDefaultSupervisorsAll (firmAllActResetMutualSupervision /= Just False) fids + newSupers <- addDefaultSupervisorsAll (firmActResetMutualSupervision /= Just False) fids addMessageI Info $ MsgFirmResetSupervision delSupers newSupers reloadKeepGetParams FirmAllR -- reload to reflect changes - (FirmAllActNotifyData , Set.toList -> fids) -> do + (FirmActNotifyData , Set.toList -> fids) -> do usrs <- runDB $ E.select $ E.distinct $ do (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList fids @@ -818,8 +818,8 @@ mkFirmUserTable isAdmin cid = do acts = mconcat [ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData - <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep) (Just $ Just False) - -- <*> aopt checkBoxField (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True ) + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) + -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) ] @@ -848,7 +848,7 @@ mkFirmUserTable isAdmin cid = do let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m return (act, s) - -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) + -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmActionData, DBFormResult CompanyId Bool FirmActionData)) resultDBTableValidator = def & defaultSorting [SortAscBy "user-name"] over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable From e645517d327734ebd0e2b5a4e877bb440c9b0af0 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 23 Nov 2023 18:36:02 +0100 Subject: [PATCH 033/110] refactor(firm): FirmAllR messaging no works again! --- src/Handler/Firm.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index bbb69ad23..73302520b 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -60,7 +60,7 @@ data FirmAction = FirmActNotify deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) -nullaryPathPiece ''FirmAction $ camelToPathPiece' 3 +nullaryPathPiece ''FirmAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''FirmAction id data FirmActionData = FirmActNotifyData From 076dff2a60de1c066148131a93ba541f7777079e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 24 Nov 2023 11:44:16 +0100 Subject: [PATCH 034/110] Revert "chore(nix): attempt to create alias for killall-uni0work" This reverts commit dc6079ec3b4eae32fe0e4325f958955edbcef965. --- src/Handler/Firm.hs | 117 +++++++++++++++----------------------------- 1 file changed, 40 insertions(+), 77 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 73302520b..384db461f 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -56,7 +56,7 @@ postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgU data FirmAction = FirmActNotify | FirmActResetSupervision - -- | FirmActAddSupervisors + | FirmActAddSupervisors deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -68,11 +68,11 @@ data FirmActionData = FirmActNotifyData { firmActResetKeepOldSupers :: Maybe Bool , firmActResetMutualSupervision :: Maybe Bool } - -- | FirmActAddSupervisorsData - -- { firmActAddSupervisorIds :: Set Text - -- , firmActAddSupervisorReroute :: Bool - -- , firmActAddSupervisorPostal :: Maybe Bool - -- } + | FirmActAddSupervisorsData + { firmActAddSupervisorIds :: Set Text + , firmActAddSupervisorReroute :: Bool + , firmActAddSupervisorPostal :: Maybe Bool + } deriving (Eq, Ord, Read, Show, Generic) firmActionMap :: [FirmAction] -> Map FirmAction (AForm Handler FirmActionData) @@ -82,10 +82,10 @@ firmActionMap acts = mconcat (mkAct <$> acts) mkAct FirmActResetSupervision = singletonMap FirmActResetSupervision $ FirmActResetSupervisionData <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) - -- mkAct FirmActAddSupervisors = singletonMap FirmActAddSupervisors $ FirmActAddSupervisorsData - -- <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) (Just mempty) - -- <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) - -- <*> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) (Just Nothing) + mkAct FirmActAddSupervisors = singletonMap FirmActAddSupervisors $ FirmActAddSupervisorsData + <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) + <*> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) Nothing firmActionForm :: [FirmAction] -> AForm Handler FirmActionData firmActionForm acts = multiActionA (firmActionMap acts) (fslI MsgTableAction) Nothing @@ -123,28 +123,28 @@ firmActionHandler route = flip formResult faHandler cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) - -- faHandler (FirmActAddSupervisorsData{..}, Set.toList -> [cid]) = do - -- avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds - -- let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers - -- usersFound = mapMaybe snd usersFound' - -- unless (null usersNotFound) $ - -- let msgContent = [whamlet| - -- $newline never - --
          - -- $forall (usr,_) <- usersNotFound - --
        • #{usr} - -- |] - -- in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) - -- when (null usersFound) $ do - -- addMessageI Warning MsgASReqEmpty - -- reloadKeepGetParams route - -- runDB $ do - -- putMany [UserCompany uid cid True firmActAddSupervisorReroute | uid <- usersFound] - -- whenIsJust firmActAddSupervisorPostal $ \prefPostal -> - -- updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal] - -- addMessageI Info $ MsgASReqSetSupers (fromIntegral $ length usersFound) firmActAddSupervisorPostal - -- redirect route - -- faHandler _ = addMessageI Error MsgErrorUnknownFormAction + faHandler (FirmActAddSupervisorsData{..}, Set.toList -> [cid]) = do + avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds + let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers + usersFound = mapMaybe snd usersFound' + unless (null usersNotFound) $ + let msgContent = [whamlet| + $newline never +
            + $forall (usr,_) <- usersNotFound +
          • #{usr} + |] + in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) + when (null usersFound) $ do + addMessageI Warning MsgASReqEmpty + reloadKeepGetParams route + runDB $ do + putMany [UserCompany uid cid True firmActAddSupervisorReroute | uid <- usersFound] + whenIsJust firmActAddSupervisorPostal $ \prefPostal -> + updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal] + addMessageI Info $ MsgASReqSetSupers (fromIntegral $ length usersFound) firmActAddSupervisorPostal + redirect route + faHandler _ = addMessageI Error MsgErrorUnknownFormAction runFirmActionFormPost :: CompanyId -> Route UniWorX -> [FirmAction] -> Handler Widget @@ -554,25 +554,14 @@ mkFirmAllTable isAdmin uid = do , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - acts :: Map FirmAction (AForm Handler FirmActionData) - acts = mconcat - [ singletonMap FirmActNotify $ pure FirmActNotifyData - , singletonMap FirmActResetSupervision $ FirmActResetSupervisionData - <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) - <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) - ] - dbtParams = DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Nothing , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit -- , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm [FirmActNotify, FirmActResetSupervision] - -- , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just - -- <$> multiActionA (firmActionMap [FirmActNotify, FirmActResetSupervision]) (fslI MsgTableAction) Nothing - , dbParamsFormAdditional - = renderAForm FormStandard $ (, mempty) . First . Just - <$> multiActionA acts (fslI MsgTableAction) Nothing + , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just + <$> multiActionA (firmActionMap [FirmActNotify, FirmActResetSupervision]) (fslI MsgTableAction) Nothing , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def @@ -602,32 +591,7 @@ postFirmAllR = do uid <- requireAuthId isAdmin <- hasReadAccessTo AdminR (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins - -- firmActionHandler FirmAllR firmRes - formResult firmRes $ \case - (_, fids) | null fids -> addMessageI Error MsgNoCompanySelected - - (FirmActResetSupervisionData{..}, fids) -> do - runDB $ do - delSupers <- if firmActResetKeepOldSupers == Just False - then E.deleteCount $ do - spr <- E.from $ E.table @UserSupervisor - E.where_ $ E.exists $ do - usr <- E.from $ E.table @UserCompany - E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids - E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser - else return 0 - newSupers <- addDefaultSupervisorsAll (firmActResetMutualSupervision /= Just False) fids - addMessageI Info $ MsgFirmResetSupervision delSupers newSupers - reloadKeepGetParams FirmAllR -- reload to reflect changes - - (FirmActNotifyData , Set.toList -> fids) -> do - usrs <- runDB $ E.select $ E.distinct $ do - (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) - E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList fids - return $ usr E.^. UserId - cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] - redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) - + firmActionHandler FirmAllR firmRes siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms $(i18nWidgetFile "firm-all") @@ -818,8 +782,8 @@ mkFirmUserTable isAdmin cid = do acts = mconcat [ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData - <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) - -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep) (Just $ Just False) + -- <*> aopt checkBoxField (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True ) , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) ] @@ -848,7 +812,7 @@ mkFirmUserTable isAdmin cid = do let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m return (act, s) - -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmActionData, DBFormResult CompanyId Bool FirmActionData)) + -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) resultDBTableValidator = def & defaultSorting [SortAscBy "user-name"] over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable @@ -917,8 +881,7 @@ postFirmUsersR fsh = do , formSubmit = FormSubmit , formAnchor = Just addFormAnchor } - formResult fucrRes $ \FirmUserChangeRequest{fucrPostalPref=fucrPPref, fucrPostalAddr=fucrPAddr} -> do - -- let fucrPAddr = canonical fucrPAddr' TODO + formResult fucrRes $ \FirmUserChangeRequest{fucrPostalPref=fucrPPref, fucrPostalAddr=(canonical -> fucrPAddr)} -> do when (isJust fucrPPref || isJust fucrPAddr) $ do let changes = foldMap (\pp -> [UserPrefersPostal E.=. E.val pp]) fucrPPref <> foldMap (\pa -> [UserPostAddress E.=. E.justVal pa]) fucrPAddr -- seems weird, but: Nothing means no change, and not delete address! @@ -1146,7 +1109,7 @@ postFirmSupersR fsh = do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) - formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) [FirmActNotify, FirmActResetSupervision] -- TODO ,FirmActAddSupervisors] + formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) [FirmActAddSupervisors, FirmActResetSupervision] ((asReqRes, asReqWgt), asReqEnctype) <- runFormPost . identifyForm FIDAddSupervisor $ makeAddSupervisorForm (Just def) let addSuperAnchor = "add-supervisors-form" :: Text From 0b00fffd2715a3908b5cc0055aada7c0fd2c1673 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 24 Nov 2023 11:45:07 +0100 Subject: [PATCH 035/110] chore(nix): change killall-uni2work to killuni2work for ease of use --- shell.nix | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/shell.nix b/shell.nix index 9acbf8a78..42c65ae1f 100644 --- a/shell.nix +++ b/shell.nix @@ -223,7 +223,7 @@ let fi ''; - killallUni2work = pkgs.writeScriptBin "killall-uni2work" '' + killallUni2work = pkgs.writeScriptBin "killuni2work" '' #!${pkgs.zsh}/bin/zsh set -o pipefail @@ -257,10 +257,6 @@ let done ''; - environment.interactiveShellInit = '' - alias killuni2work='killall-uni2work' - ''; - diffRunning = pkgs.writeScriptBin "diff-running" '' #!${pkgs.zsh}/bin/zsh From fb41caceffbaed591e5bd95485b0f2e082c506cf Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Fri, 24 Nov 2023 15:56:34 +0000 Subject: [PATCH 036/110] Resolve "Crontab appQualificationCheckHour funktioniert nicht" --- config/settings.yml | 5 +- .../categories/qualification/de-de-formal.msg | 4 +- .../categories/qualification/en-eu.msg | 10 ++-- src/Handler/LMS.hs | 7 ++- src/Jobs/Crontab.hs | 25 ++++---- src/Settings.hs | 6 +- templates/i18n/lms-all/de-de-formal.hamlet | 57 +++++++++++++++++++ templates/i18n/lms-all/en-eu.hamlet | 57 +++++++++++++++++++ templates/lms-all.hamlet | 18 ------ 9 files changed, 144 insertions(+), 45 deletions(-) create mode 100644 templates/i18n/lms-all/de-de-formal.hamlet create mode 100644 templates/i18n/lms-all/en-eu.hamlet delete mode 100644 templates/lms-all.hamlet diff --git a/config/settings.yml b/config/settings.yml index ecc94093d..b3c228991 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -90,8 +90,9 @@ synchronise-avs-users-interval: "_env:SYNCHRONISE_AVS_INTERVAL:21600" # alle 6 study-features-recache-relevance-within: 172800 study-features-recache-relevance-interval: 293 -# Enqueue at specified hour, dequeue 30min later -# qualification-check-hour: 3 +# Enqueue at specified hour, a few minutes later +job-lms-qualifications-enqueue-hour: 15 +job-lms-qualifications-dequeue-hour: 3 log-settings: detailed: "_env:DETAILED_LOGGING:false" diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 113121211..1571d7ac1 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -138,7 +138,5 @@ LmsNotificationSend n@Int: E‑Learning Benachrichtigungen an #{n} #{pluralDE n LmsPinRenewal n@Int: E‑Learning Passwort ausgetauscht für #{n} #{pluralDE n "Prüfling" "Prüflinge"}. LmsActionFailed n@Int: Aktion nicht durchgeführt für #{n} #{pluralDE n "Person" "Personen"}, da diese derzeit nicht an einer Prüfung teilnehmen. LmsStarted: E‑Learning eröffnet -LmsAutomaticQueuing n@Natural: Die folgenden Funktionen werden normalerweise einmal pro Tag um #{show n} Uhr ausgeführt. -LmsManualQueuing: Die folgenden Funktionen sollten einmal pro Tag ausgeführt werden. BtnLmsEnqueue: Nutzer mit ablaufenden Qualifikationen zum E‑Learning anmelden und benachrichtigen -BtnLmsDequeue: Nutzer mit beendetem E‑Learning ggf. benachrichtigen und aufräumen +BtnLmsDequeue: Nutzer mit beendetem E‑Learning aufräumen und ggf. benachrichtigen diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 1cab2c3dd..5d466355b 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -7,7 +7,7 @@ QualificationName: Qualification QualificationDescription: Description QualificationValidIndicator: Validity QualificationValidDuration: Validity period -QualificationAuditDuration: Audit log keept +QualificationAuditDuration: Audit log retention period QualificationAuditDurationTooltip n@Int: Optional period for deletion of e‑learning data. Note that the e‑learning server may delete its anonymised data earlier, at most #{n} days after closing. QualificationRefreshWithin: Refresh within QualificationRefreshWithinTooltip: Optional period before expiry to start e‑learning and send a notification by post or email. @@ -19,7 +19,7 @@ QualificationExpiryNotificationTooltip: Qualification holder are notfied upon in TableQualificationCountActive: Active TableQualificationCountActiveTooltip: Number of currently valid qualification holders TableQualificationCountTotal: Total -TableQualificationIsAvsLicence: AVS Driving License +TableQualificationIsAvsLicence: AVS driving license TableQualificationIsAvsLicenceTooltip: Under which name is this qualification synchronized with AVS, if any? Only applies to qualification holders having an AVS PersonID. TableQualificationSapExport: Sent to SAP TableQualificationSapExportTooltip: Is this qualification transmitted to SAP? Only applies to qualification holder having a Fraport AG personnel number. @@ -138,7 +138,5 @@ LmsNotificationSend n: E‑learning notifications will be sent to #{n} #{pluralE LmsPinRenewal n: E‑learning password replaced randomly for #{n} #{pluralENs n "examinee"}. LmsActionFailed n: No action for #{n} #{pluralENs n "person"}, since there was no ongoing examination. LmsStarted: E‑learning open since -LmsAutomaticQueuing n@Natural: The following functions are executed daily at #{show n} o'clock. -LmsManualQueuing: The following functions should be executed daily. -BtnLmsEnqueue: Enqueue users with expiring qualifications for e‑learning and notify them. -BtnLmsDequeue: Dequeue users with finished e‑learning and notify, if appropriate. +BtnLmsEnqueue: Enqueue users with expiring qualifications for e‑learning and notify them +BtnLmsDequeue: Dequeue users with finished e‑learning and notify failed users diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 682e0c7f4..2c4f6e437 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -75,7 +75,7 @@ embedRenderMessage ''UniWorX ''ButtonManualLms id instance Button UniWorX ButtonManualLms where btnClasses BtnLmsEnqueue = [BCIsButton, BCPrimary] - btnClasses BtnLmsDequeue = [BCIsButton, BCDefault] + btnClasses BtnLmsDequeue = [BCIsButton, BCPrimary] getLmsSchoolR :: SchoolId -> Handler Html @@ -85,7 +85,8 @@ getLmsAllR, postLmsAllR :: Handler Html getLmsAllR = postLmsAllR postLmsAllR = do isAdmin <- hasReadAccessTo AdminR - mbQcheck <- getsYesod $ view _appQualificationCheckHour + mbJLQenqueue <- getsYesod $ view _appJobLmsQualificationsEnqueueHour + mbJLQdequeue <- getsYesod $ view _appJobLmsQualificationsDequeueHour -- TODO: Move this functionality elsewhere without the need for `isAdmin` mbBtnForm <- if not isAdmin then return Nothing else do ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonManualLms) @@ -109,7 +110,7 @@ postLmsAllR = do view _2 <$> mkLmsAllTable isAdmin lmsDeletionDays siteLayoutMsg MsgMenuLms $ do setTitleI MsgMenuLms - $(widgetFile "lms-all") + $(i18nWidgetFile "lms-all") type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64) resultAllQualification :: Lens' AllQualificationTableData Qualification diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index e352758ef..093c5cbde 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2023 Sarah Vaupel , David Mosbach , Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -392,28 +392,31 @@ determineCrontab = execWriterT $ do -- , cronNotAfter = Right . CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appStudyFeaturesRecacheRelevanceInterval nextIntervalTime -- } - whenIsJust appQualificationCheckHour $ \hour -> tell $ HashMap.singleton + + whenIsJust appJobLmsQualificationsEnqueueHour $ \hour -> tell $ HashMap.singleton (JobCtlQueue JobLmsQualificationsEnqueue) Cron { cronInitial = CronAsap -- time after scheduling - , cronRepeat = CronRepeatScheduled $ cronCalendarAny { cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] ) - , cronMinute = cronMatchOne 3 + , cronRepeat = CronRepeatScheduled $ cronCalendarAny { cronDayOfWeek = CronMatchSome . impureNonNull . Set.fromList $ [1..5] + , cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] ) + , cronMinute = cronMatchOne 2 , cronSecond = cronMatchOne 27 } - , cronRateLimit = nominalDay / 2 -- minimal time between two executions, before the second job is skipped - , cronNotAfter = Left nominalDay -- maximal delay of an execution, before it is skipped entirely + , cronRateLimit = 600 -- minimal time between two executions, before the second job is skipped + , cronNotAfter = Right CronNotScheduled -- maximal delay of an execution, before it is skipped entirely } - whenIsJust appQualificationCheckHour $ \hour -> tell $ HashMap.singleton + whenIsJust appJobLmsQualificationsDequeueHour $ \hour -> tell $ HashMap.singleton (JobCtlQueue JobLmsQualificationsDequeue) Cron { cronInitial = CronAsap -- time after scheduling - , cronRepeat = CronRepeatScheduled $ cronCalendarAny { cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] ) - , cronMinute = cronMatchOne 33 + , cronRepeat = CronRepeatScheduled $ cronCalendarAny { cronDayOfWeek = CronMatchSome . impureNonNull . Set.fromList $ [1..5] + , cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] ) + , cronMinute = cronMatchOne 7 , cronSecond = cronMatchOne 27 } - , cronRateLimit = nominalDay / 2 -- minimal time between two executions, before the second job is skipped - , cronNotAfter = Left nominalDay -- maximal delay of an execution, before it is skipped entirely + , cronRateLimit = 600 -- minimal time between two executions, before the second job is skipped + , cronNotAfter = Right CronNotScheduled -- maximal delay of an execution, before it is skipped entirely } let diff --git a/src/Settings.hs b/src/Settings.hs index 0916f439f..e3fcc6105 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -233,7 +233,8 @@ data AppSettings = AppSettings , appStudyFeaturesRecacheRelevanceWithin :: Maybe NominalDiffTime , appStudyFeaturesRecacheRelevanceInterval :: NominalDiffTime - , appQualificationCheckHour :: Maybe Natural + , appJobLmsQualificationsEnqueueHour :: Maybe Natural + , appJobLmsQualificationsDequeueHour :: Maybe Natural , appFileSourceARCConf :: Maybe (ARCConf Int) , appFileSourcePrewarmConf :: Maybe PrewarmCacheConf @@ -785,7 +786,8 @@ instance FromJSON AppSettings where appStudyFeaturesRecacheRelevanceWithin <- o .:? "study-features-recache-relevance-within" appStudyFeaturesRecacheRelevanceInterval <- o .: "study-features-recache-relevance-interval" - appQualificationCheckHour <- o .:? "qualification-check-hour" + appJobLmsQualificationsEnqueueHour <- o .:? "job-lms-qualifications-enqueue-hour" + appJobLmsQualificationsDequeueHour <- o .:? "job-lms-qualifications-dequeue-hour" appFileSourceARCConf <- assertM isValidARCConf <$> o .:? "file-source-arc" diff --git a/templates/i18n/lms-all/de-de-formal.hamlet b/templates/i18n/lms-all/de-de-formal.hamlet new file mode 100644 index 000000000..c93ddfb58 --- /dev/null +++ b/templates/i18n/lms-all/de-de-formal.hamlet @@ -0,0 +1,57 @@ +$newline never + +$# SPDX-FileCopyrightText: 2022 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +
            + ^{lmsTable} + +$maybe btnForm <- mbBtnForm +
            +

            + E‑Learning Starten und Aufräumen +

            + Die folgenden Funktionen sollten normalerweise mindestens einmal pro Tag ausgeführt werden, # + können aber auch bedenkenlos mehrfach pro Tag ausgeführt werden. # + + Die erste Funktion benachrichtigt Inhaber von ablaufenden Lizenzen und # + lädt diese ggf. zum E‑Learning ein. # + + Die zweite Funktion benachrichtigt Inhaber von bereits abgelaufenen Lizenzen und # + räumte beendete E‑Learning Teilnehmer auf, falls der jeweilige Aufbewahrungszeitraum abgelaufen ist. # + + Ein Abgleich mit dem Ausweisverwaltungssystem findet dadurch jedoch noch nicht statt. # + +

            +

            + Automatische Ausführung + +
            +
            + Start E‑Learning: # +
            +   + $maybe hour <- mbJLQenqueue + jeden Wochentag kurz nach # + + #{hour} Uhr + $nothing + + keine automatische Ausführung +
            + Sperren/Aufräumen: # +
            +   + $maybe hour <- mbJLQdequeue + jeden Wochentag kurz nach # + + #{hour} Uhr + $nothing + + keine automatische Ausführung +

            +

            + Manuelle Ausführung + + ^{btnForm} \ No newline at end of file diff --git a/templates/i18n/lms-all/en-eu.hamlet b/templates/i18n/lms-all/en-eu.hamlet new file mode 100644 index 000000000..69aa8df82 --- /dev/null +++ b/templates/i18n/lms-all/en-eu.hamlet @@ -0,0 +1,57 @@ +$newline never + +$# SPDX-FileCopyrightText: 2022 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +
            + ^{lmsTable} + +$maybe btnForm <- mbBtnForm +
            +

            + Starting and cleaning e‑learning +

            + The following functions should be executed at least once per day, # + but a repeated execution is harmless. # + + The first function notifies holders of expiring licences and # + enlists them for e‑learning, if appropriate for the respective qualification. # + + The second function notifies holders of already expired licences and # + cleans finished e‑learnings after their respective rentention periods. # + + Note that these functions do not trigger an AVS-synchronisation. # + +

            +

            + Automatic execution + +
            +
            + Start e‑learning: # +
            +   + $maybe hour <- mbJLQenqueue + every weekday shortly after # + + #{hour} o'clock + $nothing + + no automatic execution +
            + Block/Clean: # +
            +   + $maybe hour <- mbJLQdequeue + every weekday shortly after # + + #{hour} o'clock + $nothing + + no automatic execution +

            +

            + Manual execution + + ^{btnForm} \ No newline at end of file diff --git a/templates/lms-all.hamlet b/templates/lms-all.hamlet deleted file mode 100644 index b4e5077fd..000000000 --- a/templates/lms-all.hamlet +++ /dev/null @@ -1,18 +0,0 @@ -$newline never - -$# SPDX-FileCopyrightText: 2022 Steffen Jost -$# -$# SPDX-License-Identifier: AGPL-3.0-or-later - -

            - ^{lmsTable} - -$maybe btnForm <- mbBtnForm -

            -

            - $maybe qcheck <- mbQcheck - _{MsgLmsAutomaticQueuing qcheck} - $nothing - _{MsgLmsManualQueuing} -

            - ^{btnForm} \ No newline at end of file From 2636c9d41aa50726f05c6952f45ed7b08a3b3507 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 24 Nov 2023 17:31:34 +0100 Subject: [PATCH 037/110] refactor(firm): clean firm interface - multiactions working - several code redundancies removed --- .../uniworx/categories/firm/de-de-formal.msg | 24 +- messages/uniworx/categories/firm/en-eu.msg | 22 +- src/Handler/Firm.hs | 422 ++++++++---------- src/Utils.hs | 7 + templates/firm-contact-info.hamlet | 8 +- templates/firm-users.hamlet | 8 +- .../i18n/firm-supervisors/de-de-formal.hamlet | 8 +- templates/i18n/firm-supervisors/en-eu.hamlet | 7 +- 8 files changed, 234 insertions(+), 272 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index d5cda6037..3158130c1 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -9,18 +9,23 @@ FirmEmail: Allgemeine Email FirmAddress: Postanschrift FirmDefaultPreferenceInfo: Diese Voreinstellungen gelten nur für neue Firmenangehörige FirmAction: Firmenweite Aktion +FirmActionInfo: Betrifft alle Firmenangehörigen. FirmActNotify: Mitteilung versenden FirmActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten? FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig -FirmActAddSupervisors: Ansprechpartner hinzufügen -FirmAllActNotify: Mitteilung versenden -FirmAllActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen -FirmAllActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten? -FirmAllActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig +FirmActAddSupersvisors: Ansprechpartner hinzufügen +FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden +FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner eingetragen #{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)} +FirmActChangeContactUser: Kontaktinformationen von 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. +FirmActChangeContactFirmResult: Firmenkontaktinformationen geändert. Betrifft nur neue Firmenangehörige ohne eigene Kontaktinformationen FirmUserActNotify: Mitteilung versenden FirmUserActResetSupervision: Ansprechpartner auf Firmenstandard zurücksetzen FirmUserActMkSuper: Zum Firmenansprechpartner ernennen +FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{bool mempty (", " <> tshow rem <> " zuvor gelöscht") (rem > 0)} FirmSuperActNotify: Mitteilung versenden FirmSuperActRMSuperDef: Standard Firmenansprechpartner entfernen @@ -37,12 +42,9 @@ FilterFirmExtern: Externe Firma FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh} -NoCompanySelected: Bitte wählen Sie mindestens eine Firm aus. +NoCompanySelected: Bitte wählen Sie mindestens eine Firma aus. TableIsDefaultSupervisor: Standardansprechpartner TableIsDefaultReroute: Standardumleitung -FormReqPostal: Benachrichtigungseinstellung -FormReqPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner -ASReqEmpty: Es konnten keine Ansprechpartner hinzugefügt werden -ASReqSetSupers n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner eingetragen #{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)} +FormFieldPostal: Benachrichtigungseinstellung +FormFieldPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner FirmUserChanges n@Int64: Benachrichtigungseinstellung für #{n} Firmenangehörige wurden geändert \ No newline at end of file diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 953055b25..b73afc808 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -9,18 +9,23 @@ FirmEmail: General company email FirmAddress: Postal address FirmDefaultPreferenceInfo: Default setting for new company associates only FirmAction: Companywide action +FirmActionInfo: Affects alle company associates. FirmActNotify: Send message FirmActResetSupervision: Reset supervisors for all company associates FirmActResetSuperKeep: Additionally keep existing supervisors of company associates? FirmActResetMutualSupervision: Supervisors supervise each other -FirmActAddSupervisors: Add supervisors -FirmAllActNotify: Send message -FirmAllActResetSupervision: Reset supervisors for all company associates -FirmAllActResetSuperKeep: Additionally keep existing supervisors of company associates? -FirmAllActResetMutualSupervision: Supervisors supervise each other +FirmActAddSupersvisors: Add supervisors +FirmActAddSupersEmpty: No supervisors added +FirmActAddSupersSet n postal: #{n} default company supervisors set #{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 supervisons terminated") (nact > 0)} +FirmActChangeContactUser: Change contact data for 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. +FirmActChangeContactFirmResult: Company contact data changed, affecting future company associates without contact information only FirmUserActNotify: Send message FirmUserActResetSupervision: Reset supervisors to company default FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> tshow rem <> " deleted before") (rem > 0)} +FirmUserActChangeContact: Change contact data for selected company associates FirmUserActMkSuper: Mark as company supervisor FirmSuperActNotify: Send message FirmSuperActRMSuperDef: Remove as default supervisor @@ -40,9 +45,6 @@ FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users NoCompanySelected: Select at least one company, please. TableIsDefaultSupervisor: Default supervisor TableIsDefaultReroute: Default reroute -FormReqPostal: Notification type -FormReqPostalTip: Affects all notifications to this person, not just reroutes to this supervisor -ASReqEmpty: No supervisors added -ASReqSetSupers n postal: #{n} default company supervisors set #{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 supervisons terminated") (nact > 0)} +FormFieldPostal: Notification type +FormFieldPostalTip: Affects all notifications to this person, not just reroutes to this supervisor FirmUserChanges n: Notification settings changed for #{n} company associates \ No newline at end of file diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 384db461f..9ed737280 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -2,7 +2,7 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later -{-# OPTIONS -Wno-unused-top-binds -Wno-unused-imports -Wno-unused-binds #-} -- TODO: remove me, for debugging only +{-# OPTIONS -Wno-unused-top-binds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances {-# LANGUAGE TypeApplications #-} @@ -32,7 +32,7 @@ import qualified Data.CaseInsensitive as CI import Database.Persist.Sql (deleteWhereCount, updateWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma -import qualified Database.Esqueleto.Legacy as EL (from, on) +import qualified Database.Esqueleto.Legacy as EL (on) import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH @@ -42,11 +42,11 @@ import Database.Esqueleto.Utils.TH single :: (k,a) -> Map k a single = uncurry Map.singleton -decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId -decryptUser = decrypt +-- decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId +-- decryptUser = decrypt encryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m CryptoUUIDUser -encryptUser = encrypt +encryptUser = encrypt postalEmailField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Bool postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgUtilEMail) $ Just $ SomeMessage MsgUtilUnchanged @@ -56,7 +56,9 @@ postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgU data FirmAction = FirmActNotify | FirmActResetSupervision - | FirmActAddSupervisors + | FirmActAddSupersvisors + | FirmActChangeContactFirm + | FirmActChangeContactUser deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -64,41 +66,54 @@ nullaryPathPiece ''FirmAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''FirmAction id data FirmActionData = FirmActNotifyData - | FirmActResetSupervisionData - { firmActResetKeepOldSupers :: Maybe Bool - , firmActResetMutualSupervision :: Maybe Bool + | FirmActResetSupervisionData + { firmActResetKeepOldSupers :: Maybe Bool + , firmActResetMutualSupervision :: Maybe Bool } - | FirmActAddSupervisorsData - { firmActAddSupervisorIds :: Set Text - , firmActAddSupervisorReroute :: Bool - , firmActAddSupervisorPostal :: Maybe Bool + | FirmActAddSupersvisorsData + { firmActAddSupervisorIds :: Set Text + , firmActAddSupervisorReroute :: Bool + , firmActAddSupervisorPostal :: Maybe Bool + } + | FirmActChangeContactFirmData + { firmActCCFPostalAddr :: Maybe StoredMarkup + , firmActCCFEmail :: Maybe UserEmail + , firmActCCFPostalPref :: Maybe Bool + } + | FirmActChangeContactUserData + { firmActCCUPostalAddr :: Maybe StoredMarkup + , firmActCCUPostalPref :: Maybe Bool } deriving (Eq, Ord, Read, Show, Generic) -firmActionMap :: [FirmAction] -> Map FirmAction (AForm Handler FirmActionData) -firmActionMap acts = mconcat (mkAct <$> acts) +firmActionMap :: _ -> [FirmAction] -> Map FirmAction (AForm Handler FirmActionData) +firmActionMap mr acts = mconcat (mkAct <$> acts) where mkAct FirmActNotify = singletonMap FirmActNotify $ pure FirmActNotifyData mkAct FirmActResetSupervision = singletonMap FirmActResetSupervision $ FirmActResetSupervisionData - <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) - <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) - mkAct FirmActAddSupervisors = singletonMap FirmActAddSupervisors $ FirmActAddSupervisorsData - <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing - <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) - <*> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) Nothing + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) + <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) + mkAct FirmActAddSupersvisors = singletonMap FirmActAddSupersvisors $ FirmActAddSupersvisorsData + <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + mkAct FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData + <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing + <*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + <* aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive)) + mkAct FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData + <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing -firmActionForm :: [FirmAction] -> AForm Handler FirmActionData -firmActionForm acts = multiActionA (firmActionMap acts) (fslI MsgTableAction) Nothing +firmActionForm :: _ -> [FirmAction] -> AForm Handler FirmActionData +firmActionForm mr acts = multiActionA (firmActionMap mr acts) (fslI MsgTableAction) Nothing - -makeFirmActionForm :: CompanyId -> [FirmAction] -> Form (FirmActionData, Set CompanyId) -makeFirmActionForm cid acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm acts - --- makeFirmActionTableForm :: Monoid t => [FirmAction] -> Text.Blaze.Internal.Markup -> Control.Monad.Trans.RWS.Lazy.RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints Handler (FormResult (First FirmActionData, t), WidgetFor UniWorX ()) --- makeFirmActionTableForm acts = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm acts +makeFirmActionForm :: CompanyId -> _ -> [FirmAction] -> Form (FirmActionData, Set CompanyId) +makeFirmActionForm cid mr acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm mr acts firmActionHandler :: Route UniWorX -> FormResult (FirmActionData, Set CompanyId) -> Handler () -firmActionHandler route = flip formResult faHandler +firmActionHandler route = flip formResult faHandler where faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected faHandler (FirmActResetSupervisionData{..}, fids) = do @@ -109,10 +124,10 @@ firmActionHandler route = flip formResult faHandler E.where_ $ E.exists $ do usr <- E.from $ E.table @UserCompany E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids - E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser - else return 0 - newSupers <- addDefaultSupervisorsAll (firmActResetMutualSupervision /= Just False) fids - addMessageI Info $ MsgFirmResetSupervision delSupers newSupers + E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser + else return 0 + newSupers <- addDefaultSupervisorsAll (firmActResetMutualSupervision /= Just False) fids + addMessageI Success $ MsgFirmResetSupervision delSupers newSupers reloadKeepGetParams route -- reload to reflect changes faHandler (FirmActNotifyData, Set.toList -> fids) = do @@ -123,7 +138,7 @@ firmActionHandler route = flip formResult faHandler cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) - faHandler (FirmActAddSupervisorsData{..}, Set.toList -> [cid]) = do + faHandler (FirmActAddSupersvisorsData{..}, Set.toList -> [cid]) = do avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers usersFound = mapMaybe snd usersFound' @@ -136,24 +151,51 @@ firmActionHandler route = flip formResult faHandler |] in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) when (null usersFound) $ do - addMessageI Warning MsgASReqEmpty + addMessageI Warning MsgFirmActAddSupersEmpty reloadKeepGetParams route runDB $ do putMany [UserCompany uid cid True firmActAddSupervisorReroute | uid <- usersFound] whenIsJust firmActAddSupervisorPostal $ \prefPostal -> updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal] - addMessageI Info $ MsgASReqSetSupers (fromIntegral $ length usersFound) firmActAddSupervisorPostal + addMessageI Success $ MsgFirmActAddSupersSet (fromIntegral $ length usersFound) firmActAddSupervisorPostal redirect route + + faHandler (FirmActChangeContactFirmData{..}, Set.toList -> [cid]) = + let changes = catMaybes + [ (CompanyPostAddress =.) . Just <$> canonical firmActCCFPostalAddr + , (CompanyEmail =.) . Just <$> canonical firmActCCFEmail + , (CompanyPrefersPostal =.) <$> firmActCCFPostalPref + ] + in unless (null changes) $ do + runDB $ updateBy (UniqueCompanyShorthand $ unCompanyKey cid) changes + addMessageI Success MsgFirmActChangeContactFirmResult + reloadKeepGetParams route + + faHandler (FirmActChangeContactUserData{..}, Set.toList -> [cid]) = + let changes = catMaybes + [ (UserPostAddress E.=.) . E.justVal <$> canonical firmActCCUPostalAddr -- note that Nothing means no change and not delete address! + , (UserPrefersPostal E.=.) . E.val <$> firmActCCUPostalPref + ] + in unless (null changes) $ do + nrChanged <- runDB $ E.updateCount $ \usr -> do + E.set usr changes + E.where_ $ E.exists $ do + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid + E.&&. usrCmpy E.^. UserCompanyUser E.==. usr E.^. UserId + addMessageI Success $ MsgFirmUserChanges nrChanged + reloadKeepGetParams route -- reload to reflect changes + faHandler _ = addMessageI Error MsgErrorUnknownFormAction runFirmActionFormPost :: CompanyId -> Route UniWorX -> [FirmAction] -> Handler Widget -runFirmActionFormPost cid route acts = do - -- ((faRes, faWgt), faEnctype) <- runFormPost . identifyForm FIDFirmAction $ makeFirmActionForm cid acts - ((faRes, faWgt), faEnctype) <- runFormPost $ makeFirmActionForm cid acts +runFirmActionFormPost cid route acts = do + mr <- getMessageRender + ((faRes, faWgt), faEnctype) <- runFormPost . identifyForm FIDFirmAction $ makeFirmActionForm cid mr acts let faAnchor = "firm-action-form" :: Text faRoute = route :#: faAnchor - faForm = wrapForm faWgt FormSettings + faForm = wrapForm faWgt FormSettings { formMethod = POST , formAction = Just . SomeRoute $ faRoute , formEncoding = faEnctype @@ -162,14 +204,17 @@ runFirmActionFormPost cid route acts = do , formAnchor = Just faAnchor } firmActionHandler route faRes - return [whamlet| + return [whamlet|

            _{MsgFirmAction} -
            - ^{faForm} +
            +

            + _{MsgFirmActionInfo} +

            + ^{faForm} |] - + --------------------------- -- Firm specific utilities @@ -190,9 +235,9 @@ resetSupervisors cid employees = do -- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company addDefaultSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64 -addDefaultSupervisors cid employees = do +addDefaultSupervisors cid employees = do E.insertSelectWithConflictCount UniqueUserSupervisor - (do + (do (spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid E.&&. spr E.^. UserCompanySupervisor @@ -205,12 +250,12 @@ addDefaultSupervisors cid employees = do -- like `addDefaultSupervisors`, but selects all employees of given companies from database addDefaultSupervisorsAll :: (CompanyId ~ Element mono, MonoFoldable mono) => Bool -> mono -> DB Int64 -addDefaultSupervisorsAll mutualSupervision cids = do +addDefaultSupervisorsAll mutualSupervision cids = do E.insertSelectWithConflictCount UniqueUserSupervisor - (do + (do (spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany) - E.where_ $ E.and $ guardMonoid (not mutualSupervision) - [ E.not_ $ usr E.^. UserCompanySupervisor ] + E.where_ $ E.and $ guardMonoid (not mutualSupervision) + [ E.not_ $ usr E.^. UserCompanySupervisor ] <> [ spr E.^. UserCompanySupervisor , spr E.^. UserCompanyCompany `E.in_` E.vals cids , usr E.^. UserCompanyCompany `E.in_` E.vals cids @@ -264,7 +309,7 @@ firmCountEmployeeSupervised = E.subSelectCount . fromUserCompany (Just fltr) firmCountEmployeeRerouted :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) firmCountEmployeeRerouted = E.subSelectCount . fromUserCompany (Just fltr) - where + where fltr usrc = E.exists $ do usrSuper <- E.from $ E.table @UserSupervisor E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser @@ -272,7 +317,7 @@ firmCountEmployeeRerouted = E.subSelectCount . fromUserCompany (Just fltr) firmCountEmployeeRerPost :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) firmCountEmployeeRerPost = E.subSelectCount . fromUserCompany (Just fltr) - where + where fltr usrc = E.exists $ do (usrSuper :& usr) <- E.from $ E.table @UserSupervisor @@ -330,7 +375,7 @@ firmCountUserSupervisors :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value firmCountUserSupervisors usrCmp = E.subSelectCount $ do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser - + firmCountUserSupervisorsReroute :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64) firmCountUserSupervisorsReroute usrCmp = E.subSelectCount $ do usrSpr <- E.from $ E.table @UserSupervisor @@ -367,7 +412,7 @@ postFirmR fsh = do siteLayoutMsg (SomeMessage fsh) $ do setTitle $ citext2Html fsh [whamlet| -

            PROVISORISCHE DEBUG SEITE +

            PROVISORISCHE DEBUG SEITE

            Diese Seite wird in der finalen Version nicht mehr enthalten sein.

            #{length csuper} Company Default Supervisors (non-foreign only) @@ -400,21 +445,6 @@ postFirmR fsh = do ----------------------- -- All Firms Table -data FirmAllAction = FirmAllActNotify - | FirmAllActResetSupervision - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) - deriving anyclass (Universe, Finite) - -nullaryPathPiece ''FirmAllAction $ camelToPathPiece' 3 -embedRenderMessage ''UniWorX ''FirmAllAction id - -data FirmAllActionData = FirmAllActNotifyData - | FirmAllActResetSupervisionData - { firmAllActResetKeepOldSupers :: Maybe Bool - , firmAllActResetMutualSupervision :: Maybe Bool - } - deriving (Eq, Ord, Read, Show, Generic) - -- just in case for future extensions type AllCompanyTableExpr = E.SqlExpr (Entity Company) queryAllCompany :: AllCompanyTableExpr -> E.SqlExpr (Entity Company) @@ -440,6 +470,7 @@ resultAllCompanyDefaultReroutes = _dbrOutput . _4 . _unValue mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmActionData, Set CompanyId), Widget) mkFirmAllTable isAdmin uid = do -- now <- liftIO getCurrentTime + mr <- getMessageRender let resultDBTable = DBTable{..} where @@ -448,7 +479,7 @@ mkFirmAllTable isAdmin uid = do usrCmpy <- E.from $ E.table @UserCompany E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId E.&&. ((usrCmpy E.^. UserCompanyUser E.==. E.val uid E.&&. usrCmpy E.^. UserCompanySupervisor) - E.||. E.exists (do + E.||. E.exists (do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmpy E.^. UserCompanyUser E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid @@ -476,12 +507,12 @@ mkFirmAllTable isAdmin uid = do , sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm , sortable (Just "users") (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr - , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupersDefault) $ \row -> + , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupersDefault) $ \row -> anchorCell (FirmSupersR $ row ^. resultAllCompany . _companyShorthand) $ toWgt $ hasTickmark $ row ^. resultAllCompanySupervisors , sortable (Just "reroute-def") (i18nCell MsgTableCompanyNrRerouteDefault) $ \(view resultAllCompanyDefaultReroutes -> ok) -> tickmarkCell ok -- , sortable (Just "emp-supervised")(i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultAllCompanyEmployeeSupervised -> nr) -> wgtCell $ word2widget nr -- , sortable (Just "emp-rerouted") (i18nCell MsgTableCompanyNrEmpRerouted) $ \(view resultAllCompanyEmployeeRerouted -> nr) -> wgtCell $ word2widget nr - -- , sortable (Just "emp-rer-post") (i18nCell MsgTableCompanyNrEmpRerPost) $ \(view resultAllCompanyEmpRerPost -> nr) -> wgtCell $ word2widget nr + -- , sortable (Just "emp-rer-post") (i18nCell MsgTableCompanyNrEmpRerPost) $ \(view resultAllCompanyEmpRerPost -> nr) -> wgtCell $ word2widget nr -- , sortable (Just "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr -- , sortable (Just "reroute-act") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes -> nr) -> wgtCell $ word2widget nr -- , sortable (Just "reroute-all") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes' -> nr) -> wgtCell $ word2widget nr @@ -508,14 +539,14 @@ mkFirmAllTable isAdmin uid = do , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do (usr :& usrCmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany - `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser) + `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser) E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId E.&&. ( (usr E.^. UserDisplayName `E.hasInfix` E.val criterion) E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) ) ) - , single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> + , single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> -- let checkSuper = do -- expensive -- usrSpr <- E.from $ E.table @UserSupervisor -- E.where_ $ E.notExists (do @@ -546,7 +577,7 @@ mkFirmAllTable isAdmin uid = do ) , single ("company-postal", FilterColumn $ E.mkExactFilterLast $ views (to queryAllCompany) (E.isJust . (E.^. CompanyPostAddress))) ] - dbtFilterUI mPrev = mconcat + dbtFilterUI mPrev = mconcat [ fltrCompanyNameUI mPrev , prismAForm (singletonFilter "company-number") mPrev $ aopt textField (fslI MsgTableCompanyNo) , prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) @@ -559,9 +590,7 @@ mkFirmAllTable isAdmin uid = do , dbParamsFormAction = Nothing , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit - -- , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm [FirmActNotify, FirmActResetSupervision] - , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just - <$> multiActionA (firmActionMap [FirmActNotify, FirmActResetSupervision]) (fslI MsgTableAction) Nothing + , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm mr [FirmActNotify, FirmActResetSupervision] , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def @@ -600,28 +629,11 @@ postFirmAllR = do ----------------------- -- Firm Users Table -data FirmUserChangeRequest = FirmUserChangeRequest - { fucrPostalPref :: Maybe Bool - , fucrPostalAddr :: Maybe StoredMarkup - } - deriving (Eq, Ord, Show, Generic) -instance Default FirmUserChangeRequest where - def = FirmUserChangeRequest - { fucrPostalPref = Nothing - , fucrPostalAddr = Nothing - } - -makeFirmUserChangeRequestForm :: Maybe FirmUserChangeRequest -> Form FirmUserChangeRequest -makeFirmUserChangeRequestForm template html = do - flip (renderAForm FormStandard) html $ FirmUserChangeRequest - <$> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) (fucrPostalPref <$> template) - <*> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) (fucrPostalAddr <$> template) - - -data FirmUserAction = FirmUserActNotify +data FirmUserAction = FirmUserActNotify | FirmUserActResetSupervision | FirmUserActMkSuper + | FirmUserActChangeContact deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -630,12 +642,15 @@ embedRenderMessage ''UniWorX ''FirmUserAction id data FirmUserActionData = FirmUserActNotifyData | FirmUserActResetSupervisionData - { firmUserActResetKeepOldSupers :: Maybe Bool + { firmUserActResetKeepOldSupers :: Maybe Bool -- , firmUserActResetMutualSupervision :: Maybe Bool } | FirmUserActMkSuperData { firmUserActMkSuperReroute :: Maybe Bool } - + | FirmUserActChangeContactData + { firmUserActPostalAddr :: Maybe StoredMarkup + , firmUserActPostalPref :: Maybe Bool + } deriving (Eq, Ord, Show, Generic) type UserCompanyTableExpr = E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity UserCompany) @@ -649,7 +664,7 @@ queryUserUserCompany = $(sqlIJproj 2 2) type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64) resultUserUser :: Lens' UserCompanyTableData (Entity User) -resultUserUser = _dbrOutput . _1 +resultUserUser = _dbrOutput . _1 resultUserUserCompany :: Lens' UserCompanyTableData (Entity UserCompany) resultUserUserCompany = _dbrOutput . _2 @@ -660,10 +675,10 @@ resultUserCompanySupervisors = _dbrOutput . _3 . _unValue resultUserCompanyReroutes :: Lens' UserCompanyTableData Word64 resultUserCompanyReroutes = _dbrOutput . _4 . _unValue -instance HasEntity UserCompanyTableData User where +instance HasEntity UserCompanyTableData User where hasEntity = resultUserUser -instance HasUser UserCompanyTableData where +instance HasUser UserCompanyTableData where hasUser = resultUserUser . _entityVal @@ -675,7 +690,7 @@ mkFirmUserTable isAdmin cid = do return Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid } procOptions = fmap mkOptionList . traverse mkSprOption - rawSupers <- E.select $ do + rawSupers <- E.select $ do usr <- E.from $ E.table @User E.where_ $ E.exists $ firmQuerySupervisedBy cid Nothing usr return (usr E.^. UserId, usr E.^. UserDisplayName) @@ -694,7 +709,7 @@ mkFirmUserTable isAdmin cid = do dbtRowKey = queryUserUser >>> (E.^. UserId) dbtProj = dbtProjId dbtColonnade = formColonnade $ mconcat - [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey)) + [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey)) , colUserNameModalHdr MsgTableCompanyUser ForProfileDataR , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinked entUsr , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultUserUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t @@ -715,16 +730,16 @@ mkFirmUserTable isAdmin cid = do ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUserUser - , singletonMap "has-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> - let checkSuper = do + , singletonMap "has-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> + let checkSuper = do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId in case criterion of Nothing -> E.true Just True -> E.exists checkSuper Just False -> E.notExists checkSuper - , singletonMap "has-company-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> - let checkSuper = do + , singletonMap "has-company-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> + let checkSuper = do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId E.&&. E.exists (do @@ -736,8 +751,8 @@ mkFirmUserTable isAdmin cid = do Nothing -> E.true Just True -> E.exists checkSuper Just False -> E.notExists checkSuper - , singletonMap "has-foreign-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> - let checkSuper = do + , singletonMap "has-foreign-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> + let checkSuper = do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId E.&&. E.notExists (do @@ -750,20 +765,20 @@ mkFirmUserTable isAdmin cid = do Just True -> E.exists checkSuper Just False -> E.notExists checkSuper , singletonMap "supervisor-is" $ FilterColumn $ \row (getLast -> criterion) -> - case criterion of - Just uid -> do + case criterion of + Just uid -> do -- uid <- decryptUser uuid - E.exists $ do + E.exists $ do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid _otherwise -> E.true , singletonMap "supervisors-are" $ FilterColumn $ \row criteria -> - case criteria of + case criteria of _ | Set.null criteria -> E.true | otherwise -> do -- uids <- traverse decryptUser criteria - E.exists $ do + E.exists $ do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId E.&&. usrSpr E.^. UserSupervisorSupervisor `E.in_` E.vals criteria @@ -771,7 +786,7 @@ mkFirmUserTable isAdmin cid = do -- superField = selectField $ ???? dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev - , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) + , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor) , prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor) , prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh) @@ -782,10 +797,13 @@ mkFirmUserTable isAdmin cid = do acts = mconcat [ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData - <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep) (Just $ Just False) - -- <*> aopt checkBoxField (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True ) + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) + -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) + , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData + <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing ] dbtParams = DBParamsForm { dbParamsFormMethod = POST @@ -812,7 +830,7 @@ mkFirmUserTable isAdmin cid = do let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m return (act, s) - -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) + -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmActionData, DBFormResult CompanyId Bool FirmActionData)) resultDBTableValidator = def & defaultSorting [SortAscBy "user-name"] over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable @@ -832,7 +850,7 @@ postFirmUsersR fsh = do , E.Value nrCompanyEmployeeRerPost , E.Value nrCompanyDefaultReroutes , E.Value nrCompanyActiveReroutes - ) , (fusrRes, fusrTable)) <- runDB $ (,) + ) , (fusrRes, fusrTable)) <- runDB $ (,) <$> fromMaybeM notFound (E.selectOne $ do cmpy <- E.from $ E.table @Company E.where_ $ cmpy E.^. CompanyId E.==. E.val cid @@ -846,17 +864,17 @@ postFirmUsersR fsh = do , cmpy & firmCountDefaultReroutes , cmpy & firmCountActiveReroutes )) - -- superVs <- E.select $ do + -- superVs <- E.select $ do -- usr <- E.from $ E.table @User -- E.where_ $ E.exists $ firmQuerySupervisedBy cmpyId Nothing usr -- return usr - <*> mkFirmUserTable isAdmin cid + <*> mkFirmUserTable isAdmin cid - formResult fusrRes $ \case + formResult fusrRes $ \case (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice - (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do + (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)] - addMessageI Info $ MsgASReqSetSupers nrMkSuper Nothing + addMessageI Info $ MsgFirmActAddSupersSet nrMkSuper Nothing reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes (FirmUserActNotifyData , uids) -> do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] @@ -865,34 +883,21 @@ postFirmUsersR fsh = do runDB $ do delSupers <- if firmUserActResetKeepOldSupers == Just False then deleteSupervisors uids - else return 0 + else return 0 newSupers <- addDefaultSupervisors cid uids addMessageI Info $ MsgFirmResetSupervision delSupers newSupers reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes - - ((fucrRes, fucrWgt), fucrEnctype) <- runFormPost . identifyForm FIDFirmUserChangeRequest $ makeFirmUserChangeRequestForm (Just def) - let addFormAnchor = "firm-user-change-form" :: Text - routeForm = FirmUsersR fsh :#: addFormAnchor - fucrForm = wrapForm fucrWgt FormSettings - { formMethod = POST - , formAction = Just . SomeRoute $ routeForm - , formEncoding = fucrEnctype - , formAttrs = [] - , formSubmit = FormSubmit - , formAnchor = Just addFormAnchor - } - formResult fucrRes $ \FirmUserChangeRequest{fucrPostalPref=fucrPPref, fucrPostalAddr=(canonical -> fucrPAddr)} -> do - when (isJust fucrPPref || isJust fucrPAddr) $ do - let changes = foldMap (\pp -> [UserPrefersPostal E.=. E.val pp]) fucrPPref <> - foldMap (\pa -> [UserPostAddress E.=. E.justVal pa]) fucrPAddr -- seems weird, but: Nothing means no change, and not delete address! - nrChanged <- runDB $ E.updateCount $ \usr -> do - E.set usr changes - E.where_ $ E.exists $ do - usrCmpy <- E.from $ E.table @UserCompany - E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid - E.&&. usrCmpy E.^. UserCompanyUser E.==. usr E.^. UserId - addMessageI Info $ MsgFirmUserChanges nrChanged - reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + (FirmUserActChangeContactData{..}, Set.toList -> uids) -> + let changes = catMaybes + [ (UserPostAddress =.) . Just <$> canonical firmUserActPostalAddr -- note that Nothing means no change and not delete address! + , (UserPrefersPostal =.) <$> firmUserActPostalPref + ] + in unless (null changes) $ do + nrChanged <- runDB $ updateWhereCount [UserId <-. uids] changes + addMessageI Success $ MsgFirmUserChanges nrChanged + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + + formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) [FirmActNotify, FirmActResetSupervision, FirmActAddSupersvisors, FirmActChangeContactFirm, FirmActChangeContactUser] siteLayout (citext2widget companyName) $ do setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId @@ -903,9 +908,9 @@ postFirmUsersR fsh = do ----------------------------- -- Firm Supervisors Table -data FirmSuperAction = FirmSuperActNotify +data FirmSuperAction = FirmSuperActNotify | FirmSuperActRMSuperDef - + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -915,32 +920,10 @@ embedRenderMessage ''UniWorX ''FirmSuperAction id data FirmSuperActionData = FirmSuperActNotifyData | FirmSuperActRMSuperDefData { firmSuperActRMSuperActive :: Maybe Bool } - + deriving (Eq, Ord, Show, Generic) -data AddSupervisorRequest = AddSupervisorRequest - { asReqSupers :: Set Text - , asReqReroute :: Bool - , asReqPostal :: Maybe Bool - } deriving (Eq, Ord, Show, Generic) - -instance Default AddSupervisorRequest where - def = AddSupervisorRequest - { asReqSupers = mempty - , asReqReroute = True - , asReqPostal = Nothing - } - -makeAddSupervisorForm :: Maybe AddSupervisorRequest -> Form AddSupervisorRequest -makeAddSupervisorForm template html = do - flip (renderAForm FormStandard) html $ AddSupervisorRequest - <$> areq (textField & cfAnySeparatedSet) - (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) (asReqSupers <$> template) - <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (asReqReroute <$> template) - <*> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) (asReqPostal <$> template) - - type SuperCompanyTableExpr = E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserCompany)) querySuperUser :: SuperCompanyTableExpr -> E.SqlExpr (Entity User) @@ -955,7 +938,7 @@ type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64 ) resultSuperUser :: Lens' SuperCompanyTableData (Entity User) -resultSuperUser = _dbrOutput . _1 +resultSuperUser = _dbrOutput . _1 resultSuperCompanySupervised :: Lens' SuperCompanyTableData Word64 resultSuperCompanySupervised = _dbrOutput . _2 . _unValue @@ -972,10 +955,10 @@ resultSuperCompanyDefaultSuper = _dbrOutput . _5 . _unValue resultSuperCompanyDefaultReroute :: Lens' SuperCompanyTableData (Maybe Bool) resultSuperCompanyDefaultReroute = _dbrOutput . _6 . _unValue -instance HasEntity SuperCompanyTableData User where +instance HasEntity SuperCompanyTableData User where hasEntity = resultSuperUser -instance HasUser SuperCompanyTableData where +instance HasUser SuperCompanyTableData where hasUser = resultSuperUser . _entityVal @@ -997,7 +980,7 @@ mkFirmSuperTable isAdmin cid = do ) dbtRowKey = querySuperUser >>> (E.^. UserId) dbtProj = dbtProjSimple $ \(usr, supervised, rerouted, supervisor, reroute) -> do - cmps <- E.select $ do + cmps <- E.select $ do (cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany) E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val (entityKey usr) E.orderBy [E.asc $ cmp E.^. CompanyName] @@ -1020,7 +1003,7 @@ mkFirmSuperTable isAdmin cid = do ] dbtSorting = mconcat [ single $ sortUserNameLink querySuperUser - , single $ sortUserEmail querySuperUser + , single $ sortUserEmail querySuperUser , singletonMap "matriculation" $ SortColumn $ querySuperUser >>> (E.^. UserMatrikelnummer) , singletonMap "personal-number" $ SortColumn $ querySuperUser >>> (E.^. UserCompanyPersonalNumber) , singletonMap "postal-pref" $ SortColumn $ querySuperUser >>> (E.^. UserPrefersPostal) @@ -1045,7 +1028,7 @@ mkFirmSuperTable isAdmin cid = do acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData) acts = mconcat [ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData - , singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData + , singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData <$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True) ] dbtParams = DBParamsForm @@ -1072,7 +1055,7 @@ mkFirmSuperTable isAdmin cid = do (First (Just act), m) <- inp let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m return (act, s) - + resultDBTableValidator = def & defaultSorting [SortAscBy "user-name"] over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable @@ -1089,7 +1072,7 @@ postFirmSupersR fsh = do formResult fsprRes $ \case (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice - (FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do + (FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do (nrRmSuper,nrRmActual) <- runDB $ (,) <$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False] <*> if firmSuperActRMSuperActive /= Just True @@ -1100,49 +1083,16 @@ postFirmSupersR fsh = do E.&&. E.exists (do usr <- E.from $ E.table @UserCompany E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid - E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser - ) + E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser + ) addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes - - (FirmSuperActNotifyData , uids) -> do + + (FirmSuperActNotifyData , uids) -> do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) - formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) [FirmActAddSupervisors, FirmActResetSupervision] - - ((asReqRes, asReqWgt), asReqEnctype) <- runFormPost . identifyForm FIDAddSupervisor $ makeAddSupervisorForm (Just def) - let addSuperAnchor = "add-supervisors-form" :: Text - routeAddSuperForm = FirmSupersR fsh :#: addSuperAnchor - addSuperForm = wrapForm asReqWgt FormSettings - { formMethod = POST - , formAction = Just . SomeRoute $ routeAddSuperForm - , formEncoding = asReqEnctype - , formAttrs = [] - , formSubmit = FormSubmit - , formAnchor = Just addSuperAnchor - } - formResult asReqRes $ \AddSupervisorRequest{..} -> do - avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser asReqSupers - let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers - usersFound = mapMaybe snd usersFound' - unless (null usersNotFound) $ - let msgContent = [whamlet| - $newline never -
              - $forall (usr,_) <- usersNotFound -
            • #{usr} - |] - in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) - when (null usersFound) $ do - addMessageI Warning MsgASReqEmpty - redirect routeAddSuperForm - runDB $ do - putMany [UserCompany uid cid True asReqReroute | uid <- usersFound] - whenIsJust asReqPostal $ \prefPostal -> - updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal] - addMessageI Info $ MsgASReqSetSupers (fromIntegral $ length usersFound) asReqPostal - redirect $ FirmSupersR fsh + formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) [FirmActAddSupersvisors, FirmActResetSupervision, FirmActChangeContactFirm] siteLayout (citext2widget fsh) $ do setTitle $ citext2Html $ fsh <> " Supers" @@ -1167,9 +1117,9 @@ postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR) handleFirmCommR :: SomeRoute UniWorX -> Companies -> Handler Html handleFirmCommR _ [] = invalidArgs ["At least one company name must be provided."] handleFirmCommR ultDest cs = do - let + let queryGiven :: [UserId] -> E.SqlQuery (E.SqlExpr (Entity User)) -- get users from a list of UserIds - queryGiven usrs = do + queryGiven usrs = do usr <- E.from $ E.table @User E.where_ $ usr E.^. UserId `E.in_` E.valList usrs return usr @@ -1179,14 +1129,14 @@ handleFirmCommR ultDest cs = do csKeys = CompanyKey <$> cs mbUser <- maybeAuthId -- get employees of chosen companies - empys <- mkCompanyUsrList <$> runDB (E.select $ do + empys <- mkCompanyUsrList <$> runDB (E.select $ do (emp :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& cmp) -> emp E.^. UserId E.==. cmp E.^. UserCompanyUser) - E.where_ $ cmp E.^. UserCompanyCompany `E.in_` E.valList csKeys + E.where_ $ cmp E.^. UserCompanyCompany `E.in_` E.valList csKeys E.orderBy [E.ascNullsFirst $ cmp E.^. UserCompanyCompany] return (E.just $ cmp E.^. UserCompanyCompany, emp E.^. UserId) ) - -- get supervisors of employees - sprs <- mkCompanyUsrList <$> runDB (E.select $ do + -- get supervisors of employees + sprs <- mkCompanyUsrList <$> runDB (E.select $ do (spr :& cmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(spr :& cmp) -> spr E.^. UserId E.=?. cmp E.?. UserCompanyUser) E.where_ $ (E.isTrue (cmp E.?. UserCompanySupervisor) E.&&. cmp E.?. UserCompanyCompany `E.in_` E.justValList csKeys) E.||. (spr E.^. UserId E.=?. E.val mbUser) @@ -1197,24 +1147,24 @@ handleFirmCommR ultDest cs = do ) E.orderBy [E.ascNullsFirst $ cmp E.?. UserCompanyCompany] return (cmp E.?. UserCompanyCompany, spr E.^. UserId) - ) - + ) + commR CommunicationRoute { crHeading = SomeMessage $ case cs of { [c] -> MsgFirmNotification c ; _ -> MsgFirmsNotification } , crTitle = SomeMessage $ case cs of { [c] -> MsgFirmNotificationTitle c ; _ -> MsgFirmsNotificationTitle } , crUltDest = ultDest - , crJobs = crJobsFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () - , crTestJobs = crTestFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () - , crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult - , crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))] + , crJobs = crJobsFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () + , crTestJobs = crTestFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () + , crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult + , crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))] [(toGrp acid, queryGiven usrs) | (acid, usrs) <- Map.toAscList sprs ] ++ [(RGFirmEmployees $ unCompanyKey acid, queryGiven usrs) | (Just acid, usrs) <- Map.toAscList empys ] } {- Auswahlbox für Mitteilung: Wenn Firma gewählt, dann zeige: - Alle Supervisor von Leuten in X, gruppiert nach deren Firma - Alle Teilnehmer von X + Alle Supervisor von Leuten in X, gruppiert nach deren Firma + Alle Teilnehmer von X Wenn keine Firma gewählt, dann zeige: Alle Supervisor von gewählten Leuten, gruppiert nach deren Firma Alle gewählten Personen, gruppiert nach deren Firma diff --git a/src/Utils.hs b/src/Utils.hs index 324f71aa7..a2b35c37a 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1993,3 +1993,10 @@ instance Canonical (Maybe Text) where -- a split into Canonical Text and Canonic | Text.null t' -> Nothing | t == t' -> r | otherwise -> Just t' + +instance Canonical (Maybe (CI Text)) where -- a split into Canonical Text and Canonical a => Maybe seems nicer, but the latter instance would be troublesome + canonical Nothing = Nothing + canonical r@(Just t) = let t' = CI.map Text.strip t in if + | mempty == t'-> Nothing + | t == t' -> r + | otherwise -> Just t' diff --git a/templates/firm-contact-info.hamlet b/templates/firm-contact-info.hamlet index 8aea13ab1..a251650db 100644 --- a/templates/firm-contact-info.hamlet +++ b/templates/firm-contact-info.hamlet @@ -9,12 +9,16 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
              $maybe fem <- companyEmail
              - _{MsgFirmEmail} #{iconLetterOrEmail False} + _{MsgFirmEmail} + $if not companyPrefersPostal +   #{iconLetterOrEmail False}
              #{mailtoHtml fem} $maybe addr <- companyPostAddress
              - _{MsgFirmAddress} #{iconLetterOrEmail True} + _{MsgFirmAddress} + $if companyPrefersPostal +   #{iconLetterOrEmail True}
              #{addr} $nothing diff --git a/templates/firm-users.hamlet b/templates/firm-users.hamlet index 19c41bb64..c10c06e13 100644 --- a/templates/firm-users.hamlet +++ b/templates/firm-users.hamlet @@ -6,6 +6,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{firmContactInfo} +^{formFirmAction} +
              @@ -55,9 +57,3 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later _{MsgFirmAssociates}

              ^{fusrTable} - -

              -

              - Heading TODO -
              - ^{fucrForm} \ No newline at end of file diff --git a/templates/i18n/firm-supervisors/de-de-formal.hamlet b/templates/i18n/firm-supervisors/de-de-formal.hamlet index bd9fdf4db..ddd921f87 100644 --- a/templates/i18n/firm-supervisors/de-de-formal.hamlet +++ b/templates/i18n/firm-supervisors/de-de-formal.hamlet @@ -15,7 +15,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{formFirmAction}
              - ^{fsprTable} - -
              - ^{addSuperForm} \ No newline at end of file +

              + _{MsgTableSupervisor} +
              + ^{fsprTable} diff --git a/templates/i18n/firm-supervisors/en-eu.hamlet b/templates/i18n/firm-supervisors/en-eu.hamlet index 8edcdeeec..09a6a37c5 100644 --- a/templates/i18n/firm-supervisors/en-eu.hamlet +++ b/templates/i18n/firm-supervisors/en-eu.hamlet @@ -14,7 +14,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{formFirmAction}
              - ^{fsprTable} +

              + _{MsgTableSupervisor} +
              + ^{fsprTable} -
              - ^{addSuperForm} From 212cb7180764109924fb09ce3ed748695f0f2cd2 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 24 Nov 2023 17:44:27 +0100 Subject: [PATCH 038/110] chore(firm): limit firm action access to admins --- routes | 4 +-- src/Handler/Firm.hs | 61 +++++++++++++++++++++++---------------------- 2 files changed, 33 insertions(+), 32 deletions(-) diff --git a/routes b/routes index d341734ac..df8c32fa2 100644 --- a/routes +++ b/routes @@ -115,9 +115,9 @@ /firms FirmAllR GET POST !supervisor /firms/comm/+Companies FirmsCommR GET POST -/firm/#CompanyShorthand FirmR GET POST +/firm/#CompanyShorthand/debug FirmR GET POST /firm/#CompanyShorthand/comm FirmCommR GET POST -/firm/#CompanyShorthand/users FirmUsersR GET POST !supervisor +/firm/#CompanyShorthand FirmUsersR GET POST !supervisor /firm/#CompanyShorthand/supers FirmSupersR GET POST !supervisor /exam-office ExamOfficeR !exam-office: diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 9ed737280..429f7db72 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -62,7 +62,7 @@ data FirmAction = FirmActNotify deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) -nullaryPathPiece ''FirmAction $ camelToPathPiece' 2 +nullaryPathPiece ''FirmAction $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''FirmAction id data FirmActionData = FirmActNotifyData @@ -86,28 +86,29 @@ data FirmActionData = FirmActNotifyData } deriving (Eq, Ord, Read, Show, Generic) -firmActionMap :: _ -> [FirmAction] -> Map FirmAction (AForm Handler FirmActionData) -firmActionMap mr acts = mconcat (mkAct <$> acts) +firmActionMap :: _ -> Bool -> [FirmAction] -> Map FirmAction (AForm Handler FirmActionData) +firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts) where - mkAct FirmActNotify = singletonMap FirmActNotify $ pure FirmActNotifyData - mkAct FirmActResetSupervision = singletonMap FirmActResetSupervision $ FirmActResetSupervisionData - <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) - <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) - mkAct FirmActAddSupersvisors = singletonMap FirmActAddSupersvisors $ FirmActAddSupersvisorsData - <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing - <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) - <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing - mkAct FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData - <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing - <*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail) Nothing - <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing - <* aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive)) - mkAct FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData - <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing - <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + mkAct True FirmActNotify = singletonMap FirmActNotify $ pure FirmActNotifyData + mkAct _ FirmActResetSupervision = singletonMap FirmActResetSupervision $ FirmActResetSupervisionData + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) + <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) + mkAct _ FirmActAddSupersvisors = singletonMap FirmActAddSupersvisors $ FirmActAddSupersvisorsData + <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + mkAct _ FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData + <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing + <*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + <* aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive)) + mkAct _ FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData + <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + mkAct _ _ = mempty -firmActionForm :: _ -> [FirmAction] -> AForm Handler FirmActionData -firmActionForm mr acts = multiActionA (firmActionMap mr acts) (fslI MsgTableAction) Nothing +firmActionForm :: () -> Bool -> [FirmAction] -> AForm Handler FirmActionData +firmActionForm mr isAdmin acts = multiActionA (firmActionMap mr isAdmin acts) (fslI MsgTableAction) Nothing makeFirmActionForm :: CompanyId -> _ -> [FirmAction] -> Form (FirmActionData, Set CompanyId) makeFirmActionForm cid mr acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm mr acts @@ -189,10 +190,10 @@ firmActionHandler route = flip formResult faHandler faHandler _ = addMessageI Error MsgErrorUnknownFormAction -runFirmActionFormPost :: CompanyId -> Route UniWorX -> [FirmAction] -> Handler Widget -runFirmActionFormPost cid route acts = do +runFirmActionFormPost :: CompanyId -> Route UniWorX -> Bool -> [FirmAction] -> Handler Widget +runFirmActionFormPost cid route isAdmin acts = do mr <- getMessageRender - ((faRes, faWgt), faEnctype) <- runFormPost . identifyForm FIDFirmAction $ makeFirmActionForm cid mr acts + ((faRes, faWgt), faEnctype) <- runFormPost . identifyForm FIDFirmAction $ makeFirmActionForm cid mr isAdmin acts let faAnchor = "firm-action-form" :: Text faRoute = route :#: faAnchor faForm = wrapForm faWgt FormSettings @@ -590,7 +591,7 @@ mkFirmAllTable isAdmin uid = do , dbParamsFormAction = Nothing , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit - , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm mr [FirmActNotify, FirmActResetSupervision] + , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm mr isAdmin [FirmActNotify, FirmActResetSupervision] , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def @@ -618,7 +619,7 @@ getFirmAllR, postFirmAllR :: Handler Html getFirmAllR = postFirmAllR postFirmAllR = do uid <- requireAuthId - isAdmin <- hasReadAccessTo AdminR + isAdmin <- checkAdmin (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins firmActionHandler FirmAllR firmRes siteLayoutMsg MsgMenuFirms $ do @@ -839,7 +840,7 @@ mkFirmUserTable isAdmin cid = do getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html getFirmUsersR = postFirmUsersR postFirmUsersR fsh = do - isAdmin <- hasReadAccessTo AdminR + isAdmin <- checkAdmin let cid = CompanyKey fsh (( Entity{entityVal=Company{..}} , E.Value nrCompanyUsers @@ -897,7 +898,7 @@ postFirmUsersR fsh = do addMessageI Success $ MsgFirmUserChanges nrChanged reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes - formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) [FirmActNotify, FirmActResetSupervision, FirmActAddSupersvisors, FirmActChangeContactFirm, FirmActChangeContactUser] + formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupersvisors, FirmActChangeContactFirm, FirmActChangeContactUser] siteLayout (citext2widget companyName) $ do setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId @@ -1064,7 +1065,7 @@ mkFirmSuperTable isAdmin cid = do getFirmSupersR, postFirmSupersR :: CompanyShorthand -> Handler Html getFirmSupersR = postFirmSupersR postFirmSupersR fsh = do - isAdmin <- hasReadAccessTo AdminR + isAdmin <- checkAdmin let cid = CompanyKey fsh (Company{..},(fsprRes,fsprTable)) <- runDB $ (,) <$> get404 cid @@ -1092,7 +1093,7 @@ postFirmSupersR fsh = do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) - formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) [FirmActAddSupersvisors, FirmActResetSupervision, FirmActChangeContactFirm] + formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) isAdmin [FirmActAddSupersvisors, FirmActResetSupervision, FirmActChangeContactFirm] siteLayout (citext2widget fsh) $ do setTitle $ citext2Html $ fsh <> " Supers" From 06bb44cf715375b5dd0141a46f8e10924ad6cd9c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 24 Nov 2023 18:02:03 +0100 Subject: [PATCH 039/110] fix(build): minor errors firm handler --- src/Handler/Firm.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 429f7db72..0eeaa5edd 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -86,7 +86,7 @@ data FirmActionData = FirmActNotifyData } deriving (Eq, Ord, Read, Show, Generic) -firmActionMap :: _ -> Bool -> [FirmAction] -> Map FirmAction (AForm Handler FirmActionData) +firmActionMap :: (_ -> Text) -> Bool -> [FirmAction] -> Map FirmAction (AForm Handler FirmActionData) firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts) where mkAct True FirmActNotify = singletonMap FirmActNotify $ pure FirmActNotifyData @@ -107,11 +107,11 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts) <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing mkAct _ _ = mempty -firmActionForm :: () -> Bool -> [FirmAction] -> AForm Handler FirmActionData +firmActionForm :: _ -> Bool -> [FirmAction] -> AForm Handler FirmActionData firmActionForm mr isAdmin acts = multiActionA (firmActionMap mr isAdmin acts) (fslI MsgTableAction) Nothing -makeFirmActionForm :: CompanyId -> _ -> [FirmAction] -> Form (FirmActionData, Set CompanyId) -makeFirmActionForm cid mr acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm mr acts +makeFirmActionForm :: CompanyId -> _ -> Bool -> [FirmAction] -> Form (FirmActionData, Set CompanyId) +makeFirmActionForm cid mr isAdmin acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm mr isAdmin acts firmActionHandler :: Route UniWorX -> FormResult (FirmActionData, Set CompanyId) -> Handler () firmActionHandler route = flip formResult faHandler From 17bde4de09fd535f0012e59af79b10ca33dadae2 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 24 Nov 2023 19:55:43 +0000 Subject: [PATCH 040/110] chore(release): 27.4.51 --- CHANGELOG.md | 9 +++++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 13 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 08967c314..54de9bc9a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,15 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [27.4.51](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.50...v27.4.51) (2023-11-24) + + +### Bug Fixes + +* **build:** minor errors firm handler ([06bb44c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/06bb44cf715375b5dd0141a46f8e10924ad6cd9c)) +* **cache:** remove risky caching for submissions ([4ae59fc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4ae59fc1fa658e1462139ddddd6dc80308d85872)) +* **firm:** show default supervisors with no employees too ([0f9a7a8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0f9a7a8c53d216ca7a6d0a25462b19ab1fa00bb4)) + ## [27.4.50](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.49...v27.4.50) (2023-11-17) diff --git a/nix/docker/version.json b/nix/docker/version.json index 2140ac34f..ac2140316 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.50" + "version": "27.4.51" } diff --git a/package-lock.json b/package-lock.json index 0f9458042..8c57be9a2 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.50", + "version": "27.4.51", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 06948aab1..31aa2b12d 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.50", + "version": "27.4.51", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 4cacc5a3b..5856789ac 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.50 +version: 27.4.51 dependencies: - base - yesod From 640a2e61d146f16c32b1cdfa7f13d277860cde21 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 27 Nov 2023 12:07:17 +0100 Subject: [PATCH 041/110] chore(messages): Add SomeMessages newtype SomeMessages provides a RenderMessage instance for a list of messages. --- messages/uniworx/utils/utils/de-de-formal.msg | 1 + messages/uniworx/utils/utils/en-eu.msg | 1 + src/Foundation/I18n.hs | 14 ++++++++++++++ src/Handler/Firm.hs | 14 +++++++------- src/Handler/Utils/Table/Pagination.hs | 1 + 5 files changed, 24 insertions(+), 7 deletions(-) diff --git a/messages/uniworx/utils/utils/de-de-formal.msg b/messages/uniworx/utils/utils/de-de-formal.msg index f25770b33..067b7ba11 100644 --- a/messages/uniworx/utils/utils/de-de-formal.msg +++ b/messages/uniworx/utils/utils/de-de-formal.msg @@ -97,6 +97,7 @@ RoomReferenceLinkLinkPlaceholder !ident-ok: URL RoomReferenceLinkInstructions: Anweisungen RoomReferenceLinkInstructionsPlaceholder: Anweisungen UtilEmptyChoice: Auswahl war leer +UtilEmptyNoChangeTip: Eine leere Eingabe belässt den vorherigen Wert unverändert. #invitation.hs InvitationAction: Aktion diff --git a/messages/uniworx/utils/utils/en-eu.msg b/messages/uniworx/utils/utils/en-eu.msg index 97f5daa22..cafb5fac8 100644 --- a/messages/uniworx/utils/utils/en-eu.msg +++ b/messages/uniworx/utils/utils/en-eu.msg @@ -97,6 +97,7 @@ RoomReferenceLinkLinkPlaceholder: URL RoomReferenceLinkInstructions: Instructions RoomReferenceLinkInstructionsPlaceholder: Instructions UtilEmptyChoice: Empty selection +UtilEmptyNoChangeTip: Existing values remain unchanged if this field is left empty. #invitation.hs InvitationAction: Action diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 8c8a0137b..571fd0249 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -43,6 +43,8 @@ module Foundation.I18n , UniWorXMessages(..) , uniworxMessages , unRenderMessage, unRenderMessage', unRenderMessageLenient + , SomeMessages(..) + , someMessages , module Foundation.I18n.TH ) where @@ -266,6 +268,18 @@ mkMessageAddition ''UniWorX "Avs" "messages/uniworx/categories/avs" "de-de-forma embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3) + +newtype SomeMessages master = SomeMessages [SomeMessage master] + deriving newtype (Semigroup, Monoid) + +instance master ~ master' => RenderMessage master (SomeMessages master') where + renderMessage a b (SomeMessages msgs) = Text.intercalate " " $ renderMessage a b <$> msgs + +-- | convenienience function if all messages happen to belong to the exact same type +someMessages :: RenderMessage master msg => [msg] -> SomeMessages master +someMessages msgs = SomeMessages $ SomeMessage <$> msgs + + instance RenderMessage UniWorX (Maybe LmsStatus) where -- useful for Filter with optionsFinite renderMessage f ls (Just s) = renderMessage f ls s renderMessage f ls Nothing = renderMessage f ls MsgLmsStateOpen diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 0eeaa5edd..d5cd1da0b 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -98,13 +98,13 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts) <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing mkAct _ FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData - <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing - <*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail) Nothing - <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing + <*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUtilEmptyNoChangeTip) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing <* aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive)) mkAct _ FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData - <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing - <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing mkAct _ _ = mempty firmActionForm :: _ -> Bool -> [FirmAction] -> AForm Handler FirmActionData @@ -803,8 +803,8 @@ mkFirmUserTable isAdmin cid = do , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData - <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing - <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing ] dbtParams = DBParamsForm { dbParamsFormMethod = POST diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 415fb255b..0d5182704 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -1723,6 +1723,7 @@ i18nCell msg = cell $ do cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a cellTooltip = cellTooltipIcon Nothing +-- note that you can also use `cellTooltip` with `SomeMessages`, which uses ' ' for separation only cellTooltips :: (RenderMessage UniWorX msg, IsDBTable m a) => [msg] -> DBCell m a -> DBCell m a cellTooltips msgs = cellTooltipWgt Nothing [whamlet| $forall msg <- msgs From 0a06efd76c63180c996657c2c7d78efc5bddd83d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 27 Nov 2023 17:49:06 +0100 Subject: [PATCH 042/110] fix(firm): restrict firm access to company supervisors only --- .../uniworx/categories/firm/de-de-formal.msg | 4 +- messages/uniworx/categories/firm/en-eu.msg | 6 +- src/Foundation/Authorization.hs | 3 +- src/Foundation/I18n.hs | 2 +- src/Handler/Firm.hs | 66 ++++++++++++++----- 5 files changed, 57 insertions(+), 24 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 3158130c1..0d872dba0 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -9,7 +9,7 @@ FirmEmail: Allgemeine Email FirmAddress: Postanschrift FirmDefaultPreferenceInfo: Diese Voreinstellungen gelten nur für neue Firmenangehörige FirmAction: Firmenweite Aktion -FirmActionInfo: Betrifft alle Firmenangehörigen. +FirmActionInfo: Betrifft alle Firmenangehörigen unter Ihrer Aufsicht. FirmActNotify: Mitteilung versenden FirmActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten? @@ -18,7 +18,7 @@ FirmActAddSupersvisors: Ansprechpartner hinzufügen FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner eingetragen #{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)} -FirmActChangeContactUser: Kontaktinformationen von Firmenangehörigen ändern +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. FirmActChangeContactFirmResult: Firmenkontaktinformationen geändert. Betrifft nur neue Firmenangehörige ohne eigene Kontaktinformationen diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index b73afc808..0554ce6e9 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -9,7 +9,7 @@ FirmEmail: General company email FirmAddress: Postal address FirmDefaultPreferenceInfo: Default setting for new company associates only FirmAction: Companywide action -FirmActionInfo: Affects alle company associates. +FirmActionInfo: Affects alle company associates under your supervision. FirmActNotify: Send message FirmActResetSupervision: Reset supervisors for all company associates FirmActResetSuperKeep: Additionally keep existing supervisors of company associates? @@ -17,8 +17,8 @@ FirmActResetMutualSupervision: Supervisors supervise each other FirmActAddSupersvisors: Add supervisors FirmActAddSupersEmpty: No supervisors added FirmActAddSupersSet n postal: #{n} default company supervisors set #{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 supervisons terminated") (nact > 0)} -FirmActChangeContactUser: Change contact data for company associates +RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet 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. FirmActChangeContactFirmResult: Company contact data changed, affecting future company associates without contact information only diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 7ca298622..0243b0609 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -554,7 +554,8 @@ tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of return Authorized checkCompanySupervisor sup@(mAuthId, fsh) = $cachedHereBinary sup . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isSupervisor <- lift . existsBy $ UniqueUserCompany authId $ CompanyKey fsh + -- isSupervisor <- lift . existsBy $ UniqueUserCompany authId $ CompanyKey fsh + isSupervisor <- lift $ exists [UserCompanyUser ==. authId, UserCompanyCompany ==. CompanyKey fsh, UserCompanySupervisor ==. True] guardMExceptT isSupervisor (unauthorizedI $ MsgUnauthorizedCompanySupervisor fsh) return Authorized checkAnySupervisor mAuthId = $cachedHereBinary mAuthId . exceptT return return $ do diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 571fd0249..fd2bb9479 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -273,7 +273,7 @@ newtype SomeMessages master = SomeMessages [SomeMessage master] deriving newtype (Semigroup, Monoid) instance master ~ master' => RenderMessage master (SomeMessages master') where - renderMessage a b (SomeMessages msgs) = Text.intercalate " " $ renderMessage a b <$> msgs + renderMessage a b (SomeMessages msgs) = Text.intercalate "\n " $ renderMessage a b <$> msgs -- | convenienience function if all messages happen to belong to the exact same type someMessages :: RenderMessage master msg => [msg] -> SomeMessages master diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index d5cd1da0b..6030a9052 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -113,23 +113,10 @@ firmActionForm mr isAdmin acts = multiActionA (firmActionMap mr isAdmin acts) (f makeFirmActionForm :: CompanyId -> _ -> Bool -> [FirmAction] -> Form (FirmActionData, Set CompanyId) makeFirmActionForm cid mr isAdmin acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm mr isAdmin acts -firmActionHandler :: Route UniWorX -> FormResult (FirmActionData, Set CompanyId) -> Handler () -firmActionHandler route = flip formResult faHandler +firmActionHandler :: Route UniWorX -> Bool -> FormResult (FirmActionData, Set CompanyId) -> Handler () +firmActionHandler route isAdmin = flip formResult faHandler where faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected - faHandler (FirmActResetSupervisionData{..}, fids) = do - runDB $ do - delSupers <- if firmActResetKeepOldSupers == Just False - then E.deleteCount $ do - spr <- E.from $ E.table @UserSupervisor - E.where_ $ E.exists $ do - usr <- E.from $ E.table @UserCompany - E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids - E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser - else return 0 - newSupers <- addDefaultSupervisorsAll (firmActResetMutualSupervision /= Just False) fids - addMessageI Success $ MsgFirmResetSupervision delSupers newSupers - reloadKeepGetParams route -- reload to reflect changes faHandler (FirmActNotifyData, Set.toList -> fids) = do usrs <- runDB $ E.select $ E.distinct $ do @@ -139,6 +126,26 @@ firmActionHandler route = flip formResult faHandler cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + faHandler (FirmActResetSupervisionData{..}, fids) = do + madId <- bool maybeAuthId (return Nothing) isAdmin + let suprFltr = if + | isAdmin -> const E.true + | (Just suprId) <- madId -> \spr -> spr E.^. UserSupervisorSupervisor E.==. E.val suprId + | otherwise -> const E.false + runDB $ do + delSupers <- if firmActResetKeepOldSupers == Just False + then E.deleteCount $ do + spr <- E.from $ E.table @UserSupervisor + E.where_ $ suprFltr spr E.&&. E.exists (do + usr <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids + E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser + ) + else return 0 + newSupers <- addDefaultSupervisorsFor madId (firmActResetMutualSupervision /= Just False) fids + addMessageI Success $ MsgFirmResetSupervision delSupers newSupers + reloadKeepGetParams route -- reload to reflect changes + faHandler (FirmActAddSupersvisorsData{..}, Set.toList -> [cid]) = do avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers @@ -204,11 +211,12 @@ runFirmActionFormPost cid route isAdmin acts = do , formSubmit = FormSubmit , formAnchor = Just faAnchor } - firmActionHandler route faRes + firmActionHandler route isAdmin faRes return [whamlet|

              _{MsgFirmAction} + $

              _{MsgFirmActionInfo} @@ -249,6 +257,30 @@ addDefaultSupervisors cid employees = do ) (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications]) +-- like `addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual +addDefaultSupervisorsFor :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe UserId -> Bool -> mono -> DB Int64 +addDefaultSupervisorsFor mbSuperId mutualSupervision cids = do + E.insertSelectWithConflictCount UniqueUserSupervisor + (do + (spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany) + E.where_ $ E.and $ guardMonoid (not mutualSupervision) + [ E.not_ $ usr E.^. UserCompanySupervisor ] + <> maybeEmpty mbSuperId (\sprId -> [E.exists $ do + superv <- E.from $ E.table @UserSupervisor + E.where_ $ superv E.^. UserSupervisorSupervisor E.==. E.val sprId + E.&&. superv E.^. UserSupervisorUser E.==. usr E.^. UserCompanyUser + ]) + <> [ spr E.^. UserCompanySupervisor + , spr E.^. UserCompanyCompany `E.in_` E.vals cids + , usr E.^. UserCompanyCompany `E.in_` E.vals cids + ] + return $ UserSupervisor + E.<# (spr E.^. UserCompanyUser) + E.<&> (usr E.^. UserCompanyUser) + E.<&> (spr E.^. UserCompanySupervisorReroute) + ) + (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] ) + -- like `addDefaultSupervisors`, but selects all employees of given companies from database addDefaultSupervisorsAll :: (CompanyId ~ Element mono, MonoFoldable mono) => Bool -> mono -> DB Int64 addDefaultSupervisorsAll mutualSupervision cids = do @@ -621,7 +653,7 @@ postFirmAllR = do uid <- requireAuthId isAdmin <- checkAdmin (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins - firmActionHandler FirmAllR firmRes + firmActionHandler FirmAllR isAdmin firmRes siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms $(i18nWidgetFile "firm-all") From 92aca1b830f3bac78543e26956ec2707eb194187 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 28 Nov 2023 15:32:33 +0100 Subject: [PATCH 043/110] refactor(performance): disable modalAccess use for known admins modalAccess displays a link to modal only if the user has the rights to follow that link. However, for large dbTables this checking takes too long. So we use a conventional modal instead again. Worst-case: some non-admins are shown links that they cannot follow --- src/Handler/Admin/Avs.hs | 4 +- src/Handler/Course/Users.hs | 2 +- src/Handler/Exam/Users.hs | 2 +- src/Handler/Firm.hs | 7 ++-- src/Handler/LMS.hs | 4 +- src/Handler/Qualification.hs | 2 +- src/Handler/Tutorial/Users.hs | 4 +- src/Handler/Users.hs | 2 +- src/Handler/Utils/Table/Cells.hs | 62 ++++++++++++++++++++++++------ src/Handler/Utils/Table/Columns.hs | 8 +++- src/Handler/Utils/Widgets.hs | 7 ++-- src/Utils/Frontend/Modal.hs | 2 +- 12 files changed, 74 insertions(+), 32 deletions(-) diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 3773a9c85..f65f44f50 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -548,7 +548,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do [ dbSelect (applying _2) id $ return . view (resultUserAvs . _userAvsPersonId) -- (\DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID) -- does not type due to traversal , colUserNameLink AdminUserR - , sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCell a + , sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCellAdmin a -- , colUserCompany , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do @@ -752,7 +752,7 @@ getProblemAvsErrorR = do dbtRowKey = qerryUsrAvs >>> (E.^. UserAvsId) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat - [ colUserNameModalHdr MsgLmsUser AdminUserR + [ colUserNameModalHdrAdmin MsgLmsUser AdminUserR , sortable (Just "avs-nr") (i18nCell MsgAvsPersonNo) $ avsPersonNoLinkedCell . view reserrUsrAvs , sortable Nothing (i18nCell MsgAvsPersonId) diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index c2056d6c8..4a4e11e9d 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -660,7 +660,7 @@ postCUsersR tid ssh csh = do , pure . cap' $ colUserNameLink (CourseR tid ssh csh . CUserR) , guardOn showSex . cap' $ colUserSex' , pure . cap' $ colUserEmail - , pure . cap' $ colUserMatriclenr + , pure . cap' $ colUserMatriclenr False , pure . cap' $ colUserQualifications nowaday , guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup , guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 89d0bf40f..cd06ea982 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -484,7 +484,7 @@ postEUsersR tid ssh csh examn = do dbtColonnade = mconcat $ catMaybes [ pure $ dbSelect (_2 . applying _2) _1 $ return . view (resultExamRegistration . _entityKey) , pure $ colUserNameLink (CourseR tid ssh csh . CUserR) - , pure colUserMatriclenr + , pure $ colUserMatriclenr False , pure $ colStudyFeatures resultStudyFeatures , pure $ sortable (Just "occurrence") (i18nCell MsgTableExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 6030a9052..eb95a1e40 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -215,8 +215,7 @@ runFirmActionFormPost cid route isAdmin acts = do return [whamlet|

              - _{MsgFirmAction} - $ + _{MsgFirmAction}

              _{MsgFirmActionInfo} @@ -744,7 +743,7 @@ mkFirmUserTable isAdmin cid = do dbtColonnade = formColonnade $ mconcat [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey)) , colUserNameModalHdr MsgTableCompanyUser ForProfileDataR - , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinked entUsr + , guardMonoid isAdmin $ sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinkedAdmin entUsr , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultUserUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupers ) $ \(view resultUserCompanySupervisors -> nr) -> wgtCell $ word2widget nr , sortable (Just "reroutes") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultUserCompanyReroutes -> nr) -> wgtCell $ word2widget nr @@ -1022,7 +1021,7 @@ mkFirmSuperTable isAdmin cid = do dbtColonnade = formColonnade $ mconcat [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey)) , colUserNameModalHdr MsgTableSupervisor ForProfileDataR - , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultSuperUser -> entUsr) -> cellHasMatrikelnummerLinked entUsr + , guardMonoid isAdmin $ sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultSuperUser -> entUsr) -> cellHasMatrikelnummerLinkedAdmin entUsr , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultSuperCompanies -> cmps) -> intercalate semicolonCell [companyCell cmpShort cmpName isSuper | (E.Value cmpName, E.Value cmpShort, E.Value isSuper) <- cmps] , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultSuperUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 682e0c7f4..9d363f449 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -632,7 +632,7 @@ postLmsR sid qsh = do ] colChoices cmpMap = mconcat [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) - , colUserNameModalHdr MsgLmsUser AdminUserR + , colUserNameModalHdrAdmin MsgLmsUser AdminUserR , colUserEmail , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr @@ -640,7 +640,7 @@ postLmsR sid qsh = do , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap ] in intercalate spacerCell cs - , colUserMatriclenr + , colUserMatriclenr isAdmin -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 65710b884..5b2c315af 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -591,7 +591,7 @@ postQualificationR sid qsh = do , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap ] in intercalate spacerCell cs - , guardMonoid isAdmin colUserMatriclenr + , guardMonoid isAdmin $ colUserMatriclenr isAdmin -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 46d15e16b..973366f0a 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -71,8 +71,8 @@ postTUsersR tid ssh csh tutn = do colChoices = mconcat $ catMaybes [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR - , pure colUserEmail - , pure colUserMatriclenr + , pure colUserEmail + , pure $ colUserMatriclenr isAdmin , pure $ colUserQualifications nowaday , pure $ colUserQualificationBlocked isAdmin nowaday ] diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 1133c56d8..0cbbbde66 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -100,7 +100,7 @@ postUsersR = do , sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM (AdminUserR <$> encrypt uid) (nameWidget userDisplayName userSurname) - , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinked entUsr + , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinkedAdmin entUsr , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 2cab48fc2..6b776cd41 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -218,7 +218,7 @@ cellHasUserLink toLink user = nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname) in anchorCellM (toLink <$> encrypt uid) nWdgt --- | like `cellHasUserLink` but opens the user in a modal instead +-- | like `cellHasUserLink` but opens the user in a modal instead; link is only displayed if the user has sufficient rights cellHasUserModal :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c cellHasUserModal toLink user = let userEntity = user ^. hasEntityUser @@ -226,10 +226,21 @@ cellHasUserModal toLink user = nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname) lWdgt = do uuid <- liftHandler $ encrypt uid - modalAccess False nWdgt nWdgt $ toLink uuid + modalAccess nWdgt nWdgt False $ toLink uuid in cell lWdgt --- | like `cellHasUserModal` but with fixed route and showing an edit icon instead +-- | like `cellHasUserModal` but but always display link without prior access rights checks +cellHasUserModalAdmin :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c +cellHasUserModalAdmin toLink user = + let userEntity = user ^. hasEntityUser + uid = userEntity ^. _entityKey + nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname) + lWdgt = do + uuid <- liftHandler $ encrypt uid + modal nWdgt $ Left $ SomeRoute $ toLink uuid + in cell lWdgt + +-- | like `cellHasUserModal` but with fixed route and showing an edit icon instead; link is only displayed if the user has sufficient rights cellEditUserModal :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c cellEditUserModal user = let userEntity = user ^. hasEntityUser @@ -237,16 +248,39 @@ cellEditUserModal user = nWdgt = toWidget $ icon IconUserEdit lWdgt = do uuid <- liftHandler $ encrypt uid - modalAccess True nWdgt mempty $ ForProfileR uuid + modalAccess mempty nWdgt True $ ForProfileR uuid in cell lWdgt + +-- | like `cellEditUserModal` but always displays the link without prior access rights checks +cellEditUserModalAdmin :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c +cellEditUserModalAdmin user = + let userEntity = user ^. hasEntityUser + uid = userEntity ^. _entityKey + nWdgt = toWidget $ icon IconUserEdit + lWdgt = do + uuid <- liftHandler $ encrypt uid + modal nWdgt (Left $ SomeRoute $ ForProfileR uuid) + in cell lWdgt + cellHasMatrikelnummer :: (IsDBTable m a, HasUser u) => u -> DBCell m a cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer -cellHasMatrikelnummerLinked :: (IsDBTable m a, HasEntity u User) => u -> DBCell m a -cellHasMatrikelnummerLinked usr +cellHasMatrikelnummerLinked :: (IsDBTable m a, HasEntity u User) => Bool -> u -> DBCell m a +cellHasMatrikelnummerLinked isAdmin usr | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey - modalAccess False (text2widget matNr) mempty (AdminAvsUserR uuid) + if isAdmin + then modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid) + else modalAccess mempty (text2widget matNr) False (AdminAvsUserR uuid) + | otherwise = mempty + where + usrEntity = usr ^. hasEntityUser + +cellHasMatrikelnummerLinkedAdmin :: (IsDBTable m a, HasEntity u User) => u -> DBCell m a +cellHasMatrikelnummerLinkedAdmin usr + | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do + uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey + modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid) | otherwise = mempty where usrEntity = usr ^. hasEntityUser @@ -364,7 +398,7 @@ qualificationValidUntilCell' mbToLink d qb qu = cell $ case mbToLink of Nothing -> headWgt <> dateWgt Just toLink -> do uuid <- liftHandler $ encrypt $ qu ^. hasQualificationUser . _qualificationUserUser - let modalWgt = modalAccess False dateWgt dateWgt $ toLink uuid + let modalWgt = modalAccess dateWgt dateWgt False $ toLink uuid headWgt <> modalWgt where dateWgt = formatTimeW SelFormatDate (qu ^. hasQualificationUser . _qualificationUserValidUntil) @@ -386,7 +420,7 @@ qualificationValidReasonCell' mbToLink showReason d qb qu = ic <> foldMap blc qb | Just toLink <- mbToLink = cell $ do uuid <- liftHandler $ encrypt uid let dWgt = formatTimeW SelFormatDate tstamp - modalAccess False dWgt dWgt $ toLink uuid + modalAccess dWgt dWgt False $ toLink uuid -- anchorCellM (toLink <$> encrypt uid) | otherwise = dateCell tstamp uid = qu ^. hasQualificationUser . _qualificationUserUser @@ -405,7 +439,7 @@ qualificationValidReasonCell'' mbToLink showReason d qb qu extValid = ic <> icEr | Just toLink <- mbToLink = cell $ do uuid <- liftHandler $ encrypt uid let dWgt = formatTimeW SelFormatDate tstamp - modalAccess False dWgt dWgt $ toLink uuid + modalAccess dWgt dWgt False $ toLink uuid -- anchorCellM (toLink <$> encrypt uid) | otherwise = dateCell tstamp uid = qu ^. hasQualificationUser . _qualificationUserUser @@ -466,7 +500,13 @@ avsPersonNoLinkedCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c avsPersonNoLinkedCell a = cell $ do uuid <- liftHandler $ encrypt $ a ^. _userAvsUser let nWgt = toWgt $ toMessage $ a ^. _userAvsNoPerson - modalAccess False nWgt nWgt $ AdminAvsUserR uuid + modalAccess nWgt nWgt False $ AdminAvsUserR uuid + +avsPersonNoLinkedCellAdmin :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c +avsPersonNoLinkedCellAdmin a = cell $ do + uuid <- liftHandler $ encrypt $ a ^. _userAvsUser + let nWgt = toWgt $ toMessage $ a ^. _userAvsNoPerson + modal nWgt (Left $ SomeRoute $ AdminAvsUserR uuid) avsPersonCardCell :: (IsDBTable m c) => Set AvsDataPersonCard -> DBCell m c avsPersonCardCell cards = wgtCell diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 6184d1314..c0f768e99 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -336,6 +336,10 @@ colUserNameLinkHdr colHeader userLink = sortable (Just "user-name") (i18nCell co colUserNameModalHdr :: (IsDBTable m c, HasEntity a User, RenderMessage UniWorX msg) => msg -> (CryptoUUIDUser -> Route UniWorX) -> Colonnade Sortable a (DBCell m c) colUserNameModalHdr colHeader userLink = sortable (Just "user-name") (i18nCell colHeader) (cellHasUserModal userLink) +-- | like `colUserNameModalHdr` but without checking access rights before displaying the link (no risk, but non-admins may see links that are unusable for them) +colUserNameModalHdrAdmin :: (IsDBTable m c, HasEntity a User, RenderMessage UniWorX msg) => msg -> (CryptoUUIDUser -> Route UniWorX) -> Colonnade Sortable a (DBCell m c) +colUserNameModalHdrAdmin colHeader userLink = sortable (Just "user-name") (i18nCell colHeader) (cellHasUserModalAdmin userLink) + -- | Intended to work with @nameWidget@, showing highlighter Surname within Displayname sortUserName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t r') sortUserName = ("user-name",) . sortUserNameBare @@ -442,8 +446,8 @@ fltrUserMatriculationUI :: DBFilterUI fltrUserMatriculationUI mPrev = prismAForm (singletonFilter "user-matriculation") mPrev $ aopt textField (fslI MsgTableUserMatriculation) -colUserMatriclenr :: (IsDBTable m c, HasEntity a User) => Colonnade Sortable a (DBCell m c) -colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgTableMatrikelNr) cellHasMatrikelnummerLinked +colUserMatriclenr :: (IsDBTable m c, HasEntity a User) => Bool -> Colonnade Sortable a (DBCell m c) +colUserMatriclenr isAdmin = sortable (Just "user-matriclenumber") (i18nCell MsgTableMatrikelNr) $ cellHasMatrikelnummerLinked isAdmin sortUserMatriclenr :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t r') sortUserMatriclenr queryUser = ("user-matriclenumber", SortColumn $ queryUser >>> (E.^. UserMatrikelnummer)) diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index 61c3c298e..1e5f6bdc2 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -123,15 +123,14 @@ editedByW fmt tm usr = do [whamlet|_{MsgUtilEditedBy usr ft}|] --- | like `modal`, but checks access rights to the link -modalAccess :: Bool -> Widget -> Widget -> Route UniWorX -> Widget -modalAccess writeAccess wdgtYes wdgtNo route = do +-- | like `modal`, but only conditionally displays the modal link only after checking access rights. WARNING: this might be too slow for large dbTable. Use `modalAccessCheckOnClick` instead +modalAccess :: Widget -> Widget -> Bool -> Route UniWorX -> Widget +modalAccess wdgtNo wdgtYes writeAccess route = do authOk <- liftHandler $ bool hasReadAccessTo hasWriteAccessTo writeAccess route if authOk then modal wdgtYes (Left $ SomeRoute route) else wdgtNo - ---------- -- HEAT -- ---------- diff --git a/src/Utils/Frontend/Modal.hs b/src/Utils/Frontend/Modal.hs index 304326ccc..d8180f58d 100644 --- a/src/Utils/Frontend/Modal.hs +++ b/src/Utils/Frontend/Modal.hs @@ -40,7 +40,7 @@ customModal Modal{..} = do -- | Create a link to a modal, does not check link, see `Handler.Utils.Widget.modalAccess` for a checking variant modal :: WidgetFor site () -- ^ Widget that represents the link - -> Either (SomeRoute site) (WidgetFor site ()) -- ^ Modal contant: either dynamic link or static widget + -> Either (SomeRoute site) (WidgetFor site ()) -- ^ Modal content: either dynamic link or static widget -> WidgetFor site () -- ^ result widget modal modalTrigger' modalContent = customModal Modal{..} where From eb541b4e91ecf86f7cba1c3b080675543a1f1dbd Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 28 Nov 2023 18:54:16 +0100 Subject: [PATCH 044/110] chore(firm): add action to change individual supervisors --- .../uniworx/categories/firm/de-de-formal.msg | 4 ++ messages/uniworx/categories/firm/en-eu.msg | 4 ++ .../send/send_notifications/de-de-formal.msg | 2 +- .../send/send_notifications/en-eu.msg | 2 +- src/Handler/Firm.hs | 43 ++++++++++++++++--- 5 files changed, 48 insertions(+), 7 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 0d872dba0..2772c864a 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -24,6 +24,10 @@ FirmActChangeContactFirmInfo: Firmenkontaktinformationen werden nur für neue Fi FirmActChangeContactFirmResult: Firmenkontaktinformationen geändert. Betrifft nur neue Firmenangehörige ohne eigene Kontaktinformationen FirmUserActNotify: Mitteilung versenden FirmUserActResetSupervision: Ansprechpartner auf Firmenstandard zurücksetzen +FirmUserActSetSupervisor: Ansprechpartner ändern +FirmNewSupervisor: Neue individuelle Ansprechpartner hinzufügen +FirmSetSupervisor: Existierende Ansprechpartner hinzufügen +FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: Für #{nusr} Firmenangehörige wurden #{nspr} individuelle Ansprechpartner eingetragen#{bool "." (" und " <> tshow nrem <> " individuelle Ansprechpartnerbeziehungen gelöscht.") (nrem >0)} FirmUserActMkSuper: Zum Firmenansprechpartner ernennen FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{bool mempty (", " <> tshow rem <> " zuvor gelöscht") (rem > 0)} diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 0554ce6e9..a91186f6e 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -24,6 +24,10 @@ FirmActChangeContactFirmInfo: The company contact data is only used for new comp FirmActChangeContactFirmResult: Company contact data changed, affecting future company associates without contact information only FirmUserActNotify: Send message FirmUserActResetSupervision: Reset supervisors to company default +FirmUserActSetSupervisor: Change supervision +FirmNewSupervisor: Appoint new individual supervisors +FirmSetSupervisor: Add existing supervisors +FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: #{nspr} individal supervisors set for #{nusr} company associates#{bool "." (" and " <> tshow nrem <> " other individual supervisions terminated.") (nrem >0)} FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> tshow rem <> " deleted before") (rem > 0)} FirmUserActChangeContact: Change contact data for selected company associates FirmUserActMkSuper: Mark as company supervisor diff --git a/messages/uniworx/categories/send/send_notifications/de-de-formal.msg b/messages/uniworx/categories/send/send_notifications/de-de-formal.msg index b2a350b3e..cba2c8110 100644 --- a/messages/uniworx/categories/send/send_notifications/de-de-formal.msg +++ b/messages/uniworx/categories/send/send_notifications/de-de-formal.msg @@ -103,4 +103,4 @@ MailSupervisorNoCopy: Warnung: Diese Nachricht wurde nicht an den eigentlichen E MailSupervisedNote: Hinweis MailSupervisedBody: Eine Kopie dieser Nachricht wurde auch an folgende in FRADrive eingetragene Ansprechpartner gesendet: MailSupervisorReroute: Benachrichtigungsumleitung -MailSupervisorRerouteTooltip: Alle Benachrichtigungen werden stattdessen an alle Ansprechpartner mit Benachrichtigungsumleitung gesandt \ No newline at end of file +MailSupervisorRerouteTooltip: Alle Benachrichtigungen werden stattdessen an diese Ansprechpartner mit Benachrichtigungsumleitung gesandt \ No newline at end of file diff --git a/messages/uniworx/categories/send/send_notifications/en-eu.msg b/messages/uniworx/categories/send/send_notifications/en-eu.msg index b06a1c2eb..04fe30088 100644 --- a/messages/uniworx/categories/send/send_notifications/en-eu.msg +++ b/messages/uniworx/categories/send/send_notifications/en-eu.msg @@ -103,4 +103,4 @@ MailSupervisorNoCopy: Warning: This message was not sent to the original recipie MailSupervisedNote: Please note MailSupervisedBody: A copy of this message has been sent to all supervisors registered for you in FRADrive, namely: MailSupervisorReroute: Reroute notifications -MailSupervisorRerouteTooltip: All notification will be sent to all supervisors with notification rerouting instead \ No newline at end of file +MailSupervisorRerouteTooltip: All notification will be rerouted to these supervisors instead \ No newline at end of file diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index eb95a1e40..547c4e07c 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -664,6 +664,7 @@ postFirmAllR = do data FirmUserAction = FirmUserActNotify | FirmUserActResetSupervision + | FirmUserActSetSupervisor | FirmUserActMkSuper | FirmUserActChangeContact deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) @@ -672,11 +673,17 @@ data FirmUserAction = FirmUserActNotify nullaryPathPiece ''FirmUserAction $ camelToPathPiece' 3 embedRenderMessage ''UniWorX ''FirmUserAction id -data FirmUserActionData = FirmUserActNotifyData +data FirmUserActionData = FirmUserActNotifyData | FirmUserActResetSupervisionData { firmUserActResetKeepOldSupers :: Maybe Bool -- , firmUserActResetMutualSupervision :: Maybe Bool } + | FirmUserActSetSupervisorData + { firmUserActSetSuperNames :: Set Text + , firmUserActSetSuperIds :: [UserId] + , firmUserActSetSuperReroute :: Bool + , firmUserActSetSuperKeep :: Bool + } | FirmUserActMkSuperData { firmUserActMkSuperReroute :: Maybe Bool } | FirmUserActChangeContactData @@ -831,6 +838,11 @@ mkFirmUserTable isAdmin cid = do , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) + , singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData + <$> apopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <*> apopt supervisorsField (fslI MsgFirmSetSupervisor) Nothing + <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False) + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False) , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData @@ -904,10 +916,6 @@ postFirmUsersR fsh = do formResult fusrRes $ \case (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice - (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do - nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)] - addMessageI Info $ MsgFirmActAddSupersSet nrMkSuper Nothing - reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes (FirmUserActNotifyData , uids) -> do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) @@ -919,6 +927,31 @@ postFirmUsersR fsh = do newSupers <- addDefaultSupervisors cid uids addMessageI Info $ MsgFirmResetSupervision delSupers newSupers reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + (FirmUserActSetSupervisorData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do + avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmUserActSetSuperNames + let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers + usersFound = mapMaybe snd usersFound' + newSupers = Set.toList $ Set.fromList firmUserActSetSuperIds <> Set.fromList usersFound + nrSupers = fromIntegral $ length newSupers + nrUsers = fromIntegral $ length uids + unless (null usersNotFound) $ + let msgContent = [whamlet| + $newline never +

                + $forall (usr,_) <- usersNotFound +
              • #{usr} + |] + in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) + delSupers <- runDB + $ bool (deleteSupervisors uids) (return 0) firmUserActSetSuperKeep + <* putMany [UserSupervisor s u firmUserActSetSuperReroute | u <- toList uids, s <- newSupers] + addMessageI Success $ MsgFirmSetSupersReport nrUsers nrSupers delSupers + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + + (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do + nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)] + addMessageI Info $ MsgFirmActAddSupersSet nrMkSuper Nothing + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes (FirmUserActChangeContactData{..}, Set.toList -> uids) -> let changes = catMaybes [ (UserPostAddress =.) . Just <$> canonical firmUserActPostalAddr -- note that Nothing means no change and not delete address! From 57d9447b4f94b68e356461f6e25f6289ff03e430 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 29 Nov 2023 13:18:30 +0100 Subject: [PATCH 045/110] chore(firm): update table action access rights --- src/Handler/Firm.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 547c4e07c..79236d154 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -530,7 +530,7 @@ mkFirmAllTable isAdmin uid = do dbtRowKey = (E.^. CompanyId) dbtProj = dbtProjId dbtColonnade = formColonnade $ mconcat - [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey)) + [ dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey)) , sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> anchorCell (FirmUsersR $ companyShorthand firm) . toWgt $ companyName firm , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> @@ -748,7 +748,7 @@ mkFirmUserTable isAdmin cid = do dbtRowKey = queryUserUser >>> (E.^. UserId) dbtProj = dbtProjId dbtColonnade = formColonnade $ mconcat - [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey)) + [ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey)) , colUserNameModalHdr MsgTableCompanyUser ForProfileDataR , guardMonoid isAdmin $ sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinkedAdmin entUsr , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultUserUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t @@ -834,7 +834,7 @@ mkFirmUserTable isAdmin cid = do dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } acts :: Map FirmUserAction (AForm Handler FirmUserActionData) acts = mconcat - [ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData + [ guardMonoid isAdmin $ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) @@ -883,7 +883,7 @@ mkFirmUserTable isAdmin cid = do getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html getFirmUsersR = postFirmUsersR postFirmUsersR fsh = do - isAdmin <- checkAdmin + isAdmin <- checkAdmin let cid = CompanyKey fsh (( Entity{entityVal=Company{..}} , E.Value nrCompanyUsers @@ -1052,7 +1052,7 @@ mkFirmSuperTable isAdmin cid = do return (cmp E.^. CompanyName, cmp E.^. CompanyShorthand, usrCmp E.^. UserCompanySupervisor) return (usr, supervised, rerouted, cmps, supervisor, reroute) dbtColonnade = formColonnade $ mconcat - [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey)) + [ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey)) , colUserNameModalHdr MsgTableSupervisor ForProfileDataR , guardMonoid isAdmin $ sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultSuperUser -> entUsr) -> cellHasMatrikelnummerLinkedAdmin entUsr , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultSuperCompanies -> cmps) -> @@ -1092,7 +1092,7 @@ mkFirmSuperTable isAdmin cid = do dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData) acts = mconcat - [ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData + [ guardMonoid isAdmin $ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData , singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData <$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True) ] From 929eb1b1755c1df294fb789928fb15665bce3628 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 29 Nov 2023 13:22:34 +0100 Subject: [PATCH 046/110] chore(firm): hide supervision key data by default --- messages/uniworx/categories/firm/de-de-formal.msg | 3 ++- messages/uniworx/categories/firm/en-eu.msg | 3 ++- templates/firm-users.hamlet | 4 +++- 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 2772c864a..2f5a807ef 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -51,4 +51,5 @@ TableIsDefaultSupervisor: Standardansprechpartner TableIsDefaultReroute: Standardumleitung FormFieldPostal: Benachrichtigungseinstellung FormFieldPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner -FirmUserChanges n@Int64: Benachrichtigungseinstellung für #{n} Firmenangehörige wurden geändert \ No newline at end of file +FirmUserChanges n@Int64: Benachrichtigungseinstellung für #{n} Firmenangehörige wurden geändert +FirmSupervisionKeyData: Kennzahlen Ansprechpartner \ No newline at end of file diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index a91186f6e..b14df5fba 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -51,4 +51,5 @@ TableIsDefaultSupervisor: Default supervisor TableIsDefaultReroute: Default reroute FormFieldPostal: Notification type FormFieldPostalTip: Affects all notifications to this person, not just reroutes to this supervisor -FirmUserChanges n: Notification settings changed for #{n} company associates \ No newline at end of file +FirmUserChanges n: Notification settings changed for #{n} company associates +FirmSupervisionKeyData: Supervision key data \ No newline at end of file diff --git a/templates/firm-users.hamlet b/templates/firm-users.hamlet index c10c06e13..05e90f8ed 100644 --- a/templates/firm-users.hamlet +++ b/templates/firm-users.hamlet @@ -8,7 +8,9 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{formFirmAction} -
                +
                +

                + _{MsgFirmSupervisionKeyData}

              From ef9a5dc5a9bd729e4a8c5a8af2193fead366726e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 29 Nov 2023 16:22:09 +0100 Subject: [PATCH 047/110] chore(firm): disallow supervisors on firm routes for now --- routes | 6 +++--- src/Handler/Firm.hs | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/routes b/routes index df8c32fa2..b024c577f 100644 --- a/routes +++ b/routes @@ -113,12 +113,12 @@ /for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self -/firms FirmAllR GET POST !supervisor +/firms FirmAllR GET POST -- not yet !supervisor /firms/comm/+Companies FirmsCommR GET POST /firm/#CompanyShorthand/debug FirmR GET POST /firm/#CompanyShorthand/comm FirmCommR GET POST -/firm/#CompanyShorthand FirmUsersR GET POST !supervisor -/firm/#CompanyShorthand/supers FirmSupersR GET POST !supervisor +/firm/#CompanyShorthand FirmUsersR GET POST -- not yet !supervisor +/firm/#CompanyShorthand/supers FirmSupersR GET POST -- not yet !supervisor /exam-office ExamOfficeR !exam-office: / EOExamsR GET POST !system-exam-office diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 79236d154..6e88accfa 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -735,7 +735,7 @@ mkFirmUserTable isAdmin cid = do return (usr E.^. UserId, usr E.^. UserDisplayName) let -- supervisorField :: Field Handler UserId - supervisorField = selectField $ procOptions rawSupers + -- supervisorField = selectField $ procOptions rawSupers supervisorsField = multiSelectField $ procOptions rawSupers fsh = unCompanyKey cid @@ -825,7 +825,7 @@ mkFirmUserTable isAdmin cid = do -- superField = selectField $ ???? dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev - , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) + -- , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor) , prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor) , prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh) From 75e4975c52e0ab1beff0251d9b654cdaab1d1af8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 30 Nov 2023 18:32:25 +0100 Subject: [PATCH 048/110] refactor(mail): course and firm message are sent only once to each supervisor --- .../uniworx/categories/firm/de-de-formal.msg | 2 +- messages/uniworx/categories/firm/en-eu.msg | 2 +- src/Handler/Firm.hs | 2 +- src/Handler/Utils/Communication.hs | 40 +++--- src/Handler/Utils/Mail.hs | 8 +- src/Handler/Utils/Users.hs | 118 ++++++++++-------- src/Jobs/Handler/SendCourseCommunication.hs | 4 +- src/Mail.hs | 13 +- src/Utils/Set.hs | 13 +- 9 files changed, 121 insertions(+), 81 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 2f5a807ef..e53e55b50 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -34,7 +34,7 @@ FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{ FirmSuperActNotify: Mitteilung versenden FirmSuperActRMSuperDef: Standard Firmenansprechpartner entfernen FirmSuperActRMSuperActive: Auch aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden -FirmsNotification: Firmen Benachrichtigung versenden +FirmsNotification: Firmen E-Mail versenden FirmNotification fsh@CompanyShorthand: Benachrichtigung an #{fsh} versenden FirmsNotificationTitle: Firmen benachrichtigen FirmNotificationTitle fsh@CompanyShorthand: #{fsh} benachrichtigen diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index b14df5fba..be6d003ad 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -34,7 +34,7 @@ FirmUserActMkSuper: Mark as company supervisor FirmSuperActNotify: Send message FirmSuperActRMSuperDef: Remove as default supervisor FirmSuperActRMSuperActive: Also remove active supervisions within this company -FirmsNotification: Send company notification +FirmsNotification: Send company notification e-mail FirmNotification fsh: Send notification to company #{fsh} FirmsNotificationTitle: Company notification FirmNotificationTitle fsh@CompanyShorthand: #{fsh} notification diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 6e88accfa..fcf60c8a6 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -535,7 +535,7 @@ mkFirmAllTable isAdmin uid = do anchorCell (FirmUsersR $ companyShorthand firm) . toWgt $ companyName firm , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> let fsh = companyShorthand firm - in anchorCell (FirmUsersR fsh) $ toWgt fsh + in anchorCell (FirmSupersR fsh) $ toWgt fsh , sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm , sortable (Just "users") (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 70c8e45e2..3783ba0aa 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -15,6 +15,7 @@ module Handler.Utils.Communication import Import import Handler.Utils +import Handler.Utils.Users import Jobs.Queue @@ -95,35 +96,40 @@ makeLenses_ ''Communication crJobsCourseCommunication, crTestJobsCourseCommunication :: CourseId -> Communication -> ConduitT () Job (YesodDB UniWorX) () crJobsCourseCommunication jCourse Communication{..} = do jSender <- requireAuthId - let jMailContent = cContent - allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients jMailObjectUUID <- liftIO getRandom - jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case - Left email -> return . Address Nothing $ CI.original email - Right rid -> userAddress <$> getJust rid - forM_ allRecipients $ \jRecipientEmail -> - yield JobSendCourseCommunication{..} + let jMailContent = cContent + (rawReceiverMails, rawReceiverIds) = setPartitionEithers cRecipients + adrReceiverMails = Set.map (Address Nothing . CI.original) rawReceiverMails + netReceiverAddresses <- lift $ do + netReceiverIds <- getReceiversFor $ jSender : Set.toList rawReceiverIds -- ensure supervisors get only one email + (userAddress . entityVal) <<$>> selectList [UserId <-. netReceiverIds] [] + -- let jAllRecipientAddresses = Set.fromList netReceiverAddresses <> adrReceiverMails + let jAllRecipientAddresses = Set.map getAddress (Set.fromList (AddressEqIgnoreName <$> netReceiverAddresses) <> Set.map AddressEqIgnoreName adrReceiverMails) + forM_ jAllRecipientAddresses $ \raddr -> + yield JobSendCourseCommunication{jRecipientEmail = Left $ CI.mk $ addressEmail raddr, ..} -- using Left UserMail ensures that no further reroutes are used, thus supervised supervisors also receive an email + crTestJobsCourseCommunication jCourse comm = do jSender <- requireAuthId - MsgRenderer mr <- getMsgRenderer let comm' = comm & _cContent . _ccSubject %~ Just . mr . MsgCommCourseTestSubject . fromMaybe (mr MsgUtilCommCourseSubject) crJobsCourseCommunication jCourse comm' .| C.filter ((== Right jSender) . jRecipientEmail) -crJobsFirmCommunication :: Companies -> Communication -> ConduitT () Job (YesodDB UniWorX) () +crJobsFirmCommunication, crTestFirmCommunication :: Companies -> Communication -> ConduitT () Job (YesodDB UniWorX) () crJobsFirmCommunication jCompanies Communication{..} = do jSender <- requireAuthId - let jMailContent = cContent - allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients jMailObjectUUID <- liftIO getRandom - jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case - Left email -> return . Address Nothing $ CI.original email - Right rid -> userAddress <$> getJust rid - forM_ allRecipients $ \jRecipientEmail -> - yield JobSendFirmCommunication{..} + let jMailContent = cContent + (rawReceiverMails, rawReceiverIds) = setPartitionEithers cRecipients + adrReceiverMails = Set.map (Address Nothing . CI.original) rawReceiverMails + netReceiverAddresses <- lift $ do + netReceiverIds <- getReceiversFor $ jSender : Set.toList rawReceiverIds -- ensure supervisors get only one email + (userAddress . entityVal) <<$>> selectList [UserId <-. netReceiverIds] [] + -- let jAllRecipientAddresses = Set.fromList netReceiverAddresses <> adrReceiverMails + let jAllRecipientAddresses = Set.map getAddress (Set.fromList (AddressEqIgnoreName <$> netReceiverAddresses) <> Set.map AddressEqIgnoreName adrReceiverMails) + forM_ jAllRecipientAddresses $ \raddr -> + yield JobSendFirmCommunication{jRecipientEmail = Left $ CI.mk $ addressEmail raddr, ..} -- using Left UserMail ensures that no further reroutes are used, thus supervised supervisors also receive an email -crTestFirmCommunication :: Companies -> Communication -> ConduitT () Job (YesodDB UniWorX) () crTestFirmCommunication jCompanies comm = do jSender <- requireAuthId MsgRenderer mr <- getMsgRenderer diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index 6a5e7be61..851928033 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -4,7 +4,8 @@ module Handler.Utils.Mail ( addRecipientsDB - , userAddress, userAddressFrom + , userAddress, userAddress' + , userAddressFrom , userMailT, userMailTdirect , addFileDB , addHtmlMarkdownAlternatives @@ -52,6 +53,11 @@ userAddress :: User -> Address userAddress User{userEmail, userDisplayEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail +userAddress' :: UserEmail -> UserEmail -> UserDisplayName -> Address +-- Like userAddress', but does not require a complete entity +userAddress' userEmail userDisplayEmail userDisplayName + = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail + userAddressError :: (MonadHandler m, HandlerSite m ~ UniWorX) => User -> m (Bool, Address) userAddressError User{userEmail, userDisplayEmail, userDisplayName} | Just okEmail <- pickValidEmail' userDisplayEmail userEmail = pure (True, Address (Just userDisplayName) $ CI.original okEmail) diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index fb19f07a7..1e4a28487 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -1,7 +1,9 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# LANGUAGE TypeApplications #-} + -- NOTE: Also see Handler.Utils.Profile for similar utilities module Handler.Utils.Users ( computeUserAuthenticationDigest @@ -17,7 +19,7 @@ module Handler.Utils.Users , getEmailAddress , getPostalAddress, getPostalPreferenceAndAddress , abbrvName - , getReceivers + , getReceivers, getReceiversFor , getSupervisees ) where @@ -38,7 +40,9 @@ import qualified Data.Set as Set -- import qualified Data.List as List import qualified Data.CaseInsensitive as CI -import qualified Database.Esqueleto.Legacy as E +import Database.Esqueleto.Experimental ((:&)(..)) +import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma +import qualified Database.Esqueleto.Legacy as EL (on,from) import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E @@ -111,6 +115,14 @@ getReceivers uid = do then directResult else return (underling, receivers, uid `elem` (entityKey <$> receivers)) +-- | For user with mailTdirect, since this query will also return supervisors that have reroute supervisors themselves, who would then receive multiple duplicates +getReceiversFor :: (MonoFoldable mono, UserId ~ Element mono) => mono -> DB [UserId] +getReceiversFor uids = (E.unValue <<$>>) $ E.select $ E.distinct $ do + usr :& spr <- E.from $ E.table @User `E.leftJoin` E.table @UserSupervisor + `E.on` (\(usr :& spr) -> usr E.^. UserId E.=?. spr E.?. UserSupervisorUser E.&&. E.isTrue (spr E.?. UserSupervisorRerouteNotifications)) + E.where_ $ usr E.^. UserId `E.in_` E.vals uids + return $ E.coalesceDefault [spr E.?. UserSupervisorSupervisor] $ usr E.^. UserId + -- | return underlings for currently logged in user getSupervisees :: DB (Set UserId) getSupervisees = do @@ -185,7 +197,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) GuessUserFirstName userFirstName' -> user E.^. UserFirstName `containsAsSet` userFirstName' go didLdap = do - let retrieveUsers = E.select . E.from $ \user -> do + let retrieveUsers = E.select . EL.from $ \user -> do E.where_ . E.or $ map (E.and . map (toSql user)) criteria when (is _Just mQueryLimit) $ (E.limit . fromJust) mQueryLimit return user @@ -307,7 +319,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueCourseFavourite - (E.from $ \courseFavourite -> do + (EL.from $ \courseFavourite -> do E.where_ $ courseFavourite E.^. CourseFavouriteUser E.==. E.val oldUserId return $ CourseFavourite E.<# E.val newUserId @@ -320,7 +332,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueCourseNoFavourite - (E.from $ \courseNoFavourite -> do + (EL.from $ \courseNoFavourite -> do E.where_ $ courseNoFavourite E.^. CourseNoFavouriteUser E.==. E.val oldUserId return $ CourseNoFavourite E.<# E.val newUserId @@ -331,7 +343,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueExamOfficeField - (E.from $ \examOfficeField -> do + (EL.from $ \examOfficeField -> do E.where_ $ examOfficeField E.^. ExamOfficeFieldOffice E.==. E.val oldUserId return $ ExamOfficeField E.<# E.val newUserId @@ -343,7 +355,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueExamOfficeUser - (E.from $ \examOfficeUser -> do + (EL.from $ \examOfficeUser -> do E.where_ $ examOfficeUser E.^. ExamOfficeUserOffice E.==. E.val oldUserId return $ ExamOfficeUser E.<# E.val newUserId @@ -353,7 +365,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do deleteWhere [ ExamOfficeUserOffice ==. oldUserId ] E.insertSelectWithConflict UniqueExamOfficeUser - (E.from $ \examOfficeUser -> do + (EL.from $ \examOfficeUser -> do E.where_ $ examOfficeUser E.^. ExamOfficeUserUser E.==. E.val oldUserId return $ ExamOfficeUser E.<# (examOfficeUser E.^. ExamOfficeUserOffice) @@ -362,7 +374,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do (\_current _excluded -> []) deleteWhere [ ExamOfficeUserUser ==. oldUserId ] - E.insertSelect . E.from $ \examOfficeResultSynced -> do + E.insertSelect . EL.from $ \examOfficeResultSynced -> do E.where_ $ examOfficeResultSynced E.^. ExamOfficeResultSyncedOffice E.==. E.val oldUserId return $ ExamOfficeResultSynced E.<# (examOfficeResultSynced E.^. ExamOfficeResultSyncedSchool) @@ -371,7 +383,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.<&> (examOfficeResultSynced E.^. ExamOfficeResultSyncedTime) deleteWhere [ ExamOfficeResultSyncedOffice ==. oldUserId ] - E.insertSelect . E.from $ \examOfficeExternalResultSynced -> do + E.insertSelect . EL.from $ \examOfficeExternalResultSynced -> do E.where_ $ examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedOffice E.==. E.val oldUserId return $ ExamOfficeExternalResultSynced E.<# (examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedSchool) @@ -400,7 +412,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueExternalExamStaff - (E.from $ \externalExamStaff -> do + (EL.from $ \externalExamStaff -> do E.where_ $ externalExamStaff E.^. ExternalExamStaffUser E.==. E.val oldUserId return $ ExternalExamStaff E.<# E.val newUserId @@ -415,7 +427,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueSubmissionUser - (E.from $ \submissionUser -> do + (EL.from $ \submissionUser -> do E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val oldUserId return $ SubmissionUser E.<# E.val newUserId @@ -425,19 +437,19 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do deleteWhere [ SubmissionUserUser ==. oldUserId ] do - collisions <- E.select . E.from $ \((submissionGroupUserA `E.InnerJoin` submissionGroupA) `E.InnerJoin` (submissionGroupUserB `E.InnerJoin` submissionGroupB)) -> do - E.on $ submissionGroupB E.^. SubmissionGroupId E.==. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup - E.on $ submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup E.!=. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup + collisions <- E.select . EL.from $ \((submissionGroupUserA `E.InnerJoin` submissionGroupA) `E.InnerJoin` (submissionGroupUserB `E.InnerJoin` submissionGroupB)) -> do + EL.on $ submissionGroupB E.^. SubmissionGroupId E.==. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup + EL.on $ submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup E.!=. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup E.&&. submissionGroupUserA E.^. SubmissionGroupUserUser E.==. E.val oldUserId E.&&. submissionGroupUserB E.^. SubmissionGroupUserUser E.==. E.val newUserId - E.on $ submissionGroupA E.^. SubmissionGroupId E.==. submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup + EL.on $ submissionGroupA E.^. SubmissionGroupId E.==. submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup E.where_ $ submissionGroupA E.^. SubmissionGroupCourse E.==. submissionGroupB E.^. SubmissionGroupCourse return (submissionGroupUserA, submissionGroupUserB) forM_ collisions $ \(submissionGroupUserA, submissionGroupUserB) -> tellWarning $ UserAssimilateSubmissionGroupUserMultiple submissionGroupUserA submissionGroupUserB E.insertSelectWithConflict UniqueSubmissionGroupUser - (E.from $ \submissionGroupUser -> do + (EL.from $ \submissionGroupUser -> do E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val oldUserId return $ SubmissionGroupUser E.<# (submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup) @@ -454,7 +466,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueLecturer - (E.from $ \lecturer -> do + (EL.from $ \lecturer -> do E.where_ $ lecturer E.^. LecturerUser E.==. E.val oldUserId return $ Lecturer E.<# E.val newUserId @@ -466,7 +478,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueParticipant - (E.from $ \courseParticipant -> do + (EL.from $ \courseParticipant -> do E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val oldUserId return $ CourseParticipant E.<# (courseParticipant E.^. CourseParticipantCourse) @@ -496,7 +508,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueCourseUserExamOfficeOptOut - (E.from $ \examOfficeOptOut -> do + (EL.from $ \examOfficeOptOut -> do E.where_ $ examOfficeOptOut E.^. CourseUserExamOfficeOptOutUser E.==. E.val oldUserId return $ CourseUserExamOfficeOptOut E.<# (examOfficeOptOut E.^. CourseUserExamOfficeOptOutCourse) @@ -508,7 +520,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueUserFunction - (E.from $ \userFunction -> do + (EL.from $ \userFunction -> do E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val oldUserId return $ UserFunction E.<# E.val newUserId @@ -520,7 +532,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueUserSystemFunction - (E.from $ \userSystemFunction -> do + (EL.from $ \userSystemFunction -> do E.where_ $ userSystemFunction E.^. UserSystemFunctionUser E.==. E.val oldUserId return $ UserSystemFunction E.<# E.val newUserId @@ -533,7 +545,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueUserExamOffice - (E.from $ \userExamOffice -> do + (EL.from $ \userExamOffice -> do E.where_ $ userExamOffice E.^. UserExamOfficeUser E.==. E.val oldUserId return $ UserExamOffice E.<# E.val newUserId @@ -544,7 +556,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueUserSchool - (E.from $ \userSchool -> do + (EL.from $ \userSchool -> do E.where_ $ userSchool E.^. UserSchoolUser E.==. E.val oldUserId return $ UserSchool E.<# E.val newUserId @@ -557,7 +569,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do updateWhere [ UserGroupMemberUser ==. oldUserId, UserGroupMemberPrimary ==. Active ] [ UserGroupMemberUser =. newUserId ] E.insertSelectWithConflict UniqueUserGroupMember - (E.from $ \userGroupMember -> do + (EL.from $ \userGroupMember -> do E.where_ $ userGroupMember E.^. UserGroupMemberUser E.==. E.val oldUserId return $ UserGroupMember E.<# (userGroupMember E.^. UserGroupMemberGroup) @@ -568,8 +580,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do deleteWhere [ UserGroupMemberUser ==. oldUserId ] do - collisions <- E.select . E.from $ \(examRegistrationA `E.InnerJoin` examRegistrationB) -> do - E.on $ examRegistrationA E.^. ExamRegistrationExam E.==. examRegistrationB E.^. ExamRegistrationExam + collisions <- E.select . EL.from $ \(examRegistrationA `E.InnerJoin` examRegistrationB) -> do + EL.on $ examRegistrationA E.^. ExamRegistrationExam E.==. examRegistrationB E.^. ExamRegistrationExam E.&&. examRegistrationA E.^. ExamRegistrationUser E.==. E.val oldUserId E.&&. examRegistrationB E.^. ExamRegistrationUser E.==. E.val newUserId E.where_ $ examRegistrationA E.^. ExamRegistrationOccurrence E.!=. examRegistrationB E.^. ExamRegistrationOccurrence @@ -580,7 +592,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -> tellWarning $ UserAssimilateExamRegistrationDifferentOccurrence oldExamRegistration newExamRegistration E.insertSelectWithConflict UniqueExamRegistration - (E.from $ \examRegistration -> do + (EL.from $ \examRegistration -> do E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val oldUserId return $ ExamRegistration E.<# (examRegistration E.^. ExamRegistrationExam) @@ -592,8 +604,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do deleteWhere [ ExamRegistrationUser ==. oldUserId ] do - collision <- E.selectMaybe . E.from $ \(examPartResultA `E.InnerJoin` examPartResultB) -> do - E.on $ examPartResultA E.^. ExamPartResultExamPart E.==. examPartResultB E.^. ExamPartResultExamPart + collision <- E.selectMaybe . EL.from $ \(examPartResultA `E.InnerJoin` examPartResultB) -> do + EL.on $ examPartResultA E.^. ExamPartResultExamPart E.==. examPartResultB E.^. ExamPartResultExamPart E.&&. examPartResultA E.^. ExamPartResultUser E.==. E.val oldUserId E.&&. examPartResultB E.^. ExamPartResultUser E.==. E.val newUserId E.where_ $ examPartResultA E.^. ExamPartResultResult E.!=. examPartResultB E.^. ExamPartResultResult @@ -602,7 +614,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -> tellError $ UserAssimilateExamPartResultDifferentResult oldExamPartResult newExamPartResult E.insertSelectWithConflict UniqueExamPartResult - (E.from $ \examPartResult -> do + (EL.from $ \examPartResult -> do E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val oldUserId return $ ExamPartResult E.<# (examPartResult E.^. ExamPartResultExamPart) @@ -614,8 +626,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do deleteWhere [ ExamPartResultUser ==. oldUserId ] do - collision <- E.selectMaybe . E.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do - E.on $ examBonusA E.^. ExamBonusExam E.==. examBonusB E.^. ExamBonusExam + collision <- E.selectMaybe . EL.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do + EL.on $ examBonusA E.^. ExamBonusExam E.==. examBonusB E.^. ExamBonusExam E.&&. examBonusA E.^. ExamBonusUser E.==. E.val oldUserId E.&&. examBonusB E.^. ExamBonusUser E.==. E.val newUserId E.where_ $ examBonusA E.^. ExamBonusBonus E.!=. examBonusB E.^. ExamBonusBonus @@ -624,7 +636,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -> tellError $ UserAssimilateExamBonusDifferentBonus oldExamBonus newExamBonus E.insertSelectWithConflict UniqueExamBonus - (E.from $ \examBonus -> do + (EL.from $ \examBonus -> do E.where_ $ examBonus E.^. ExamBonusUser E.==. E.val oldUserId return $ ExamBonus E.<# (examBonus E.^. ExamBonusExam) @@ -657,8 +669,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do Entity newECId _ <- upsert examCorrector{ examCorrectorUser = newUserId } [] E.insertSelectWithConflict UniqueExamPartCorrector - (E.from $ \(examPartCorrector `E.InnerJoin` examCorrector') -> do - E.on $ examCorrector' E.^. ExamCorrectorId E.==. examPartCorrector E.^. ExamPartCorrectorCorrector + (EL.from $ \(examPartCorrector `E.InnerJoin` examCorrector') -> do + EL.on $ examCorrector' E.^. ExamCorrectorId E.==. examPartCorrector E.^. ExamPartCorrectorCorrector E.where_ $ examCorrector' E.^. ExamCorrectorUser E.==. E.val oldUserId E.&&. examCorrector' E.^. ExamCorrectorExam E.==. E.val (examCorrectorExam examCorrector) return $ ExamPartCorrector @@ -704,8 +716,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do in runConduit $ getSheetCorrectors .| C.mapM_ upsertSheetCorrector do - collision <- E.selectMaybe . E.from $ \(personalisedSheetFileA `E.InnerJoin` personalisedSheetFileB) -> do - E.on $ personalisedSheetFileA E.^. PersonalisedSheetFileSheet E.==. personalisedSheetFileB E.^. PersonalisedSheetFileSheet + collision <- E.selectMaybe . EL.from $ \(personalisedSheetFileA `E.InnerJoin` personalisedSheetFileB) -> do + EL.on $ personalisedSheetFileA E.^. PersonalisedSheetFileSheet E.==. personalisedSheetFileB E.^. PersonalisedSheetFileSheet E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileType E.==. personalisedSheetFileB E.^. PersonalisedSheetFileType E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileTitle E.==. personalisedSheetFileB E.^. PersonalisedSheetFileTitle E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileUser E.==. E.val oldUserId @@ -716,7 +728,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -> tellError $ UserAssimilatePersonalisedSheetFileDifferentContent oldPersonalisedSheetFile newPersonalisedSheetFile E.insertSelectWithConflict UniquePersonalisedSheetFile - (E.from $ \personalisedSheetFile -> do + (EL.from $ \personalisedSheetFile -> do E.where_ $ personalisedSheetFile E.^. PersonalisedSheetFileUser E.==. E.val oldUserId return $ PersonalisedSheetFile E.<# (personalisedSheetFile E.^. PersonalisedSheetFileSheet) @@ -731,7 +743,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueTutor - (E.from $ \tutor -> do + (EL.from $ \tutor -> do E.where_ $ tutor E.^. TutorUser E.==. E.val oldUserId return $ Tutor E.<# (tutor E.^. TutorTutorial) @@ -740,12 +752,12 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do (\_current _excluded -> []) do - collision <- E.selectMaybe . E.from $ \((tutorialA `E.InnerJoin` tutorialParticipantA) `E.InnerJoin` (tutorialB `E.InnerJoin` tutorialParticipantB)) -> do - E.on $ tutorialParticipantB E.^. TutorialParticipantTutorial E.==. tutorialB E.^. TutorialId - E.on $ tutorialA E.^. TutorialCourse E.==. tutorialB E.^. TutorialCourse + collision <- E.selectMaybe . EL.from $ \((tutorialA `E.InnerJoin` tutorialParticipantA) `E.InnerJoin` (tutorialB `E.InnerJoin` tutorialParticipantB)) -> do + EL.on $ tutorialParticipantB E.^. TutorialParticipantTutorial E.==. tutorialB E.^. TutorialId + EL.on $ tutorialA E.^. TutorialCourse E.==. tutorialB E.^. TutorialCourse E.&&. tutorialParticipantB E.^. TutorialParticipantUser E.==. E.val newUserId E.&&. tutorialParticipantA E.^. TutorialParticipantUser E.==. E.val oldUserId - E.on $ tutorialParticipantA E.^. TutorialParticipantTutorial E.==. tutorialA E.^. TutorialId + EL.on $ tutorialParticipantA E.^. TutorialParticipantTutorial E.==. tutorialA E.^. TutorialId E.where_ $ tutorialA E.^. TutorialId E.!=. tutorialB E.^. TutorialId E.&&. tutorialA E.^. TutorialRegGroup E.==. tutorialB E.^. TutorialRegGroup return (tutorialParticipantA, tutorialParticipantB) @@ -753,7 +765,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -> tellError $ UserAssimilateTutorialParticipantCollidingRegGroups tutorialUserA tutorialUserB E.insertSelectWithConflict UniqueTutorialParticipant - (E.from $ \tutorialParticipant -> do + (EL.from $ \tutorialParticipant -> do E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val oldUserId return $ TutorialParticipant E.<# (tutorialParticipant E.^. TutorialParticipantTutorial) @@ -764,7 +776,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueSystemMessageHidden - (E.from $ \systemMessageHidden -> do + (EL.from $ \systemMessageHidden -> do E.where_ $ systemMessageHidden E.^. SystemMessageHiddenUser E.==. E.val oldUserId return $ SystemMessageHidden E.<# (systemMessageHidden E.^. SystemMessageHiddenMessage) @@ -789,7 +801,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do ] E.insertSelectWithConflict UniqueRelevantStudyFeatures - (E.from $ \relevantStudyFeatures -> do + (EL.from $ \relevantStudyFeatures -> do E.where_ $ relevantStudyFeatures E.^. RelevantStudyFeaturesStudyFeatures E.==. E.val oldSFId return $ RelevantStudyFeatures E.<# (relevantStudyFeatures E.^. RelevantStudyFeaturesTerm) @@ -815,8 +827,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do unless (Set.null qResolvable) $ deleteWhere [ LmsUserUser ==. oldUserId, LmsUserQualification <-. Set.toList qResolvable ] -- delete conflicting and finished LMS, which are still within auditDuration updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ] updateWhere [ QualificationEditUser ==. oldUserId ] [ QualificationEditUser =. newUserId ] - usrQualis <- E.select $ E.from $ \(oldQual `E.LeftOuterJoin` newQual) -> do - E.on ( newQual E.?. QualificationUserQualification E.?=. oldQual E.^. QualificationUserQualification + usrQualis <- E.select $ EL.from $ \(oldQual `E.LeftOuterJoin` newQual) -> do + EL.on ( newQual E.?. QualificationUserQualification E.?=. oldQual E.^. QualificationUserQualification E.&&. newQual E.?. QualificationUserUser E.?=. E.val newUserId ) E.where_ $ oldQual E.^. QualificationUserUser E.==. E.val oldUserId @@ -838,7 +850,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -- Supervision is fully merged E.insertSelectWithConflict UniqueUserSupervisor - (E.from $ \userSupervisor -> do + (EL.from $ \userSupervisor -> do E.where_ $ userSupervisor E.^. UserSupervisorSupervisor E.==. E.val oldUserId return $ UserSupervisor E.<# E.val newUserId @@ -850,7 +862,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueUserSupervisor - (E.from $ \userSupervisor -> do + (EL.from $ \userSupervisor -> do E.where_ $ userSupervisor E.^. UserSupervisorUser E.==. E.val oldUserId return $ UserSupervisor E.<# (userSupervisor E.^. UserSupervisorSupervisor) @@ -863,7 +875,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -- Companies, in conflict, keep the newUser-Company as is E.insertSelectWithConflict UniqueUserCompany - (E.from $ \userCompany -> do + (EL.from $ \userCompany -> do E.where_ $ userCompany E.^. UserCompanyUser E.==. E.val oldUserId return $ UserCompany E.<# E.val newUserId diff --git a/src/Jobs/Handler/SendCourseCommunication.hs b/src/Jobs/Handler/SendCourseCommunication.hs index 4edaa2d4d..1a065726c 100644 --- a/src/Jobs/Handler/SendCourseCommunication.hs +++ b/src/Jobs/Handler/SendCourseCommunication.hs @@ -31,7 +31,7 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours (sender, Course{..}) <- runDB $ (,) <$> getJust jSender <*> getJust jCourse - either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do + either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do -- userMailT obeys reroutes, userMailT direct does not MsgRenderer mr <- getMailMsgRenderer void $ setMailObjectUUID jMailObjectUUID @@ -59,7 +59,7 @@ dispatchJobSendFirmCommunication jRecipientEmail jAllRecipientAddresses _jCompan -- <$> getJust jSender -- <*> ifMaybeM jCompany Nothing get sender <- runDB $ getJust jSender - either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do + either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do -- userMailT obeys reroutes, userMailT direct does not MsgRenderer mr <- getMailMsgRenderer void $ setMailObjectUUID jMailObjectUUID diff --git a/src/Mail.hs b/src/Mail.hs index 6f8879b71..4f9ab00d6 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -10,6 +10,7 @@ module Mail ( -- * Structured MIME emails module Network.Mail.Mime + , AddressEqIgnoreName(..) -- * MailT , MailT, defMailT , MailSmtpData(..), _smtpEnvelopeFrom, _smtpRecipients @@ -137,6 +138,14 @@ import Network.HTTP.Types.Header (hETag) import Web.HttpApiData (ToHttpApiData(toHeader)) +newtype AddressEqIgnoreName = AddressEqIgnoreName { getAddress :: Address } + deriving (Show, Generic) +instance Eq AddressEqIgnoreName where + (==) = (==) `on` (addressEmail . getAddress) +instance Ord AddressEqIgnoreName where + compare = compare `on` (addressEmail . getAddress) + + makeLenses_ ''Address makeLenses_ ''Mail makeLenses_ ''Part @@ -339,8 +348,8 @@ defMailT ls (MailT mailC) = do return $ mail0 & _mailFrom .~ fromAddress & _mailReplyTo .~ sender - mailRerouteTo' <- mailRerouteTo - let (mail2, smtpData1) = maybe (mail1,smtpData0) switchRecipient mailRerouteTo' -- switch receiver on enveloper, if rerouting is active + mailRerouteTo' <- mailRerouteTo -- this is the general reroute, e.g. for test instances, not for supervisors + let (mail2, smtpData1) = maybe (mail1,smtpData0) switchRecipient mailRerouteTo' -- switch receiver on envelope, if rerouting is active switchRecipient rerouteTo = (Mime.addPart switchInfo mail1, smtpData0 { smtpRecipients = Set.singleton rerouteTo } ) switchInfo = [plainPart $ LT.fromStrict $ "Due to setting 'mail-reroute-to', this mail was diverted; it was intended to be sent to: " <> tshow (smtpRecipients smtpData0)] mail3 <- liftIO $ LBS.toStrict <$> renderMail' mail2 diff --git a/src/Utils/Set.hs b/src/Utils/Set.hs index 7ef167280..79e11c662 100644 --- a/src/Utils/Set.hs +++ b/src/Utils/Set.hs @@ -5,7 +5,7 @@ module Utils.Set ( setIntersectNotOne , setIntersections -, setMapMaybe +, setMapMaybe, setMapMaybeMonotonic , concatMapSet , setSymmDiff , setProduct @@ -56,6 +56,10 @@ setIntersections (h:t) = foldl' Set.intersection h t setMapMaybe :: Ord b => (a -> Maybe b) -> Set a -> Set b setMapMaybe f = Set.fromList . mapMaybe f . Set.toList +-- | like `setMapMaybe`, but only when f is strictly increasing +setMapMaybeMonotonic :: (a -> Maybe b) -> Set a -> Set b +setMapMaybeMonotonic f = Set.fromDistinctAscList . mapMaybe f . Set.toAscList + concatMapSet :: Ord b => (a -> Set b) -> Set a -> Set b concatMapSet f = Set.foldl ((. f) . (<>)) mempty -- concatMapSet f = foldMap f --- requires Ord a as well, which we ought to have anyway @@ -68,8 +72,11 @@ setProduct :: Set a -> Set b -> Set (a, b) -- ^ Depends on the valid internal structure of the given sets setProduct (Set.toAscList -> as) (Set.toAscList -> bs) = Set.fromDistinctAscList $ (,) <$> as <*> bs -setPartitionEithers :: (Ord a, Ord b) => Set (Either a b) -> (Set a, Set b) -setPartitionEithers = (,) <$> setMapMaybe (preview _Left) <*> setMapMaybe (preview _Right) +-- setPartitionEithers :: (Ord a, Ord b) => Set (Either a b) -> (Set a, Set b) +-- setPartitionEithers = (,) <$> setMapMaybe (preview _Left) <*> setMapMaybe (preview _Right) +-- +setPartitionEithers :: Set (Either a b) -> (Set a, Set b) +setPartitionEithers = (,) <$> setMapMaybeMonotonic (preview _Left) <*> setMapMaybeMonotonic (preview _Right) setFromFunc :: (Finite k, Ord k) => (k -> Bool) -> Set k setFromFunc = Set.fromList . flip filter universeF From b1ce55597ec44774f5e293d176236bb35144b0ac Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 1 Dec 2023 13:29:38 +0100 Subject: [PATCH 049/110] chore(lms): remove debug code --- .../uniworx/categories/firm/de-de-formal.msg | 2 +- messages/uniworx/categories/firm/en-eu.msg | 2 +- messages/uniworx/misc/de-de-formal.msg | 1 + messages/uniworx/misc/en-eu.msg | 1 + models/users.model | 2 +- routes | 1 - src/Foundation/Navigation.hs | 11 --- src/Handler/Admin/Avs.hs | 2 +- src/Handler/Firm.hs | 67 +------------------ src/Handler/Users.hs | 2 +- src/Handler/Utils/Table/Cells.hs | 2 +- 11 files changed, 11 insertions(+), 82 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index e53e55b50..1668a06c3 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -35,7 +35,7 @@ FirmSuperActNotify: Mitteilung versenden FirmSuperActRMSuperDef: Standard Firmenansprechpartner entfernen FirmSuperActRMSuperActive: Auch aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden FirmsNotification: Firmen E-Mail versenden -FirmNotification fsh@CompanyShorthand: Benachrichtigung an #{fsh} versenden +FirmNotification fsh@CompanyShorthand: E-Mail an #{fsh} senden FirmsNotificationTitle: Firmen benachrichtigen FirmNotificationTitle fsh@CompanyShorthand: #{fsh} benachrichtigen FilterSupervisor: Hat aktiven Ansprechpartner diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index be6d003ad..7539257d1 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -35,7 +35,7 @@ FirmSuperActNotify: Send message FirmSuperActRMSuperDef: Remove as default supervisor FirmSuperActRMSuperActive: Also remove active supervisions within this company FirmsNotification: Send company notification e-mail -FirmNotification fsh: Send notification to company #{fsh} +FirmNotification fsh: Send e-mail to #{fsh} FirmsNotificationTitle: Company notification FirmNotificationTitle fsh@CompanyShorthand: #{fsh} notification FilterSupervisor: Has active supervisor diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index ef68eb735..eaa02c0fa 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -10,6 +10,7 @@ BoolIrrelevant !ident-ok: — FieldPrimary: Hauptfach FieldSecondary: Nebenfach MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Adressen möglich +MultiSelectTip: Mehrfachauswahl mit Strg-Klick WeekDay: Wochentag LdapIdentificationOrEmail: Fraport AG-Kennung / E-Mail-Adresse Months num@Int64: #{num} #{pluralDE num "Monat" "Monate"} diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index 97423bdda..5b6b15f5b 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -10,6 +10,7 @@ BoolIrrelevant: — FieldPrimary: Major FieldSecondary: Minor MultiEmailFieldTip: Multiple emails addresses may be specified (comma-separated) +MultiSelectTip: Multiple selection via Ctrl-Click WeekDay: Day of the week LdapIdentificationOrEmail: Fraport AG-Kennung / email address Months num: #{num} #{pluralEN num "Month" "Months"} diff --git a/models/users.model b/models/users.model index b29f71eb3..b23fe85b2 100644 --- a/models/users.model +++ b/models/users.model @@ -2,7 +2,7 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later --- The files in /models determine the database scheme. +-- The files in /models determine t he database scheme. -- The organisational split into several files has no operational effects. -- White-space and case matters: Each SQL table is named in 1st column of this file -- Indendent lower-case lines describe the SQL-columns of the table with name, type and options diff --git a/routes b/routes index b024c577f..0ea40300c 100644 --- a/routes +++ b/routes @@ -115,7 +115,6 @@ /firms FirmAllR GET POST -- not yet !supervisor /firms/comm/+Companies FirmsCommR GET POST -/firm/#CompanyShorthand/debug FirmR GET POST /firm/#CompanyShorthand/comm FirmCommR GET POST /firm/#CompanyShorthand FirmUsersR GET POST -- not yet !supervisor /firm/#CompanyShorthand/supers FirmSupersR GET POST -- not yet !supervisor diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index b029cc0ee..1d0258e31 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -125,7 +125,6 @@ breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing breadcrumb FirmsCommR{} = i18nCrumb MsgMenuFirmsComm $ Just FirmAllR -breadcrumb FirmR{} = i18nCrumb MsgMenuAdminHeading $ Just FirmAllR -- TODO: change heading or remove breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirmUsers $ Just FirmAllR breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors $ Just $ FirmUsersR fsh breadcrumb (FirmCommR fsh)= i18nCrumb MsgMenuFirmsComm $ Just $ FirmUsersR fsh @@ -2417,16 +2416,6 @@ pageActions ApiDocsR = return , navChildren = [] } ] -pageActions (FirmR fsh) = return - [ NavPageActionPrimary - { navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh - , navChildren = [] - } - , NavPageActionPrimary - { navLink = defNavLink MsgTableCompanyNrUsers $ FirmUsersR fsh - , navChildren = [] - } - ] pageActions (FirmUsersR fsh) = return [ NavPageActionPrimary { navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index f65f44f50..9521912c9 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -558,7 +558,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) let icnSuper = toWidget $ text2markup " " <> icon IconSupervisor companies = - (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies' + (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmUsersR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies' pure $ intercalate (text2widget "; ") companies , sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe lmsShortCell q diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index fcf60c8a6..881be6223 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -7,8 +7,7 @@ {-# LANGUAGE TypeApplications #-} module Handler.Firm - ( getFirmAllR , postFirmAllR - , getFirmR , postFirmR + ( getFirmAllR , postFirmAllR , getFirmUsersR , postFirmUsersR , getFirmSupersR, postFirmSupersR , getFirmCommR , postFirmCommR @@ -415,65 +414,6 @@ firmCountUserSupervisorsReroute usrCmp = E.subSelectCount $ do E.&&. usrSpr E.^. UserSupervisorRerouteNotifications ------------------- --- Debug Handler - -getFirmR, postFirmR :: CompanyShorthand -> Handler Html -getFirmR = postFirmR -postFirmR fsh = do - let cid = CompanyKey fsh - cusers <- runDB $ do - cusers <- selectList [UserCompanyCompany ==. cid] [] - selectList [UserId <-. fmap (userCompanyUser . entityVal) cusers] [Asc UserDisplayName] - csuper <- runDB $ do - csuper <- selectList [UserCompanyCompany ==. cid, UserCompanySupervisor ==. True] [] - selectList [UserId <-. fmap (userCompanyUser . entityVal) csuper] [Asc UserDisplayName] - cactSuper <- runDB $ E.select $ do - (usr :& spr :& scmpy) <- E.from $ - E.table @User - `E.innerJoin` E.table @UserSupervisor - `E.on` (\(usr :& spr ) -> spr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId) - `E.leftJoin` E.table @UserCompany - `E.on` (\(_ :& spr :& scmpy) -> spr E.^. UserSupervisorSupervisor E.=?. scmpy E.?. UserCompanyUser) - E.where_ $ (spr E.^. UserSupervisorUser) `E.in_` E.valList (entityKey <$> cusers) - E.groupBy (usr E.^. UserId, usr E.^. UserDisplayName, usr E.^. UserSurname, scmpy E.?. UserCompanyCompany) - E.orderBy [E.asc $ usr E.^. UserId, E.asc $ usr E.^. UserDisplayName, E.asc $ usr E.^. UserSurname, E.asc $ scmpy E.?. UserCompanyCompany] - let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows - return (usr E.^. UserId, usr E.^. UserDisplayName, usr E.^. UserSurname, scmpy E.?. UserCompanyCompany, countRows', usr E.^. UserPrefersPostal) - - siteLayoutMsg (SomeMessage fsh) $ do - setTitle $ citext2Html fsh - [whamlet| -

              PROVISORISCHE DEBUG SEITE -

              Diese Seite wird in der finalen Version nicht mehr enthalten sein. - -

              #{length csuper} Company Default Supervisors (non-foreign only) -
                - $forall u <- csuper -
              • ^{linkUserWidget ForProfileDataR u} - -

                #{length cactSuper} Active Supervisors for Employees -
                  - $forall (E.Value _, E.Value dn, E.Value sn, E.Value mbCsh, E.Value nr, E.Value prefPost) <- cactSuper -
                • #{nr} Employees supervised by ^{nameWidget dn sn} # - #{iconLetterOrEmail prefPost} # - $maybe csh <- mbCsh - $if csh /= cid - from foreign company #{unCompanyKey csh} - $else - from this company - $nothing - having no associated company - -

                  #{length cusers} Employees -
                    - $forall u <- cusers -
                  • ^{linkUserWidget ForProfileDataR u} - - In the end, this needs to be a dbTable, of course! - |] - - ----------------------- -- All Firms Table @@ -536,8 +476,7 @@ mkFirmAllTable isAdmin uid = do , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> let fsh = companyShorthand firm in anchorCell (FirmSupersR fsh) $ toWgt fsh - , sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> - anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm + , sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> numCell $ companyAvsId firm , sortable (Just "users") (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupersDefault) $ \row -> anchorCell (FirmSupersR $ row ^. resultAllCompany . _companyShorthand) $ toWgt $ hasTickmark $ row ^. resultAllCompanySupervisors @@ -826,7 +765,7 @@ mkFirmUserTable isAdmin cid = do dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev -- , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) - , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor) + , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor & setTooltip MsgMultiSelectTip ) , prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor) , prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh) , prismAForm (singletonFilter "has-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorForeign fsh) diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 0cbbbde66..b2c8d3073 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -109,7 +109,7 @@ postUsersR = do return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) let icnSuper = toWidget $ text2markup " " <> icon IconSupervisor companies = - (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies' + (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmUsersR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies' pure $ intercalate (text2widget "; ") companies -- , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM -- (AdminUserR <$> encrypt uid) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 6b776cd41..a1ca0a18a 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -358,7 +358,7 @@ courseCell Course{..} = anchorCell link name `mappend` desc companyCell :: IsDBTable m a => CompanyShorthand -> CompanyName -> Bool -> DBCell m a companyCell cid cname isSupervisor = anchorCell link name where - link = FirmR cid + link = FirmUsersR cid corg = ciOriginal cname name | isSupervisor = text2markup (corg <> " ") <> icon IconSupervisor From 34c0928718a0dcac57a0ba97f7b9f0e24383c9ed Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 1 Dec 2023 16:12:10 +0100 Subject: [PATCH 050/110] chore(firm): add switch supervisor status --- .../uniworx/categories/firm/de-de-formal.msg | 6 ++++-- messages/uniworx/categories/firm/en-eu.msg | 6 ++++-- src/Handler/Firm.hs | 21 +++++++++++++++++-- 3 files changed, 27 insertions(+), 6 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 1668a06c3..f938dbaa9 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -16,7 +16,7 @@ FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzl FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig FirmActAddSupersvisors: Ansprechpartner hinzufügen FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden -FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner eingetragen #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert. +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)} FirmActChangeContactUser: Kontaktinformationen von allen Firmenangehörigen ändern FirmActChangeContactFirm: Kontaktinformationen der Firma ändern @@ -32,7 +32,9 @@ FirmUserActMkSuper: Zum Firmenansprechpartner ernennen FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{bool mempty (", " <> tshow rem <> " zuvor gelöscht") (rem > 0)} FirmSuperActNotify: Mitteilung versenden -FirmSuperActRMSuperDef: Standard Firmenansprechpartner entfernen +FirmSuperActSwitchSuper: Standard Firmenansprechpartner abändern +FirmSuperActSwitchSuperInfo: Betrifft keine firmenfremden Ansprechpartner und ändert keine aktiven individuellen Ansprechpartnerbeziehungen. Gegebenfalls im Anschluss die Funktion "Ansprechpartner auf Firmenstandard zurücksetzen" nutzen. +FirmSuperActRMSuperDef: Firmenansprechpartner entfernen FirmSuperActRMSuperActive: Auch aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden FirmsNotification: Firmen E-Mail versenden FirmNotification fsh@CompanyShorthand: E-Mail an #{fsh} senden diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 7539257d1..747900397 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -16,7 +16,7 @@ FirmActResetSuperKeep: Additionally keep existing supervisors of company associa FirmActResetMutualSupervision: Supervisors supervise each other FirmActAddSupersvisors: Add supervisors FirmActAddSupersEmpty: No supervisors added -FirmActAddSupersSet n postal: #{n} default company supervisors set #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated. +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)} FirmActChangeContactUser: Change contact data for all company associates FirmActChangeContactFirm: Change company contact data @@ -32,7 +32,9 @@ FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> FirmUserActChangeContact: Change contact data for selected company associates FirmUserActMkSuper: Mark as company supervisor FirmSuperActNotify: Send message -FirmSuperActRMSuperDef: Remove as default supervisor +FirmSuperActSwitchSuper: Change default company supervisor +FirmSuperActSwitchSuperInfo: Does not affect company-external supervisors and does not change any active individal supervisions. Additionally use reset action, if desired. +FirmSuperActRMSuperDef: Remove default supervisor FirmSuperActRMSuperActive: Also remove active supervisions within this company FirmsNotification: Send company notification e-mail FirmNotification fsh: Send e-mail to #{fsh} diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 881be6223..11ff2e4fa 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -913,6 +913,7 @@ postFirmUsersR fsh = do -- Firm Supervisors Table data FirmSuperAction = FirmSuperActNotify + | FirmSuperActSwitchSuper | FirmSuperActRMSuperDef deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) @@ -922,6 +923,10 @@ nullaryPathPiece ''FirmSuperAction $ camelToPathPiece' 3 embedRenderMessage ''UniWorX ''FirmSuperAction id data FirmSuperActionData = FirmSuperActNotifyData + | FirmSuperActSwitchSuperData + { firmSuperActSwitchSuper :: Maybe Bool + , firmSuperActSwitchReroute :: Maybe Bool + } | FirmSuperActRMSuperDefData { firmSuperActRMSuperActive :: Maybe Bool } @@ -968,6 +973,7 @@ instance HasUser SuperCompanyTableData where mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Set UserId), Widget) mkFirmSuperTable isAdmin cid = do + msgSupervisorUnchanged <- messageI Info MsgFirmSuperActSwitchSuperInfo let -- fsh = unCompanyKey cid resultDBTable = DBTable{..} @@ -1032,6 +1038,10 @@ mkFirmSuperTable isAdmin cid = do acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData) acts = mconcat [ guardMonoid isAdmin $ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData + , singletonMap FirmSuperActSwitchSuper $ FirmSuperActSwitchSuperData + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultSupervisor) (Just $ Just True) + <*> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultReroute) (Nothing) + <* aformMessage msgSupervisorUnchanged , singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData <$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True) ] @@ -1079,7 +1089,7 @@ postFirmSupersR fsh = do (FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do (nrRmSuper,nrRmActual) <- runDB $ (,) <$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False] - <*> if firmSuperActRMSuperActive /= Just True + <*> if firmSuperActRMSuperActive /= Just True then return 0 else E.deleteCount $ do spr <- E.from $ E.table @UserSupervisor @@ -1091,7 +1101,14 @@ postFirmSupersR fsh = do ) addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes - + (FirmSuperActSwitchSuperData{..}, Set.toList -> uids) -> do + let fltrSpr = guardMonoid (isNothing firmSuperActSwitchSuper) [UserCompanySupervisor ==. True] + changes = maybeEmpty firmSuperActSwitchSuper (pure . (UserCompanySupervisor =.)) + <> guardMonoid (firmSuperActSwitchSuper /= Just False || firmSuperActSwitchReroute == Just False) ( + maybeEmpty firmSuperActSwitchReroute (pure . (UserCompanySupervisorReroute =.))) + nrSuperChanges <- runDB $ updateWhereCount (fltrSpr <> [UserCompanyUser <-. uids, UserCompanyCompany ==. cid]) changes + addMessageI Info $ MsgFirmActAddSupersSet nrSuperChanges Nothing + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes (FirmSuperActNotifyData , uids) -> do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) From 1d3345cbba1cb65ee49c6f62e145750545439642 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 1 Dec 2023 16:55:51 +0100 Subject: [PATCH 051/110] fix(firm): supervisor changes led to inconsistent DB --- src/Handler/Firm.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 11ff2e4fa..f86048434 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -1102,10 +1102,14 @@ postFirmSupersR fsh = do addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes (FirmSuperActSwitchSuperData{..}, Set.toList -> uids) -> do - let fltrSpr = guardMonoid (isNothing firmSuperActSwitchSuper) [UserCompanySupervisor ==. True] - changes = maybeEmpty firmSuperActSwitchSuper (pure . (UserCompanySupervisor =.)) - <> guardMonoid (firmSuperActSwitchSuper /= Just False || firmSuperActSwitchReroute == Just False) ( - maybeEmpty firmSuperActSwitchReroute (pure . (UserCompanySupervisorReroute =.))) + let (fltrSpr, changes) = case (firmSuperActSwitchSuper, firmSuperActSwitchReroute) of + (Just True, Nothing) -> ([UserCompanySupervisor ==. False], [UserCompanySupervisor =. True ]) + (Just True, Just rer) -> ([UserCompanySupervisor ==. False] ||. [UserCompanySupervisorReroute !=. rer] + , [UserCompanySupervisor =. True , UserCompanySupervisorReroute =. rer ]) + (Just False, _) -> ([UserCompanySupervisor ==. True ], [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False]) + (Nothing, Just True) -> ([UserCompanySupervisor ==. True, UserCompanySupervisorReroute ==. False], [UserCompanySupervisorReroute =. True ]) + (Nothing, Just False) -> ([ UserCompanySupervisorReroute ==. True ], [UserCompanySupervisorReroute =. False]) + (Nothing, Nothing ) -> ([],[]) nrSuperChanges <- runDB $ updateWhereCount (fltrSpr <> [UserCompanyUser <-. uids, UserCompanyCompany ==. cid]) changes addMessageI Info $ MsgFirmActAddSupersSet nrSuperChanges Nothing reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes From df6a7ee1e2ed47e76f60477322ca433edbd84445 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 1 Dec 2023 17:04:42 +0100 Subject: [PATCH 052/110] chore(lms): deactivate lms synch by default --- config/settings.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index b3c228991..602c9c0e2 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -91,8 +91,8 @@ study-features-recache-relevance-within: 172800 study-features-recache-relevance-interval: 293 # Enqueue at specified hour, a few minutes later -job-lms-qualifications-enqueue-hour: 15 -job-lms-qualifications-dequeue-hour: 3 +# job-lms-qualifications-enqueue-hour: 15 +# job-lms-qualifications-dequeue-hour: 3 log-settings: detailed: "_env:DETAILED_LOGGING:false" From fcc802753a75f0829238e3cbdce46dfc0d7ca4e7 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 1 Dec 2023 18:11:02 +0100 Subject: [PATCH 053/110] chore(lms): remove obsolete lms handlers v1 --- .../categories/qualification/de-de-formal.msg | 6 - .../categories/qualification/en-eu.msg | 6 - .../utils/navigation/menu/de-de-formal.msg | 2 - .../uniworx/utils/navigation/menu/en-eu.msg | 2 - models/lms.model | 37 +-- routes | 9 - src/Foundation/Navigation.hs | 30 +- src/Handler/LMS.hs | 12 +- src/Handler/LMS/Result.hs | 293 ------------------ src/Handler/LMS/Userlist.hs | 288 ----------------- src/Handler/Utils/LMS.hs | 10 - src/Jobs/Handler/LMS.hs | 127 +------- src/Jobs/Types.hs | 6 +- src/Utils/Lens.hs | 2 - test/Database/Fill.hs | 6 - 15 files changed, 11 insertions(+), 825 deletions(-) delete mode 100644 src/Handler/LMS/Result.hs delete mode 100644 src/Handler/LMS/Userlist.hs diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 1571d7ac1..e0fee7cb8 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -84,14 +84,8 @@ CsvColumnLmsDate: Datum des E‑Learning Ereignisses CsvColumnLmsResetTries: Anzahl der bisher verbrauchten E‑Learning Prüfungsversuche zurücksetzen CsvColumnLmsLock: E‑Learning Login gesperrt CsvColumnLmsResult !ident-ok: LMS Status -LmsUserlistInsert: Neuer LMS User -LmsUserlistUpdate: LMS User Aktualisierung -LmsResultInsert: Neues LMS Ergebnis -LmsResultUpdate: LMS Ergebnis Aktualisierung LmsReportInsert: Neues LMS Ereignis LmsReportUpdate: LMS Ereignis Aktualisierung -LmsResultCsvExceptionDuplicatedKey: CSV-Import LmsResult fand uneindeutigen Schlüssel -LmsUserlistCsvExceptionDuplicatedKey: CSV-Import LmsUserlist fand uneindeutigen Schlüssel LmsReportCsvExceptionDuplicatedKey: CSV-Import LmsReport fand uneindeutigen Schlüssel LmsDirectUpload: Direkter Upload für automatisierte Systeme LmsErrorNoRefreshElearning: Fehler: E‑Learning wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde. diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 5d466355b..c886cb843 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -84,14 +84,8 @@ CsvColumnLmsResetTries: Reset number of used up e‑learning exam attempts CsvColumnLmsDate: Date of e‑learning event CsvColumnLmsResult: LMS Status CsvColumnLmsLock: E‑learning login is not permitted -LmsUserlistInsert: New LMS user -LmsUserlistUpdate: Update of LMS user -LmsResultInsert: New LMS result -LmsResultUpdate: Update of LMS result LmsReportInsert: New LMS event LmsReportUpdate: Update of LMS event -LmsResultCsvExceptionDuplicatedKey: CSV import LmsResult with ambiguous key -LmsUserlistCsvExceptionDuplicatedKey: CSV import LmsUserlist with ambiguous key LmsReportCsvExceptionDuplicatedKey: CSV Import LmsReport with ambiguous key LmsDirectUpload: Direct upload for automated systems LmsErrorNoRefreshElearning: Error: E‑learning will not be started automatically due to refresh-within time period not being set. diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index b306bfdfc..d7d246ed3 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -124,8 +124,6 @@ MenuLmsUser: Benutzerqualifikationen MenuLmsUserSchool: Bereichs Benutzerqualifikationen MenuLmsUserAll: Alle Benutzerqualifikationen MenuLmsUsers: Veralteter Export E‑Learning Benutzer -MenuLmsUserlist: Veraltetes Melden E‑Learning Benutzer -MenuLmsResult: Veralteter Melden Ergebnisse E‑Learning MenuLmsUpload: Hochladen MenuLmsDirectUpload: Direkter Upload MenuLmsDirectDownload: Direkter Download diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index c8c18365f..02e25ca1e 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -125,8 +125,6 @@ MenuLmsUser: User Qualifications MenuLmsUserSchool: Institute User Qualifications MenuLmsUserAll: All User Qualifications MenuLmsUsers: Legacy download e‑learning users -MenuLmsUserlist: Legacy upload e‑learning users -MenuLmsResult: Legacy upload r‑learning results MenuLmsUpload: Upload MenuLmsDirectUpload: Direct Upload MenuLmsDirectDownload: Direct Download diff --git a/models/lms.model b/models/lms.model index 4ba0f3927..d9f4c1b7e 100644 --- a/models/lms.model +++ b/models/lms.model @@ -95,25 +95,20 @@ QualificationUserBlock -- - delete-flag: isJust LmsUserStatus -- Note: REST means that LmsUserResetPin and LmsUserDelete remain unchanged by this GET request! -- - -- 3. REST POST Userlist.csv: just save as is to LmsUserlist + -- 3. REST POST Report.csv: just save as is to LmsReport for later processing -- - -- 4. REST POST Ergebnisse.csv: just save as is to LmsResult - -- - -- 5. When received: Job LmsUserlist: -- Note: containment needs at-once processing + -- 4. When received: Job LmsReport: -- Note: containment needs at-once processing -- - For all LmsUser: -- + if contained: -- set LmsUserReceived to Just now() - -- if LmsUserlistFailed: set LmsUserStatus to Just LmsBlocked now + -- if Failed: set LmsUserStatus to Just LmsBlocked now + -- if Success: set LmsUserStatus to Just LmsSuccess now + -- and renew QualificationValidTo -- + not contained, by LmsUserReceived is set: set LmsUserEnded to Just now() -- - move row to LmsAudit -- - -- 6. When received: Daily Job LmsResult: - -- - set LmsUserReceived to Just now() -- always - -- - set LmsUserStatus to Just LmsSuccess now -- conditional - -- - and renew QualificationValidTo - -- - move row to LmsAudit - -- - -- 7. Daily Job: dequeue LMS Users + -- 5. Daily Job: dequeue LMS Users + -- - fail and mark expired LmsUser -- - remove from LmsUser after audit Period has passed LmsUser @@ -144,24 +139,6 @@ LmsUser -- UniqueLmsUserStatus lmsUser -- enforcing uniqueness prohibits history -- deriving Generic --- DEPRECATED V1 LmsUserlist stores LMS upload for later processing only -LmsUserlist - qualification QualificationId OnDeleteCascade OnUpdateCascade - ident LmsIdent - failed Bool - timestamp UTCTime default=now() - UniqueLmsUserlist qualification ident - deriving Generic Show - --- DEPRECATED V1 LmsResult stores LMS upload for later processing only -LmsResult - qualification QualificationId OnDeleteCascade OnUpdateCascade - ident LmsIdent - success Day -- BEWARE: timezone is local as submitted by LMS - timestamp UTCTime default=now() - UniqueLmsResult qualification ident -- required by DBTable - deriving Generic - -- V2 Stores LMS upload for processing in Background Job LmsReport qualification QualificationId OnDeleteCascade OnUpdateCascade diff --git a/routes b/routes index 0ea40300c..34891b367 100644 --- a/routes +++ b/routes @@ -279,15 +279,6 @@ /lms/#SchoolId LmsSchoolR GET /lms/#SchoolId/#QualificationShorthand LmsR GET POST /lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST --- old V1 LMS Interface -/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET -/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !token -- LMS -/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST -/lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST !development -/lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST !token -- LMS, also remove JobLmsUserlist constructor -/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST -/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST !development -/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token -- LMS, also remove JobLmsResults constructor -- new V2 LMS Interface /lms/#SchoolId/#QualificationShorthand/learners LmsLearnersR GET /lms/#SchoolId/#QualificationShorthand/learners/direct LmsLearnersDirectR GET !token -- LMS diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 1d0258e31..59e430487 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -185,14 +185,6 @@ breadcrumb (LmsR ssh qsh) = useRunDB . maybeT (i18nCrumb MsgBrea guardM . lift . existsBy $ SchoolQualificationShort ssh qsh return (CI.original qsh, Just $ LmsSchoolR ssh) breadcrumb (LmsEditR ssh qsh) = i18nCrumb MsgMenuLmsEdit $ Just $ LmsR ssh qsh -breadcrumb (LmsUsersR ssh qsh) = i18nCrumb MsgMenuLmsUsers $ Just $ LmsR ssh qsh -breadcrumb (LmsUsersDirectR ssh qsh) = i18nCrumb MsgMenuLmsUsers $ Just $ LmsUsersR ssh qsh -- never displayed, TypedContent -breadcrumb (LmsUserlistR ssh qsh) = i18nCrumb MsgMenuLmsUserlist $ Just $ LmsR ssh qsh -breadcrumb (LmsUserlistUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsUserlistR ssh qsh -breadcrumb (LmsUserlistDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsUserlistR ssh qsh -- never displayed -breadcrumb (LmsResultR ssh qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsR ssh qsh -breadcrumb (LmsResultUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh -breadcrumb (LmsResultDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh -- never displayed -- v2 breadcrumb (LmsLearnersR ssh qsh) = i18nCrumb MsgMenuLmsLearners $ Just $ LmsR ssh qsh breadcrumb (LmsLearnersDirectR ssh qsh) = i18nCrumb MsgMenuLmsLearners $ Just $ LmsLearnersR ssh qsh -- never displayed, TypedContent @@ -2375,27 +2367,7 @@ pageActions (LmsR sid qsh) = return [ defNavLink MsgMenuLmsUpload $ LmsReportUploadR sid qsh , defNavLink MsgMenuLmsDirectUpload $ LmsReportDirectR sid qsh ] - } - , NavPageActionSecondary - { navLink = defNavLink MsgMenuLmsUsers $ LmsUsersR sid qsh - -- , navChildren = - -- [ defNavLink MsgMenuLmsDirectDownload $ LmsUsersDirectR sid qsh - -- ] - } - , NavPageActionSecondary - { navLink = defNavLink MsgMenuLmsUserlist $ LmsUserlistR sid qsh - -- , navChildren = - -- [ defNavLink MsgMenuLmsUpload $ LmsUserlistUploadR sid qsh - -- , defNavLink MsgMenuLmsDirectUpload $ LmsUserlistDirectR sid qsh - -- ] - } - , NavPageActionSecondary - { navLink = defNavLink MsgMenuLmsResult $ LmsResultR sid qsh - -- , navChildren = - -- [ defNavLink MsgMenuLmsUpload $ LmsResultUploadR sid qsh - -- , defNavLink MsgMenuLmsDirectUpload $ LmsResultDirectR sid qsh - -- ] - } + } , NavPageActionSecondary { navLink = defNavLink MsgMenuLmsEdit $ LmsEditR sid qsh } diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 5bf9beb94..abc8d8bd6 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -11,13 +11,7 @@ module Handler.LMS , getLmsR , postLmsR , getLmsIdentR , getLmsEditR , postLmsEditR - -- V1 - , getLmsUsersR , getLmsUsersDirectR - , getLmsUserlistR , postLmsUserlistR - , getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR - , getLmsResultR , postLmsResultR - , getLmsResultUploadR , postLmsResultUploadR , postLmsResultDirectR - -- V1 + -- V2 , getLmsLearnersR , getLmsLearnersDirectR , getLmsReportR , postLmsReportR , getLmsReportUploadR , postLmsReportUploadR , postLmsReportDirectR @@ -50,10 +44,6 @@ import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH import Database.Persist.Sql (deleteWhereCount, updateWhereCount) --- V1 -import Handler.LMS.Users as Handler.LMS -import Handler.LMS.Userlist as Handler.LMS -import Handler.LMS.Result as Handler.LMS -- V2 import Handler.LMS.Learners as Handler.LMS import Handler.LMS.Report as Handler.LMS diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs deleted file mode 100644 index aca551ab6..000000000 --- a/src/Handler/LMS/Result.hs +++ /dev/null @@ -1,293 +0,0 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost ,Steffen Jost --- --- SPDX-License-Identifier: AGPL-3.0-or-later - -{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances - -module Handler.LMS.Result - ( getLmsResultR, postLmsResultR - , getLmsResultUploadR, postLmsResultUploadR - , postLmsResultDirectR - ) - where - -import Import - -import Handler.Utils -import Handler.Utils.Csv -import Handler.Utils.LMS - -import qualified Data.Map as Map -import qualified Data.Csv as Csv -import qualified Data.Conduit.List as C -import qualified Database.Esqueleto.Legacy as E -import qualified Database.Esqueleto.Utils as E - -import Jobs.Queue - - -data LmsResultTableCsv = LmsResultTableCsv - { csvLRTident :: LmsIdent - , csvLRTsuccess :: LmsDay - } - deriving Generic -makeLenses_ ''LmsResultTableCsv - --- csv without headers -instance Csv.ToRecord LmsResultTableCsv -- default suffices -instance Csv.FromRecord LmsResultTableCsv -- default suffices - --- csv with headers -lmsResultTableCsvHeader :: Csv.Header -lmsResultTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsSuccess ] - -instance ToNamedRecord LmsResultTableCsv where - toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord - [ csvLmsIdent Csv..= csvLRTident - , csvLmsSuccess Csv..= csvLRTsuccess - ] - -instance FromNamedRecord LmsResultTableCsv where - parseNamedRecord (lsfHeaderTranslate -> csv) - = LmsResultTableCsv - <$> csv Csv..: csvLmsIdent - <*> csv Csv..: csvLmsSuccess - -instance CsvColumnsExplained LmsResultTableCsv where - csvColumnsExplanations _ = mconcat - [ single csvLmsIdent MsgCsvColumnLmsIdent - , single csvLmsSuccess MsgCsvColumnLmsSuccess - ] - where - single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget - single k v = singletonMap k [whamlet|_{v}|] - -data LmsResultCsvActionClass = LmsResultInsert | LmsResultUpdate - deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded) -embedRenderMessage ''UniWorX ''LmsResultCsvActionClass id - --- By coincidence the action type is identical to LmsResultTableCsv -data LmsResultCsvAction = LmsResultInsertData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day } - | LmsResultUpdateData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day } - deriving (Eq, Ord, Read, Show, Generic) - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece'' 2 1 -- LmsResultInsertData -> insert - , fieldLabelModifier = camelToPathPiece' 2 -- lmsResultInsertIdent -> insert-ident | lmsResultInsertSuccess -> insert-success - , sumEncoding = TaggedObject "action" "data" - } ''LmsResultCsvAction - -data LmsResultCsvException - = LmsResultCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?! - deriving (Show, Generic) - -instance Exception LmsResultCsvException -embedRenderMessage ''UniWorX ''LmsResultCsvException id - -mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) -mkResultTable sid qsh qid = do - now_day <- utctDay <$> liftIO getCurrentTime - dbtCsvName <- csvFilenameLmsResult qsh - let dbtCsvSheetName = dbtCsvName - let - resultDBTable = DBTable{..} - where - dbtSQLQuery lmsresult = do - E.where_ $ lmsresult E.^. LmsResultQualification E.==. E.val qid - return lmsresult - dbtRowKey = (E.^. LmsResultId) - dbtProj = dbtProjId - dbtColonnade = dbColonnade $ mconcat - [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident - , sortable (Just csvLmsSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ _dbrOutput . _entityVal . _lmsResultSuccess -> success) -> dayCell success - , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \(view $ _dbrOutput . _entityVal . _lmsResultTimestamp -> timestamp) -> dateTimeCell timestamp - ] - dbtSorting = Map.fromList - [ (csvLmsIdent , SortColumn (E.^. LmsResultIdent)) - , (csvLmsSuccess , SortColumn (E.^. LmsResultSuccess)) - , (csvLmsTimestamp, SortColumn (E.^. LmsResultTimestamp)) - ] - dbtFilter = Map.fromList - [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsResultIdent)) - , (csvLmsSuccess, FilterColumn $ E.mkExactFilter (E.^. LmsResultSuccess)) - ] - dbtFilterUI = \mPrev -> mconcat - [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) - , prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableLmsSuccess) - ] - dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - dbtParams = def - dbtIdent :: Text - dbtIdent = "lms-result" - dbtCsvEncode = Just DBTCsvEncode - { dbtCsvExportForm = pure () - , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) - , dbtCsvName - , dbtCsvSheetName - , dbtCsvNoExportData = Just id - , dbtCsvHeader = const $ return lmsResultTableCsvHeader - , dbtCsvExampleData = Just - [ LmsResultTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day } - | (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..] - ] - } - where - doEncode' = LmsResultTableCsv - <$> view (_dbrOutput . _entityVal . _lmsResultIdent) - <*> view (_dbrOutput . _entityVal . _lmsResultSuccess . _lmsDay) - dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later - { dbtCsvRowKey = \LmsResultTableCsv{..} -> - fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident - , dbtCsvComputeActions = \case -- purpose is to show a diff to the user first - DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do - yield $ LmsResultInsertData - { lmsResultInsertIdent = csvLRTident dbCsvNew - , lmsResultInsertSuccess = csvLRTsuccess dbCsvNew & lms2day - } - DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsResult was found, but the key no longer exists." -- TODO: how can this ever happen? Check Pagination-Code - DBCsvDiffExisting{dbCsvNew = LmsResultTableCsv{..}, dbCsvOld} -> do - let successDay = lms2day csvLRTsuccess - when (successDay /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsResultSuccess) $ - yield $ LmsResultUpdateData - { lmsResultInsertIdent = csvLRTident - , lmsResultInsertSuccess = successDay - } - DBCsvDiffMissing{} -> return () -- no deletion - , dbtCsvClassifyAction = \case - LmsResultInsertData{} -> LmsResultInsert - LmsResultUpdateData{} -> LmsResultUpdate - , dbtCsvCoarsenActionClass = \case - LmsResultInsert -> DBCsvActionNew - LmsResultUpdate -> DBCsvActionExisting - , dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error - , dbtCsvExecuteActions = do - C.mapM_ $ \actionData -> do - now <- liftIO getCurrentTime - void $ upsert - LmsResult - { lmsResultQualification = qid - , lmsResultIdent = lmsResultInsertIdent actionData - , lmsResultSuccess = lmsResultInsertSuccess actionData - , lmsResultTimestamp = now -- lmsResultInsertTimestamp -- does it matter which one to choose? - } - [ LmsResultSuccess =. lmsResultInsertSuccess actionData - , LmsResultTimestamp =. now - ] - -- audit $ Transaction.. (add to Audit.Types) - lift . queueDBJob $ JobLmsResults qid - return $ LmsResultR sid qsh - , dbtCsvRenderKey = const $ \case - LmsResultInsertData{..} -> do -- TODO: i18n - [whamlet| - $newline never - Insert: Ident #{getLmsIdent lmsResultInsertIdent} # - had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess} - |] - LmsResultUpdateData{..} -> do -- TODO: i18n - [whamlet| - $newline never - Update: Ident #{getLmsIdent lmsResultInsertIdent} # - had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess} - |] - , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure - , dbtCsvRenderException = ap getMessageRender . pure :: LmsResultCsvException -> DB Text - } - dbtExtraReps = [] - - resultDBTableValidator = def - & defaultSorting [SortAscBy csvLmsIdent] - dbTable resultDBTableValidator resultDBTable - -getLmsResultR, postLmsResultR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsResultR = postLmsResultR -postLmsResultR sid qsh = do - let directUploadLink = LmsResultUploadR sid qsh - lmsTable <- runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - view _2 <$> mkResultTable sid qsh qid - siteLayoutMsg MsgMenuLmsResult $ do - setTitleI MsgMenuLmsResult - $(widgetFile "lms-result") - - --- Direct File Upload/Download - -saveResultCsv :: QualificationId -> Int -> LmsResultTableCsv -> DB Int -saveResultCsv qid i LmsResultTableCsv{..} = do - now <- liftIO getCurrentTime - void $ upsert - LmsResult - { lmsResultQualification = qid - , lmsResultIdent = csvLRTident - , lmsResultSuccess = csvLRTsuccess & lms2day - , lmsResultTimestamp = now - } - [ LmsResultSuccess =. (csvLRTsuccess & lms2day) - , LmsResultTimestamp =. now - ] - return $ succ i - -makeResultUploadForm :: Form FileInfo -makeResultUploadForm = renderAForm FormStandard $ fileAFormReq "Result CSV" - -getLmsResultUploadR, postLmsResultUploadR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsResultUploadR = postLmsResultUploadR -postLmsResultUploadR sid qsh = do - ((result,widget), enctype) <- runFormPost makeResultUploadForm - case result of - FormSuccess file -> do - -- content <- fileSourceByteString file - -- return $ Just (fileName file, content) - nr <- runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - nr <- runConduit $ fileSource file - .| decodeCsv - .| foldMC (saveResultCsv qid) 0 - queueJob' $ JobLmsResults qid - return nr - addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") - redirect $ LmsResultR sid qsh - FormFailure errs -> do - forM_ errs $ addMessage Error . toHtml - redirect $ LmsResultUploadR sid qsh - FormMissing -> - siteLayoutMsg MsgMenuLmsResult $ do - setTitleI MsgMenuLmsUpload - [whamlet|$newline never -
                    - ^{widget} -

                    - - |] - - -postLmsResultDirectR :: SchoolId -> QualificationShorthand -> Handler Html -postLmsResultDirectR sid qsh = do - (_params, files) <- runRequestBody - (status, msg) <- case files of - [(fhead,file)] -> do - lmsDecoder <- getLmsCsvDecoder - runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - enr <- try $ runConduit $ fileSource file - .| lmsDecoder - .| foldMC (saveResultCsv qid) 0 - case enr of - Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error - $logWarnS "LMS" $ "Result upload failed parsing: " <> tshow e - return (badRequest400, "Exception: " <> tshow e) - Right nr -> do - let msg = "Success. LMS Result upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". " - $logInfoS "LMS" msg - when (nr > 0) $ queueJob' $ JobLmsResults qid - return (ok200, msg) - [] -> do - let msg = "Result upload file missing." - $logWarnS "LMS" msg - return (badRequest400, msg) - _other -> do - let msg = "Result upload received multiple files; all ignored." - $logWarnS "LMS" msg - return (badRequest400, msg) - sendResponseStatus status msg - diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs deleted file mode 100644 index 6304c5be7..000000000 --- a/src/Handler/LMS/Userlist.hs +++ /dev/null @@ -1,288 +0,0 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost --- --- SPDX-License-Identifier: AGPL-3.0-or-later - -{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances - -module Handler.LMS.Userlist - ( getLmsUserlistR, postLmsUserlistR - , getLmsUserlistUploadR, postLmsUserlistUploadR - , postLmsUserlistDirectR - ) - where - -import Import - -import Handler.Utils -import Handler.Utils.Csv -import Handler.Utils.LMS - -import qualified Data.Map as Map -import qualified Data.Csv as Csv -import qualified Data.Conduit.List as C -import qualified Database.Esqueleto.Legacy as E -import qualified Database.Esqueleto.Utils as E - -import Jobs.Queue - -data LmsUserlistTableCsv = LmsUserlistTableCsv - { csvLULident :: LmsIdent - , csvLULfailed :: LmsBool - } - deriving Generic -makeLenses_ ''LmsUserlistTableCsv - --- csv without headers -instance Csv.ToRecord LmsUserlistTableCsv -instance Csv.FromRecord LmsUserlistTableCsv - --- csv with headers -instance DefaultOrdered LmsUserlistTableCsv where - headerOrder = const $ Csv.header [ csvLmsIdent, csvLmsBlocked ] - -instance ToNamedRecord LmsUserlistTableCsv where - toNamedRecord LmsUserlistTableCsv{..} = Csv.namedRecord - [ csvLmsIdent Csv..= csvLULident - , csvLmsBlocked Csv..= csvLULfailed - ] -instance FromNamedRecord LmsUserlistTableCsv where - parseNamedRecord (lsfHeaderTranslate -> csv) - = LmsUserlistTableCsv - <$> csv Csv..: csvLmsIdent - <*> csv Csv..: csvLmsBlocked - -instance CsvColumnsExplained LmsUserlistTableCsv where - csvColumnsExplanations _ = mconcat - [ single csvLmsIdent MsgCsvColumnLmsIdent - , single csvLmsBlocked MsgCsvColumnLmsLock - ] - where - single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget - single k v = singletonMap k [whamlet|_{v}|] - - -data LmsUserlistCsvActionClass = LmsUserlistInsert | LmsUserlistUpdate - deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded) -embedRenderMessage ''UniWorX ''LmsUserlistCsvActionClass id - -data LmsUserlistCsvAction = LmsUserlistInsertData { lmsUserlistInsertIdent :: LmsIdent, lmsUserlistInsertFailed :: Bool } - | LmsUserlistUpdateData { lmsUserlistInsertIdent :: LmsIdent, lmsUserlistInsertFailed :: Bool } - deriving (Eq, Ord, Read, Show, Generic) - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece'' 2 1 -- LmsUserlistInsertData -> insert - , fieldLabelModifier = camelToPathPiece' 2 -- lmsUserlistInsertIdent -> insert-ident | lmsUserlistInsertFailed -> insert-failed - , sumEncoding = TaggedObject "action" "data" - } ''LmsUserlistCsvAction - - -data LmsUserlistCsvException - = LmsUserlistCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?! - deriving (Show, Generic) - -instance Exception LmsUserlistCsvException -embedRenderMessage ''UniWorX ''LmsUserlistCsvException id - -mkUserlistTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) -mkUserlistTable sid qsh qid = do - dbtCsvName <- csvFilenameLmsUserlist qsh - let dbtCsvSheetName = dbtCsvName - let - userlistTable = DBTable{..} - where - dbtSQLQuery lmslist = do - E.where_ $ lmslist E.^. LmsUserlistQualification E.==. E.val qid - return lmslist - dbtRowKey = (E.^. LmsUserlistId) - dbtProj = dbtProjId - dbtColonnade = dbColonnade $ mconcat - [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell $ lmsUserlistIdent & getLmsIdent - , sortable (Just csvLmsBlocked) (i18nCell MsgTableLmsLock) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> ifIconCell lmsUserlistFailed IconBlocked - , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> dateTimeCell lmsUserlistTimestamp - ] - dbtSorting = Map.fromList - [ (csvLmsIdent , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistIdent) - , (csvLmsBlocked , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistFailed) - , (csvLmsTimestamp, SortColumn $ \lmslist -> lmslist E.^. LmsUserlistTimestamp) - ] - dbtFilter = Map.fromList - [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent )) - , (csvLmsBlocked, FilterColumn $ E.mkExactFilter (E.^. LmsUserlistFailed)) - ] - dbtFilterUI = \mPrev -> mconcat - [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) - , prismAForm (singletonFilter csvLmsBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsLock) - ] - dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - dbtParams = def - dbtIdent :: Text - dbtIdent = "lms-userlist" - dbtCsvEncode = simpleCsvEncode dbtCsvName dbtCsvSheetName doEncode' <&> addExample - where - addExample dce = dce{ dbtCsvExampleData = csvExample } - csvExample = Just - [ LmsUserlistTableCsv{csvLULident = LmsIdent lid, csvLULfailed = LmsBool ufl} - | (lid,ufl) <- zip ["abcdefgh", "12345678", "ident8ch"] [False,True,False] - ] - doEncode' = LmsUserlistTableCsv - <$> view (_dbrOutput . _entityVal . _lmsUserlistIdent) - <*> view (_dbrOutput . _entityVal . _lmsUserlistFailed . _lmsBool) - dbtCsvDecode = Just DBTCsvDecode {..} - where - dbtCsvRowKey = \LmsUserlistTableCsv{csvLULident} -> - fmap E.Value . MaybeT . getKeyBy $ UniqueLmsUserlist qid csvLULident - dbtCsvComputeActions = \case -- shows a diff first - DBCsvDiffNew{dbCsvNew} -> do - yield $ LmsUserlistInsertData - { lmsUserlistInsertIdent = csvLULident dbCsvNew - , lmsUserlistInsertFailed = lms2bool $ csvLULfailed dbCsvNew - } - DBCsvDiffExisting{dbCsvNew = LmsUserlistTableCsv{..}, dbCsvOld} -> do - let failedBool = lms2bool csvLULfailed - when (failedBool /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsUserlistFailed) $ - yield $ LmsUserlistUpdateData - { lmsUserlistInsertIdent = csvLULident - , lmsUserlistInsertFailed = csvLULfailed & lms2bool - } - DBCsvDiffMissing{} -> return () -- no deletion - dbtCsvClassifyAction = \case - LmsUserlistInsertData{} -> LmsUserlistInsert - LmsUserlistUpdateData{} -> LmsUserlistUpdate - dbtCsvCoarsenActionClass = \case - LmsUserlistInsert -> DBCsvActionNew - LmsUserlistUpdate -> DBCsvActionExisting - dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error - dbtCsvExecuteActions = do - C.mapM_ $ \actionData -> do - now <- liftIO getCurrentTime - void $ upsert LmsUserlist - { - lmsUserlistQualification = qid - , lmsUserlistIdent = lmsUserlistInsertIdent actionData - , lmsUserlistFailed = lmsUserlistInsertFailed actionData - , lmsUserlistTimestamp = now - } - [ - LmsUserlistFailed =. lmsUserlistInsertFailed actionData -- TODO: should we allow a reset from failed: True to False? - , LmsUserlistTimestamp =. now - ] - -- audit - lift . queueDBJob $ JobLmsUserlist qid - return $ LmsUserlistR sid qsh - dbtCsvRenderKey = const $ \case - LmsUserlistInsertData{..} -> do -- TODO: i18n - [whamlet| - $newline never - Insert: Course for Ident #{getLmsIdent lmsUserlistInsertIdent} # - $if lmsUserlistInsertFailed - is closed due to failure. - $else - is open. - |] - LmsUserlistUpdateData{..} -> do -- TODO: i18n - [whamlet| - $newline never - Update: Course for Ident #{getLmsIdent lmsUserlistInsertIdent} # - $if lmsUserlistInsertFailed - is now closed due to failure. - $else - is still open. - |] - dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure - dbtCsvRenderException = ap getMessageRender . pure :: LmsUserlistCsvException -> DB Text - dbtExtraReps = [] - - userlistDBTableValidator = def - & defaultSorting [SortAscBy csvLmsIdent] - - dbTable userlistDBTableValidator userlistTable - - -getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsUserlistR = postLmsUserlistR -postLmsUserlistR sid qsh = do - lmsTable <- runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - view _2 <$> mkUserlistTable sid qsh qid - siteLayoutMsg MsgMenuLmsUserlist $ do - setTitleI MsgMenuLmsUserlist - lmsTable - - --- Direct File Upload/Download --- saveUserlistCsv :: (PersistUniqueWrite backend, MonadIO m, BaseBackend backend ~ SqlBackend, Enum b) => --- Key Qualification -> b -> LmsUserlistTableCsv -> ReaderT backend m b -saveUserlistCsv :: QualificationId -> Int -> LmsUserlistTableCsv -> DB Int -saveUserlistCsv qid i LmsUserlistTableCsv{..} = do - now <- liftIO getCurrentTime - void $ upsert - LmsUserlist - { lmsUserlistQualification = qid - , lmsUserlistIdent = csvLULident - , lmsUserlistFailed = csvLULfailed & lms2bool - , lmsUserlistTimestamp = now - } - [ LmsUserlistFailed =. (csvLULfailed & lms2bool) - , LmsUserlistTimestamp =. now - ] - return $ succ i - -makeUserlistUploadForm :: Form FileInfo -makeUserlistUploadForm = renderAForm FormStandard $ fileAFormReq "Userlist CSV" - -getLmsUserlistUploadR, postLmsUserlistUploadR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsUserlistUploadR = postLmsUserlistUploadR -postLmsUserlistUploadR sid qsh = do - ((result,widget), enctype) <- runFormPost makeUserlistUploadForm - case result of - FormSuccess file -> do - nr <- runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - nr <- runConduit $ fileSource file .| decodeCsv .| foldMC (saveUserlistCsv qid) 0 - queueJob' $ JobLmsUserlist qid - return nr - addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") - redirect $ LmsUserlistR sid qsh - FormFailure errs -> do - forM_ errs $ addMessage Error . toHtml - redirect $ LmsUserlistUploadR sid qsh - FormMissing -> - siteLayoutMsg MsgMenuLmsUserlist $ do - setTitleI MsgMenuLmsUpload - [whamlet|$newline never - - ^{widget} -

                    - - |] - - -postLmsUserlistDirectR :: SchoolId -> QualificationShorthand -> Handler Html -postLmsUserlistDirectR sid qsh = do - (_params, files) <- runRequestBody - (status, msg) <- case files of - [(fhead,file)] -> do - lmsDecoder <- getLmsCsvDecoder - runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - enr <- try $ runConduit $ fileSource file - .| lmsDecoder - .| foldMC (saveUserlistCsv qid) 0 - case enr of - Left (e :: SomeException) -> do - $logWarnS "LMS" $ "Userlist upload failed parsing: " <> tshow e - return (badRequest400, "Exception: " <> tshow e) - Right nr -> do - let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". " - $logInfoS "LMS" msg - when (nr > 0) $ queueJob' $ JobLmsUserlist qid - return (ok200, msg) - [] -> do - let msg = "Userlist upload file missing." - $logWarnS "LMS" msg - return (badRequest400, msg) - _other -> do - let msg = "Userlist upload received multiple files; all ignored." - $logWarnS "LMS" msg - return (badRequest400, msg) - sendResponseStatus status msg diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index eb619276b..e6f35e8e9 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -19,8 +19,6 @@ module Handler.Utils.LMS , csvLmsLock , csvLmsResult , csvFilenameLmsUser - , csvFilenameLmsUserlist - , csvFilenameLmsResult , csvFilenameLmsReport , lmsDeletionDate , lmsUserToDelete , _lmsUserToDelete , lmsUserToDeleteExpr @@ -109,14 +107,6 @@ csvLmsResult = fromString "result" -- LmsStatus: 0=Versuche aufgebraucht, 1=Offe csvFilenameLmsUser :: MonadHandler m => QualificationShorthand -> m Text csvFilenameLmsUser = makeLmsFilename "user" --- | Filename for Userlist transmission, contains current datestamp as agreed in LMS interface V2 -csvFilenameLmsUserlist :: MonadHandler m => QualificationShorthand -> m Text -csvFilenameLmsUserlist = makeLmsFilename "userliste" - --- | Filename for Result transmission, contains current datestamp as agreed in LMS interface V1 -csvFilenameLmsResult :: MonadHandler m => QualificationShorthand -> m Text -csvFilenameLmsResult = makeLmsFilename "ergebnisse" - -- | Filename for Report transmission, combining former Userlist and Result as agreed in new LMS interface V2 csvFilenameLmsReport :: MonadHandler m => QualificationShorthand -> m Text csvFilenameLmsReport = makeLmsFilename "report" diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 1785924b4..5ab7745ae 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -10,8 +10,6 @@ module Jobs.Handler.LMS , dispatchJobLmsEnqueue, dispatchJobLmsEnqueueUser , dispatchJobLmsDequeue , dispatchJobLmsReports - , dispatchJobLmsResults - , dispatchJobLmsUserlist ) where import Import @@ -28,7 +26,7 @@ import qualified Database.Esqueleto.Utils as E import qualified Data.Set as Set -- import qualified Data.Map as Map -import qualified Data.Time.Zones as TZ +-- import qualified Data.Time.Zones as TZ import Handler.Utils.DateTime import Handler.Utils.LMS (randomLMSIdentBut, randomLMSpw, maxLmsUserIdentRetries) import Handler.Utils.Qualification @@ -134,10 +132,6 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act ( (E.^. LmsUserIdent) <$> E.from (E.table @LmsUser ) ) -- no filter by Qid, since LmsIdents must be unique across all `E.union_` ( (E.^. LmsReportIdent) <$> E.from (E.table @LmsReport ) ) -- V2 - `E.union_` - ( (E.^. LmsResultIdent) <$> E.from (E.table @LmsResult ) ) -- V1 DEPRECATED - `E.union_` - ( (E.^. LmsUserlistIdent) <$> E.from (E.table @LmsUserlist) ) -- V1 DEPRECATED E.orderBy [E.asc lui] pure lui now <- liftIO getCurrentTime @@ -261,8 +255,6 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act when (numdel > 0) $ do $logInfoS "LMS" $ "Deleting " <> tshow numdel <> " LmsIdents due to audit duration expiry for qualification " <> qshort deleteWhere [LmsUserQualification ==. qid, LmsUserIdent <-. delusers] - deleteWhere [LmsUserlistQualification ==. qid, LmsUserlistIdent <-. delusers] - deleteWhere [LmsResultQualification ==. qid, LmsResultIdent <-. delusers] -- deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers] deleteWhere [LmsReportLogQualification ==. qid, LmsReportLogTimestamp <. auditCutoff ] @@ -433,120 +425,3 @@ dispatchJobLmsReports qid = JobHandlerAtomic act E.<&> E.true) repProc <- deleteWhereCount [LmsReportQualification ==. qid] $logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|] - - --- DEPRECATED processes received results and lengthen qualifications, if applicable -dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX -dispatchJobLmsResults qid = JobHandlerAtomic act - where - -- act :: YesodJobDB UniWorX () - act = hoist lift $ do - results <- E.select $ do - (quser :& luser :& lresult) <- E.from $ - E.table @QualificationUser -- table not needed if renewal from lms completion day is used TODO: decide! - `E.innerJoin` E.table @LmsUser - `E.on` (\(quser :& luser) -> - luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser - E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification) - `E.innerJoin` E.table @LmsResult - `E.on` (\(_ :& luser :& lresult) -> - luser E.^. LmsUserIdent E.==. lresult E.^. LmsResultIdent - E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification) - E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid - E.&&. luser E.^. LmsUserQualification E.==. E.val qid - -- E.&&. E.isNothing (luser E.^. LmsUserStatus) -- do not process learners already having a result WORKAROUND LMS-Bug: LMS may send blocked & success simultanesouly or within a few hours; in this case, success is the correct meaning - E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners - return (quser, luser, lresult) - now <- liftIO getCurrentTime - let locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now - forM_ results $ \(Entity _quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do - -- three separate DB operations per result is not so nice. All within one transaction though. - let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted - saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay) - -- && qualificationUserLastRefresh <= utctDay lmsUserStarted NOTE: not always true due to manual intervention; also renewValidQualificationUsers prevents double renewals anyway - -- newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards - note <- if saneDate && (lmsUserStatus /= Just LmsSuccess) - then do - -- WORKAROUND LMS-Bug [supposedly fixed now, but isnt]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning - let reason_undo = Left $ "LMS Workaround undoing: " <> tshow (QualificationBlockFailedELearningBy lmsUserIdent) - ok_unblock <- qualificationUserUnblockByReason qid [qualificationUserUser] Nothing (Right $ QualificationBlockFailedELearningBy lmsUserIdent) reason_undo False -- affects audit log - when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid}|]) - - _ok_renew <- renewValidQualificationUsers qid (Just $ Right $ QualificationRenewELearningBy lmsUserIdent) Nothing [qualificationUserUser] -- only unblocked are renewed - -- when (ok==1) $ update luid -- we end lms regardless of whether or not a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings - - update luid - [ LmsUserStatus =. Just LmsSuccess - , LmsUserStatusDay =. Just (utctDayMidnight lmsResultSuccess) - , LmsUserReceived =. Just lmsResultTimestamp - ] - return Nothing - else do - let errmsg = [st|LMS Result: success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent} for #{tshow qid}|] - $logErrorS "LMS" errmsg - return $ Just errmsg - - audit TransactionLmsSuccess -- always log success, since this is only transmitted once - { transactionQualification = qid - , transactionLmsIdent = lmsUserIdent - , transactionLmsDay = utctDayMidnight lmsResultSuccess - , transactionLmsUser = lmsUserUser - , transactionNote = note - , transactionReceived = lmsResultTimestamp - } - delete lrid - $logInfoS "LMS" [st|Processed #{tshow (length results)} LMS results|] - - --- DEPRECATED processes received input and block qualifications, if applicable -dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX -dispatchJobLmsUserlist qid = JobHandlerAtomic act - where - act :: YesodJobDB UniWorX () - act = whenM (exists [LmsUserlistQualification ==. qid]) $ do -- safeguard against multiple calls, which would close all learners due to first case below - now <- liftIO getCurrentTime - -- result :: [(Entity LmsUser, Entity LmsUserlist)] - results <- E.select $ do - (luser :& lulist) <- E.from $ - E.table @LmsUser `E.leftJoin` E.table @LmsUserlist - `E.on` (\(luser :& lulist) -> luser E.^. LmsUserIdent E.=?. lulist E.?. LmsUserlistIdent - E.&&. luser E.^. LmsUserQualification E.=?. lulist E.?. LmsUserlistQualification) - E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid - E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners - return (luser, lulist) - forM_ results $ \case - (Entity luid luser, Nothing) - | isJust $ lmsUserReceived luser -- mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected) - , isNothing $ lmsUserEnded luser -> - update luid [LmsUserEnded =. Just now] - | otherwise -> return () -- users likely not yet started - - (Entity luid luser, Just (Entity _lulid lulist)) -> do - let lReceived = lmsUserlistTimestamp lulist - update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications - - when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available - queueDBJob JobUserNotification - { jRecipient = lmsUserUser luser - , jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } - } - - let isBlocked = lmsUserlistFailed lulist - oldStatus = lmsUserStatus luser - updateStatus = isBlocked && oldStatus /= Just LmsSuccess - when updateStatus $ do - update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. Just lReceived] - ok <- qualificationUserBlocking qid [lmsUserUser luser] False Nothing (Right QualificationBlockFailedELearning) True - when (ok /= 1) $ do - uuid :: CryptoUUIDUser <- encrypt $ lmsUserUser luser - $logWarnS "LmsUserlist" [st|Blocking by failed E-learning failed for learner #{tshow uuid} and qualification #{tshow qid}] - audit TransactionLmsBlocked - { transactionQualification = qid - , transactionLmsIdent = lmsUserIdent luser - , transactionLmsDay = lReceived - , transactionLmsUser = lmsUserUser luser - , transactionNote = Just $ "Old status was " <> tshow oldStatus - , transactionReceived = lReceived - } - delete lulid - $logInfoS "LMS" [st|Processed LMS Userlist with #{tshow (length results)} entries|] diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 78b4fe50b..dc8e04120 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -135,8 +135,6 @@ data Job | JobLmsEnqueueUser { jQualification :: QualificationId, jUser :: UserId } | JobLmsQualificationsDequeue | JobLmsDequeue { jQualification :: QualificationId } - | JobLmsUserlist { jQualification :: QualificationId } -- Deprecated, remove together with routes - | JobLmsResults { jQualification :: QualificationId } -- Deprecated, remove together with routes | JobLmsReports { jQualification :: QualificationId } | JobPrintAck | JobPrintAckAgain @@ -368,9 +366,7 @@ jobNoQueueSame = \case JobLmsEnqueue {} -> Just JobNoQueueSame JobLmsEnqueueUser {} -> Just JobNoQueueSame JobLmsQualificationsDequeue -> Just JobNoQueueSame - JobLmsDequeue {} -> Just JobNoQueueSame - JobLmsUserlist {} -> Just JobNoQueueSame - JobLmsResults {} -> Just JobNoQueueSame + JobLmsDequeue {} -> Just JobNoQueueSame JobLmsReports {} -> Just JobNoQueueSame JobPrintAck {} -> Just JobNoQueueSame JobPrintAckAgain {} -> Just JobNoQueueSame diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 861d98fd4..5c83e1e35 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -125,8 +125,6 @@ makeClassyFor_ ''QualificationUser makeClassyFor_ ''QualificationUserBlock makeClassyFor_ ''LmsUser -- makeClassyFor_ ''LmsUserStatus -makeClassyFor_ ''LmsUserlist -makeClassyFor_ ''LmsResult makeClassyFor_ ''LmsReport makeClassyFor_ ''UserAvs makeClassyFor_ ''UserAvsCard diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 9e1b9cea6..19f424fc8 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -739,12 +739,6 @@ fillDb = do insertMany_ [QualificationUser uid qid_f (n_day (fromIntegral (length udn) - 12)) (n_day $ -42) (n_day $ -365) True (n_day' $ -11) | Entity uid User{userDisplayName=udn} <- take 200 $ drop 2 matUsers, uid `Set.notMember` qidfUsers] insertMany_ [LmsUser qid_f uid (LmsIdent udn) "123456" False now astatus astatusDay now (Just now) (Just now) Nothing False False | Entity uid User{userDisplayName=udn} <- take 200 $ drop 22 matUsers, uid `Set.notMember` qidfUsers , let selsome = odd $ length udn, let astatus = bool Nothing (Just LmsBlocked) selsome, let astatusDay = bool Nothing (Just now) selsome] - void . insert' $ LmsResult qid_f (LmsIdent "hijklm" ) (n_day (-1)) now - void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (n_day (-2)) now - void . insert' $ LmsResult qid_f (LmsIdent "pqgrst" ) (n_day (-3)) now - void . insert' $ LmsUserlist qid_f (LmsIdent "hijklm") False now - void . insert' $ LmsUserlist qid_f (LmsIdent "abcdef") True now - void . insert' $ LmsUserlist qid_f (LmsIdent "ijk" ) False now void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing Nothing now Nothing (Just $ n_day' (-7)) (Just $ n_day' (-5)) False False void . insert' $ LmsUser qid_f svaupel (LmsIdent "bcdefg") "abc" False now (Just LmsSuccess) (Just $ n_day' 1) (n_day' (-1)) (Just now) (Just $ n_day' 0) Nothing True False void . insert' $ LmsUser qid_f gkleen (LmsIdent "hiklmn") "@#!" True now (Just LmsBlocked) (Just $ now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing False True From 50eda5f65f7394fe519546609fe748490cb4dd72 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 1 Dec 2023 18:36:21 +0100 Subject: [PATCH 054/110] fix(build): redundant parenthesis --- src/Handler/Firm.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index f86048434..370e30467 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -1040,7 +1040,7 @@ mkFirmSuperTable isAdmin cid = do [ guardMonoid isAdmin $ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData , singletonMap FirmSuperActSwitchSuper $ FirmSuperActSwitchSuperData <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultSupervisor) (Just $ Just True) - <*> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultReroute) (Nothing) + <*> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultReroute) Nothing <* aformMessage msgSupervisorUnchanged , singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData <$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True) From 527a270cbf77ce6f45ab014e3f61d81249b98578 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 1 Dec 2023 21:26:09 +0000 Subject: [PATCH 055/110] chore(release): 27.4.52 --- CHANGELOG.md | 9 +++++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 13 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 54de9bc9a..cce1e6cff 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,15 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [27.4.52](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.51...v27.4.52) (2023-12-01) + + +### Bug Fixes + +* **build:** redundant parenthesis ([50eda5f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/50eda5f65f7394fe519546609fe748490cb4dd72)) +* **firm:** restrict firm access to company supervisors only ([0a06efd](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0a06efd76c63180c996657c2c7d78efc5bddd83d)) +* **firm:** supervisor changes led to inconsistent DB ([1d3345c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1d3345cbba1cb65ee49c6f62e145750545439642)) + ## [27.4.51](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.50...v27.4.51) (2023-11-24) diff --git a/nix/docker/version.json b/nix/docker/version.json index ac2140316..07d466528 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.51" + "version": "27.4.52" } diff --git a/package-lock.json b/package-lock.json index 8c57be9a2..8aae86886 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.51", + "version": "27.4.52", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 31aa2b12d..e7e8a6e47 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.51", + "version": "27.4.52", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 5856789ac..c6e1a8bcb 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.51 +version: 27.4.52 dependencies: - base - yesod From a15862ea72bc374af870ef3a23f86ae32c2c67a9 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 4 Dec 2023 16:03:31 +0100 Subject: [PATCH 056/110] fix(print): keep print jobs on user merge and lms id deletion --- models/print.model | 4 ++-- src/Handler/Utils/Users.hs | 4 ++++ 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/models/print.model b/models/print.model index ee3f1ea7c..ee22cf922 100644 --- a/models/print.model +++ b/models/print.model @@ -9,11 +9,11 @@ PrintJob file ByteString -- stores plain pdf; otherwise use FileContentReference Maybe created UTCTime acknowledged UTCTime Maybe - recipient UserId Maybe OnDeleteCascade OnUpdateCascade -- optional as some letters may contain just an address + recipient UserId Maybe OnDeleteSetNull OnUpdateCascade -- optional as some letters may contain just an address sender UserId Maybe OnDeleteSetNull OnUpdateCascade -- senders and associations are optional course CourseId Maybe OnDeleteCascade OnUpdateCascade qualification QualificationId Maybe OnDeleteCascade OnUpdateCascade - lmsUser LmsIdent Maybe OnDeleteCascade OnUpdateCascade -- allows tracking if recipient has been notified; must be unique + lmsUser LmsIdent Maybe OnDeleteSetNull OnUpdateCascade -- allows tracking if recipient has been notified; must be unique -- UniquePrintJobLmsUser lmsUser -- Note that in fact multiple print jobs per LMS user are possible! -- UniquePrintJobApcIdent apcIdent -- TODO: not yet enforced, since LmsIdent is currently used deriving Generic diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 1e4a28487..5c85c9c73 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -847,6 +847,10 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do delete oldQKey -- deleteWhere [ QualificationUserUser ==. oldUserId ] -- no longer needed + -- PrintJobs + updateWhere [ PrintJobRecipient ==. Just oldUserId ] [ PrintJobRecipient =. Just newUserId ] + updateWhere [ PrintJobSender ==. Just oldUserId ] [ PrintJobSender =. Just newUserId ] + -- Supervision is fully merged E.insertSelectWithConflict UniqueUserSupervisor From 3acb847915010d10358ea02000c231dbba7cba26 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 5 Dec 2023 11:52:13 +0100 Subject: [PATCH 057/110] fix(firm): supervisor filter --- src/Handler/Firm.hs | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 370e30467..194eea1dc 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -507,7 +507,7 @@ mkFirmAllTable isAdmin uid = do dbtFilter = mconcat [ single $ fltrCompanyNameNr queryAllCompany , single ("company-number", FilterColumn $ E.mkExactFilterWithComma readMay (queryAllCompany >>> (E.^. CompanyAvsId))) - , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do + , single ("is-associate" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do (usr :& usrCmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser) @@ -517,6 +517,25 @@ mkFirmAllTable isAdmin uid = do E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) ) ) + , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do + (usr :& usrCmp) <- E.from $ E.table @User + `E.leftJoin` E.table @UserCompany + `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser) + E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion) + E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) + E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) + ) E.&&. ((E.isTrue (usrCmp E.?. UserCompanySupervisor) E.&&. usrCmp E.? . UserCompanyCompany E.?=. queryAllCompany row E.^. CompanyId) + E.||. E.exists (do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + E.&& E.exists (do + usrSub <- E.from $ E.table @UserCompany + E.where_ $ usrSub E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser + E.&&. usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + ) + ) + ) + ) , single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> -- let checkSuper = do -- expensive -- usrSpr <- E.from $ E.table @UserSupervisor @@ -552,6 +571,7 @@ mkFirmAllTable isAdmin uid = do [ fltrCompanyNameUI mPrev , prismAForm (singletonFilter "company-number") mPrev $ aopt textField (fslI MsgTableCompanyNo) , prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) + , prismAForm (singletonFilter "is-associate") mPrev $ aopt textField (fslI MsgTableCompanyUser) , prismAForm (singletonFilter "foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterForeignSupervisor) , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern) ] From 9878956716b04c7ae88989cb9b059d3edcb923dc Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 5 Dec 2023 12:12:51 +0100 Subject: [PATCH 058/110] fix(firm): set supervisor field not all fields required --- src/Handler/Firm.hs | 22 +++++++++++----------- src/Utils.hs | 1 + 2 files changed, 12 insertions(+), 11 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 194eea1dc..c6d77abc1 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -520,15 +520,15 @@ mkFirmAllTable isAdmin uid = do , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do (usr :& usrCmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany - `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser) + `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser) E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion) E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) - ) E.&&. ((E.isTrue (usrCmp E.?. UserCompanySupervisor) E.&&. usrCmp E.? . UserCompanyCompany E.?=. queryAllCompany row E.^. CompanyId) + ) E.&&. ((E.isTrue (usrCmp E.?. UserCompanySupervisor) E.&&. usrCmp E.?. UserCompanyCompany E.?=. queryAllCompany row E.^. CompanyId) E.||. E.exists (do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId - E.&& E.exists (do + E.&&. E.exists (do usrSub <- E.from $ E.table @UserCompany E.where_ $ usrSub E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser E.&&. usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId @@ -638,8 +638,8 @@ data FirmUserActionData = FirmUserActNotifyData -- , firmUserActResetMutualSupervision :: Maybe Bool } | FirmUserActSetSupervisorData - { firmUserActSetSuperNames :: Set Text - , firmUserActSetSuperIds :: [UserId] + { firmUserActSetSuperNames :: Maybe (Set Text) + , firmUserActSetSuperIds :: Maybe [UserId] , firmUserActSetSuperReroute :: Bool , firmUserActSetSuperKeep :: Bool } @@ -798,10 +798,10 @@ mkFirmUserTable isAdmin cid = do <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) , singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData - <$> apopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing - <*> apopt supervisorsField (fslI MsgFirmSetSupervisor) Nothing - <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False) - <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False) + <$> aopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <*> aopt supervisorsField (fslI MsgFirmSetSupervisor) Nothing + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False) + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False) , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData @@ -887,10 +887,10 @@ postFirmUsersR fsh = do addMessageI Info $ MsgFirmResetSupervision delSupers newSupers reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes (FirmUserActSetSupervisorData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do - avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmUserActSetSuperNames + avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser $ maybeMonoid firmUserActSetSuperNames let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers usersFound = mapMaybe snd usersFound' - newSupers = Set.toList $ Set.fromList firmUserActSetSuperIds <> Set.fromList usersFound + newSupers = Set.toList $ Set.fromList (maybeMonoid firmUserActSetSuperIds) <> Set.fromList usersFound nrSupers = fromIntegral $ length newSupers nrUsers = fromIntegral $ length uids unless (null usersNotFound) $ diff --git a/src/Utils.hs b/src/Utils.hs index a2b35c37a..2093da8b2 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -626,6 +626,7 @@ guardMonoid True x = x assertMonoid :: Monoid m => (m -> Bool) -> m -> m assertMonoid f x = guardMonoid (f x) x +-- fold would also do, but is more risky if the Folable isn't Maybe maybeMonoid :: Monoid m => Maybe m -> m -- ^ Identify `Nothing` with `mempty` maybeMonoid = fromMaybe mempty From fc0ca7b854a686cf395dadf81b7423e530fd26b8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 5 Dec 2023 18:39:59 +0100 Subject: [PATCH 059/110] fix(firm): group multi select field supervisor However, grouped multi select does not work for some reason. --- .../uniworx/categories/firm/de-de-formal.msg | 3 ++ messages/uniworx/categories/firm/en-eu.msg | 3 ++ messages/uniworx/misc/de-de-formal.msg | 2 +- messages/uniworx/misc/en-eu.msg | 2 +- src/Handler/Firm.hs | 38 ++++++++++++------- 5 files changed, 33 insertions(+), 15 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index f938dbaa9..c7a92efb3 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -2,6 +2,9 @@ # # SPDX-License-Identifier: AGPL-3.0-or-later +FirmSuperDefault: Standardansprechpartner +FirmSuperForeign: Firmenfremde Ansprechpartner +FirmSuperIrregular: Irreguläre Ansprechpartner FirmAssociates: Firmenangehörige FirmContact: Firmenkontakt FirmNoContact: Keine allgemeinen Kontaktinformationen bekannt. diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 747900397..043312a20 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -2,6 +2,9 @@ # # SPDX-License-Identifier: AGPL-3.0-or-later +FirmSuperDefault: Default supervisor +FirmSuperForeign: External supervisor +FirmSuperIrregular: Irregular supervisor FirmAssociates: Company associated users FirmContact: Company Contact FirmNoContact: No general contact information known. diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index eaa02c0fa..3fcd6ffe6 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -10,7 +10,7 @@ BoolIrrelevant !ident-ok: — FieldPrimary: Hauptfach FieldSecondary: Nebenfach MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Adressen möglich -MultiSelectTip: Mehrfachauswahl mit Strg-Klick +MultiSelectTip: Mehrfachauswahl und Abwählen mit Strg-Klick WeekDay: Wochentag LdapIdentificationOrEmail: Fraport AG-Kennung / E-Mail-Adresse Months num@Int64: #{num} #{pluralDE num "Monat" "Monate"} diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index 5b6b15f5b..ed8bda4db 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -10,7 +10,7 @@ BoolIrrelevant: — FieldPrimary: Major FieldSecondary: Minor MultiEmailFieldTip: Multiple emails addresses may be specified (comma-separated) -MultiSelectTip: Multiple selection via Ctrl-Click +MultiSelectTip: Multiple selection and desection via Ctrl-Click WeekDay: Day of the week LdapIdentificationOrEmail: Fraport AG-Kennung / email address Months num: #{num} #{pluralEN num "Month" "Months"} diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index c6d77abc1..fabb20538 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -380,14 +380,14 @@ firmCountForeignSupervisors cmpy = E.subSelectCountDistinct $ do -- firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -- firmCountActiveReroutes cmpy = E.subSelectCountDistinct $ do -- usrSuper <- E.from $ E.table @UserSupervisor --- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) +-- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) -- E.&&. usrSuper E.^. UserSupervisorRerouteNotifications -- pure $ usrSuper E.^. UserSupervisorSupervisor firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) firmCountActiveReroutes cmpy = E.subSelectCount $ do usrSuper <- E.from $ E.table @UserSupervisor - E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) + E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) E.&&. usrSuper E.^. UserSupervisorRerouteNotifications firmQuerySupervisedBy :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlQuery () @@ -682,20 +682,32 @@ instance HasUser UserCompanyTableData where mkFirmUserTable :: Bool -> CompanyId -> DB (FormResult (FirmUserActionData, Set UserId), Widget) mkFirmUserTable isAdmin cid = do + mr <- getMessageRender let - mkSprOption (E.Value uid, E.Value udn) = do + mkSprOption (E.Value uid, E.Value udn, E.Value mbSpr) = do uuid <- toPathPiece <$> encryptUser uid - return Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid } - procOptions = fmap mkOptionList . traverse mkSprOption + return (Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid }, mbSpr) + + procOptions rawSupers = do + procSupers <- traverse mkSprOption rawSupers + return $ mkOptionListGrouped $ filter (notNull . snd) + [ (mr MsgFirmSuperDefault , [opt | (opt, Just True ) <- procSupers]) + , (mr MsgFirmSuperIrregular, [opt | (opt, Just False) <- procSupers]) + , (mr MsgFirmSuperForeign , [opt | (opt, Nothing ) <- procSupers]) + ] rawSupers <- E.select $ do - usr <- E.from $ E.table @User - E.where_ $ E.exists $ firmQuerySupervisedBy cid Nothing usr - return (usr E.^. UserId, usr E.^. UserDisplayName) + (usr :& usrCmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany + `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.==. E.justVal cid) + E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor) + E.||. E.exists (firmQuerySupervisedBy cid Nothing usr) + return (usr E.^. UserId, usr E.^. UserDisplayName, usrCmp E.?. UserCompanySupervisor) let -- supervisorField :: Field Handler UserId - -- supervisorField = selectField $ procOptions rawSupers - supervisorsField = multiSelectField $ procOptions rawSupers + supervisorField = selectField $ procOptions rawSupers + -- TODO: Markieren Alien/Standard/Irregulär + -- supervisorsField = multiSelectField $ procOptions rawSupers + -- supervisorsField = convertField pure head supervisorField fsh = unCompanyKey cid resultDBTable = DBTable{..} @@ -784,8 +796,8 @@ mkFirmUserTable isAdmin cid = do -- superField = selectField $ ???? dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev - -- , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) - , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor & setTooltip MsgMultiSelectTip ) + , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) + -- , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor & setTooltip MsgMultiSelectTip ) , prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor) , prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh) , prismAForm (singletonFilter "has-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorForeign fsh) @@ -799,7 +811,7 @@ mkFirmUserTable isAdmin cid = do -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) , singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData <$> aopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing - <*> aopt supervisorsField (fslI MsgFirmSetSupervisor) Nothing + <*> fmap (fmap pure) (aopt supervisorField (fslI MsgFirmSetSupervisor) Nothing) <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False) <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False) , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData From 3aa89019a8b4393da0eca715871a3793c1e3abb2 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 6 Dec 2023 11:50:08 +0100 Subject: [PATCH 060/110] fix(form): multiSelectField working with grouped options --- messages/uniworx/utils/utils/de-de-formal.msg | 1 + messages/uniworx/utils/utils/en-eu.msg | 1 + src/Handler/Firm.hs | 21 ++++---- src/Utils/Form.hs | 48 +++++++++++++++++++ 4 files changed, 60 insertions(+), 11 deletions(-) diff --git a/messages/uniworx/utils/utils/de-de-formal.msg b/messages/uniworx/utils/utils/de-de-formal.msg index 067b7ba11..5ff122fb1 100644 --- a/messages/uniworx/utils/utils/de-de-formal.msg +++ b/messages/uniworx/utils/utils/de-de-formal.msg @@ -98,6 +98,7 @@ RoomReferenceLinkInstructions: Anweisungen RoomReferenceLinkInstructionsPlaceholder: Anweisungen UtilEmptyChoice: Auswahl war leer UtilEmptyNoChangeTip: Eine leere Eingabe belässt den vorherigen Wert unverändert. +MultiNoSelection: Keine Auswahl #invitation.hs InvitationAction: Aktion diff --git a/messages/uniworx/utils/utils/en-eu.msg b/messages/uniworx/utils/utils/en-eu.msg index cafb5fac8..f65004cd1 100644 --- a/messages/uniworx/utils/utils/en-eu.msg +++ b/messages/uniworx/utils/utils/en-eu.msg @@ -98,6 +98,7 @@ RoomReferenceLinkInstructions: Instructions RoomReferenceLinkInstructionsPlaceholder: Instructions UtilEmptyChoice: Empty selection UtilEmptyNoChangeTip: Existing values remain unchanged if this field is left empty. +MultiNoSelection: No selection #invitation.hs InvitationAction: Action diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index fabb20538..53914269e 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -94,7 +94,7 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts) <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) mkAct _ FirmActAddSupersvisors = singletonMap FirmActAddSupersvisors $ FirmActAddSupersvisorsData <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing - <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) + <*> areq checkBoxField (fslI MsgTableIsDefaultReroute) (Just True) <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing mkAct _ FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing @@ -704,10 +704,9 @@ mkFirmUserTable isAdmin cid = do return (usr E.^. UserId, usr E.^. UserDisplayName, usrCmp E.?. UserCompanySupervisor) let -- supervisorField :: Field Handler UserId - supervisorField = selectField $ procOptions rawSupers - -- TODO: Markieren Alien/Standard/Irregulär - -- supervisorsField = multiSelectField $ procOptions rawSupers - -- supervisorsField = convertField pure head supervisorField + -- supervisorField = selectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers + supervisorsField = multiSelectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers + fsh = unCompanyKey cid resultDBTable = DBTable{..} @@ -796,8 +795,8 @@ mkFirmUserTable isAdmin cid = do -- superField = selectField $ ???? dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev - , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) - -- , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor & setTooltip MsgMultiSelectTip ) + -- , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) + , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor & setTooltip MsgMultiSelectTip) , prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor) , prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh) , prismAForm (singletonFilter "has-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorForeign fsh) @@ -810,10 +809,10 @@ mkFirmUserTable isAdmin cid = do <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) , singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData - <$> aopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing - <*> fmap (fmap pure) (aopt supervisorField (fslI MsgFirmSetSupervisor) Nothing) - <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False) - <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False) + <$> aopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <*> aopt supervisorsField (fslI MsgFirmSetSupervisor & setTooltip MsgMultiSelectTip) Nothing + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False) + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False) , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 39107331e..1a4bc3aa9 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -950,6 +950,54 @@ selectField' optMsg mkOpts = Field{..} #{optionDisplay opt} |] +multiSelectField' :: ( Eq a + , RenderMessage (HandlerSite m) FormMessage + , MonadHandler m + ) + => Maybe (SomeMessage (HandlerSite m)) -- ^ Caption used for @Nothing@-Option, if Field is optional and whether to show such an option + -> HandlerT (HandlerSite m) IO (OptionList a) + -> Field m [a] +-- ^ Like @multiSelectField@, but it can handle OptionListGrouped and also offers more control over the @Nothing@-Option, if Field is optional +multiSelectField' optMsg mkOpts = Field{..} + where + fieldEnctype = UrlEncoded + + fieldParse [] _ = return $ Right Nothing + fieldParse optlist _ = do + let optlist' = filter notNull optlist + readExternal <- view _olReadExternal <$> liftHandler mkOpts + return . maybe (Left . SomeMessage $ MsgInvalidEntry $ T.intercalate ", " optlist') (Right . Just) $ mapM readExternal optlist' + -- case mapM readExternal optlist' of + -- Nothing -> return $ Left $ SomeMessage $ MsgInvalidEntry $ T.intercalate ", " optlist' + -- res -> return $ Right res + + fieldView theId name attrs val isReq = do + opts <- liftHandler mkOpts + let + rendered = case val of + Left _ -> [] + Right xs -> [optionExternalValue o | o <- opts ^.. _olOptions, x <- xs, x == optionInternalValue o] + isSel Nothing = ClassyPrelude.Yesod.null rendered + isSel (Just opt) = optionExternalValue opt `elem` rendered + [whamlet| + $newline never + + |] + postPrintAckDirectR :: Handler Html postPrintAckDirectR = do now <- liftIO getCurrentTime (_params, files) <- runRequestBody (status, msg) <- case files of - [(_fhead,file)] -> do - runDBJobs $ do + [(_fhead,file)] -> do + runDBJobs $ do enr <- try $ runConduit $ fileSource file - -- .| decodeCsvPositional Csv.NoHeader -- decode by separator position + -- .| decodeCsvPositional Csv.NoHeader -- decode by separator position .| decodeUtf8C -- no CSV, just convert each line to a single text .| linesUnboundedC .| foldMC (saveApcident now) 0 @@ -462,7 +477,7 @@ postPrintAckDirectR = do let msg = "Success: received " <> tshow nr <> " APC identifiers to be processed later." $logInfoS "LMS" msg when (nr > 0) $ queueDBJob JobPrintAck - return (ok200, msg) + return (ok200, msg) [] -> do let msg = "Error: No file received. A file of lms identifiers must be supplied for print job acknowledging." $logWarnS "APC" msg @@ -476,7 +491,7 @@ postPrintAckDirectR = do getPrintLogR :: Handler Html getPrintLogR = do - let + let logDBTable = DBTable{..} where resultLog :: Lens' (DBRow (TransactionLog, Aeson.Result Transaction)) TransactionLog @@ -485,9 +500,9 @@ getPrintLogR = do resultTrans :: Lens' (DBRow (TransactionLog, Aeson.Result Transaction)) (Aeson.Result Transaction) resultTrans = _dbrOutput . _2 - tCell' err c dbr = case view resultTrans dbr of + tCell' err c dbr = case view resultTrans dbr of (Aeson.Error msg) -> err msg -- should not happen, due to query filter - (Aeson.Success t) -> c t + (Aeson.Success t) -> c t tCellErr = tCell' stringCell tCell = tCell' $ const mempty @@ -497,7 +512,7 @@ getPrintLogR = do -- E.&&. E.val "interface" E.==. l E.^. TransactionLogInfo E.->>. "transaction" -- not necessary return l dbtRowKey = (E.^. TransactionLogId) - dbtProj = dbtProjSimple $ \(Entity _ l) -> do + dbtProj = dbtProjSimple $ \(Entity _ l) -> do return (l, Aeson.fromJSON $ transactionLogInfo l) dbtColonnade = dbColonnade $ mconcat [ sortable (Just "time") (i18nCell MsgSystemMessageTimestamp) $ \(view $ resultLog . to transactionLogTime -> t) -> dateTimeCell t @@ -521,6 +536,6 @@ getPrintLogR = do dbtExtraReps = [] validator = def & defaultSorting [ SortDescBy "time" ] tbl <- runDB $ dbTableDB' validator logDBTable - siteLayoutMsg MsgMenuPrintLog $ do + siteLayoutMsg MsgMenuPrintLog $ do setTitleI MsgMenuPrintLog [whamlet|^{tbl}|] From bbb9f9fadb4136a92fa6727cb73ee02eb489f495 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Feb 2024 17:16:19 +0100 Subject: [PATCH 094/110] chore(health): telling interface table compiles --- .../uniworx/categories/admin/de-de-formal.msg | 6 +- messages/uniworx/categories/admin/en-eu.msg | 6 +- src/Handler/Health/Interface.hs | 89 +++++++++++++++++-- src/Handler/LMS/Report.hs | 3 +- src/Handler/Utils/DateTime.hs | 4 +- 5 files changed, 95 insertions(+), 13 deletions(-) diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index f4c23696d..ad521c490 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -121,6 +121,10 @@ ProblemsAvsSynchHeading: Synchronisation AVS Fahrberechtigungen ProblemsAvsErrorHeading: Fehlermeldungen ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit +InterfaceStatus !ident-ok: Status +InterfaceName: Schnittstelle InterfaceLastSynch: Zuletzt InterfaceSubtype: Betreffend -InterfaceWrite: Schreibend \ No newline at end of file +InterfaceWrite: Schreibend +InterfaceSuccess: Rückmeldung +InterfaceInfo: Nachricht \ No newline at end of file diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index c035f54c0..c73fd8910 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -121,6 +121,10 @@ ProblemsAvsSynchHeading: Synchronisation AVS Driving Licences ProblemsAvsErrorHeading: Error Log ProblemsInterfaceSince: Only considering successes and errors since +InterfaceStatus: Status +InterfaceName: Interface InterfaceLastSynch: Last InterfaceSubtype: Affecting -InterfaceWrite: Write \ No newline at end of file +InterfaceWrite: Write +InterfaceSuccess: Returned +InterfaceInfo: Message \ No newline at end of file diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index 6592b6f56..e623901f1 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -2,6 +2,9 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -- !!! TODO REMOVE ME + + module Handler.Health.Interface ( getHealthInterfaceR @@ -12,10 +15,12 @@ import Import -- import qualified Data.Set as Set import qualified Data.Text as Text +import Handler.Utils import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Utils as E +import qualified Database.Esqueleto.Legacy as EL (on) identifyInterfaces :: [Text] -> [Unique InterfaceHealth] @@ -34,35 +39,105 @@ wc2null o = Just o -- | sloppily parse a boolean, also see Model.Types.Avs.SloppyBool pbool :: Text -> Maybe Bool pbool (Text.toLower . Text.strip -> w) - | w `elem` ["1", "t", "true" ,"wahr", "w"] = Just True + | w `elem` ["1", "t", "true" ,"wahr", "w"] = Just True | w `elem` ["0", "f", "false","falsch"] = Just False | otherwise = Nothing +mkInterfaceLogTable :: [Unique InterfaceHealth] -> (Bool -> Widget) -> DB ([(Text,Bool)], Widget) +mkInterfaceLogTable interfs flagError = do + now <- liftIO getCurrentTime + dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..} + where + dbtIdent = "interface-log" :: Text + dbtProj = dbtProjId + dbtSQLQuery (ilog `E.LeftOuterJoin` ihealth) = do + EL.on ( ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface + E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) + E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) + ) + unless (null interfs) $ + E.where_ $ E.or [ ilog E.^. InterfaceLogInterface E.==. E.val ifce + E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.val subt + E.&&. ilog E.^. InterfaceLogWrite E.=~. E.val writ + | (UniqueInterfaceHealth ifce subt writ) <- interfs + ] + let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead + return (ilog, ihour, E.joinV $ ihealth E.?. InterfaceHealthMessage) + + queryILog :: (E.SqlExpr (Entity InterfaceLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity InterfaceHealth))) -> E.SqlExpr (Entity InterfaceLog) + queryILog = $(E.sqlLOJproj 2 1) + resultILog :: Lens' (DBRow (Entity InterfaceLog, E.Value Int, E.Value (Maybe Text))) InterfaceLog + resultILog = _dbrOutput . _1 . _entityVal + resultHours :: Lens' (DBRow (Entity InterfaceLog, E.Value Int, E.Value (Maybe Text))) Int + resultHours = _dbrOutput . _2 . E._unValue + -- resultErrMsg :: Traversal' (DBRow (Entity InterfaceLog, E.Value Int, E.Value (Maybe Text))) Text + -- resultErrMsg = _dbrOutput . _3 . E._unValue . _Just + + dbtRowKey = queryILog >>> (E.^.InterfaceLogId) + colonnade now = mconcat + [ sortable Nothing (i18nCell MsgInterfaceStatus) $ \row -> -- do + let hours = row ^. resultHours + -- defmsg = row ^? resultErrMsg + logtime = row ^. resultILog . _interfaceLogTime + success = row ^. resultILog . _interfaceLogSuccess + iface = row ^. resultILog . _interfaceLogInterface + status = success && now <= addHours hours logtime + in tellCell [(iface,status)] $ + wgtCell $ flagError status + , sortable (Just "interface") (i18nCell MsgInterfaceName ) $ \(view (resultILog . _interfaceLogInterface) -> n) -> textCell n + , sortable (Just "subtype") (i18nCell MsgInterfaceSubtype ) $ textCell . view (resultILog . _interfaceLogSubtype) + , sortable (Just "write") (i18nCell MsgInterfaceWrite ) $ (`ifIconCell` IconEdit) . view (resultILog . _interfaceLogWrite) + , sortable (Just "time") (i18nCell MsgInterfaceLastSynch ) $ dateTimeCell . view (resultILog . _interfaceLogTime) + , sortable (Just "rows") (i18nCell MsgTableRows ) $ cellMaybe numCell . view (resultILog . _interfaceLogRows) + , sortable (Just "success") (i18nCell MsgInterfaceSuccess ) $ \(view (resultILog . _interfaceLogSuccess) -> s) -> iconBoolCell s + , sortable Nothing (i18nCell MsgInterfaceInfo ) $ \(view resultILog -> ilt) -> case ilt of + InterfaceLog "AVS" "Synch" True _ _ i _ -> anchorCell ProblemAvsErrorR $ toWgt $ bool i "AVS-Log" $ null i + InterfaceLog "LPR" _ _ _ _ i _ -> anchorCell PrintLogR $ toWgt $ bool i "LPR-Log" $ null i + InterfaceLog _ _ _ _ _ i _ -> textCell i + ] + dbtSorting = mconcat + [ singletonMap "interface" $ SortColumn $ queryILog >>> (E.^. InterfaceLogInterface) + , singletonMap "subtype" $ SortColumn $ queryILog >>> (E.^. InterfaceLogSubtype) + , singletonMap "write" $ SortColumn $ queryILog >>> (E.^. InterfaceLogWrite) + , singletonMap "time" $ SortColumn $ queryILog >>> (E.^. InterfaceLogTime) + , singletonMap "rows" $ SortColumn $ queryILog >>> (E.^. InterfaceLogRows) + , singletonMap "success" $ SortColumn $ queryILog >>> (E.^. InterfaceLogSuccess) + ] + ilvalidator = def & defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"] + dbtFilter = mempty + dbtFilterUI = mempty + dbtStyle = def + dbtParams = def + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + + getHealthInterfaceR :: [Text] -> Handler Html getHealthInterfaceR ris = do let interfs = identifyInterfaces ris res <- runDB $ E.select $ do - (ilog :& ihealth) <- E.from (E.table @InterfaceLog + (ilog :& ihealth) <- E.from (E.table @InterfaceLog `E.leftJoin` E.table @InterfaceHealth - `E.on` (\(ilog :& ihealth) -> + `E.on` (\(ilog :& ihealth) -> ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) )) - unless (null interfs) $ + unless (null interfs) $ E.where_ $ E.or [ ilog E.^. InterfaceLogInterface E.==. E.val ifce E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.val subt E.&&. ilog E.^. InterfaceLogWrite E.=~. E.val writ | (UniqueInterfaceHealth ifce subt writ) <- interfs - ] - let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val 48) + ] + let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val 48) return (ilog, ihour, E.joinV $ ihealth E.?. InterfaceHealthMessage) siteLayoutMsg MsgMenuHealthInterface $ do setTitleI MsgMenuHealthInterface [whamlet| TODO This page is not yet fully implemented - +

                      $forall i <- res
                    • diff --git a/src/Handler/LMS/Report.hs b/src/Handler/LMS/Report.hs index a0a6fefb6..2e3ffb00b 100644 --- a/src/Handler/LMS/Report.hs +++ b/src/Handler/LMS/Report.hs @@ -294,8 +294,7 @@ postLmsReportUploadR sid qsh = do setTitleI MsgMenuLmsUpload [whamlet|$newline never - ^{widget} -

                      + ^{widget} |] diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 49cc6a7ba..2b05f208f 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -93,8 +93,8 @@ toMorning = toTimeOfDay 6 0 0 toTimeOfDay :: Int -> Int -> Pico -> Day -> UTCTime toTimeOfDay todHour todMin todSec d = localTimeToUTCTZ appTZ $ LocalTime d TimeOfDay{..} -addHours :: Integer -> UTCTime -> UTCTime -addHours = addUTCTime . secondsToNominalDiffTime . fromInteger . (* 3600) +addHours :: Integral n => n -> UTCTime -> UTCTime +addHours = addUTCTime . secondsToNominalDiffTime . fromIntegral . (* 3600) instance HasLocalTime UTCTime where toLocalTime = utcToLocalTime From c71814d1ef1efc16c278136dfd6ebd86bd1d20db Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Feb 2024 18:43:57 +0100 Subject: [PATCH 095/110] fix(health): fix #151 by offering route /health/interface/* --- .../uniworx/categories/admin/de-de-formal.msg | 5 +- messages/uniworx/categories/admin/en-eu.msg | 5 +- models/audit.model | 3 +- src/Handler/Admin.hs | 81 +----------- src/Handler/Health/Interface.hs | 118 ++++++++++++------ templates/admin-problems.hamlet | 7 +- 6 files changed, 100 insertions(+), 119 deletions(-) diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index ad521c490..6fb6a2836 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -121,10 +121,13 @@ ProblemsAvsSynchHeading: Synchronisation AVS Fahrberechtigungen ProblemsAvsErrorHeading: Fehlermeldungen ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit +InterfacesOk: Schnittstellen sind ok. +InterfacesFail n@Int: #{tshow n} Schnittstellenprobleme! InterfaceStatus !ident-ok: Status InterfaceName: Schnittstelle InterfaceLastSynch: Zuletzt InterfaceSubtype: Betreffend InterfaceWrite: Schreibend InterfaceSuccess: Rückmeldung -InterfaceInfo: Nachricht \ No newline at end of file +InterfaceInfo: Nachricht +InterfaceFreshness: Prüfungszeitraum (h) \ No newline at end of file diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index c73fd8910..74420ff19 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -121,10 +121,13 @@ ProblemsAvsSynchHeading: Synchronisation AVS Driving Licences ProblemsAvsErrorHeading: Error Log ProblemsInterfaceSince: Only considering successes and errors since +InterfacesOk: Interfaces are ok. +InterfacesFail n: #{tshow n} Interface problems! InterfaceStatus: Status InterfaceName: Interface InterfaceLastSynch: Last InterfaceSubtype: Affecting InterfaceWrite: Write InterfaceSuccess: Returned -InterfaceInfo: Message \ No newline at end of file +InterfaceInfo: Message +InterfaceFreshness: Check hours \ No newline at end of file diff --git a/models/audit.model b/models/audit.model index defb5c391..3cd567a13 100644 --- a/models/audit.model +++ b/models/audit.model @@ -26,7 +26,6 @@ InterfaceHealth interface Text subtype Text Maybe write Bool Maybe - hours Int - message Text Maybe + hours Int UniqueInterfaceHealth interface subtype write !force -- Note that nullable fields must be either empty or unique deriving Eq Read Show Generic diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 92dcac020..fd001c768 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -24,6 +24,7 @@ import qualified Database.Esqueleto.Utils as E import Handler.Utils import Handler.Utils.Avs import Handler.Utils.Users +import Handler.Health.Interface import Handler.Admin.Test as Handler.Admin import Handler.Admin.ErrorMessage as Handler.Admin @@ -54,13 +55,15 @@ getAdminProblemsR = do flagNonZero n | n <= 0 = flagError True | otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n)) - (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, interfaceTable) <- runDB $ (,,,,,) + (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, (interfaceOks, interfaceTable)) <- runDB $ (,,,,,) <$> areAllUsersReachable <*> allDriversHaveAvsId now <*> allRDriversHaveFs now <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <. cutOffOldTime]) <*> (not <$> exists [PrintAcknowledgeProcessed ==. False]) - <*> fmap (view _2) (mkInterfaceLogTable flagError cutOffOldTime) + <*> mkInterfaceLogTable flagError mempty + let interfacesBadNr = length $ filter (not . snd) interfaceOks + -- interfacesOk = all snd interfaceOks diffLics <- try retrieveDifferingLicences >>= \case -- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received" (Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException) @@ -235,77 +238,3 @@ retrieveDriversRWithoutF now = do E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld) E.&&. E.notExists (hasValidQual AvsLicenceVorfeld) return usr - - - - - -mkInterfaceLogTable :: (Bool -> Widget) -> UTCTime -> DB (Any, Widget) -mkInterfaceLogTable flagError cutOffOldTime = do - avsSynchStats <- E.select $ do - uavs <- E.from $ E.table @UserAvs - E.where_ $ uavs E.^. UserAvsLastSynch E.>. E.val cutOffOldTime - let isOk = E.isNothing (uavs E.^. UserAvsLastSynchError) - E.groupBy isOk - E.orderBy [E.descNullsLast isOk] - return (isOk, E.countRows, E.max_ $ uavs E.^. UserAvsLastSynch) - let - mkBadInfo badRows (fromMaybe cutOffOldTime -> badTime) | badRows > 0 = do - fmtCut <- formatTime SelFormatDate cutOffOldTime - fmtBad <- formatTime SelFormatDateTime badTime - return $ tshow badRows <> " Fehler seit " <> fmtCut <> ", zuletzt um " <> fmtBad - mkBadInfo _ _ = return mempty - writeAvsSynchStats okRows (fromMaybe cutOffOldTime -> okTime) badInfo = - void $ upsertBy (UniqueInterfaceSubtypeWrite "AVS" "Synch" True) - (InterfaceLog "AVS" "Synch" True okTime okRows badInfo (null badInfo)) - [InterfaceLogTime =. okTime, InterfaceLogRows =. okRows, InterfaceLogInfo =. badInfo, InterfaceLogSuccess =. null badInfo] - --case $(unValueN 3) <$> avsSynchStats of - case avsSynchStats of - ((E.Value True , E.Value okRows, E.Value okTime):(E.Value False, E.Value badRows, E.Value badTime):_) -> - writeAvsSynchStats (Just okRows) okTime =<< mkBadInfo badRows badTime - ((E.Value True , E.Value okRows, E.Value okTime):_) -> - writeAvsSynchStats (Just okRows) okTime mempty - ((E.Value False, E.Value badRows, E.Value badTime):_) -> do - lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch] - writeAvsSynchStats Nothing lastOk =<< mkBadInfo badRows badTime - _ -> return () - - let - flagOld = flagError . (cutOffOldTime <) - resultDBTable = DBTable{..} - where - resultILog :: Lens' (DBRow (Entity InterfaceLog)) InterfaceLog - resultILog = _dbrOutput . _entityVal - dbtSQLQuery = return - dbtRowKey = (E.^. InterfaceLogId) - dbtProj = dbtProjId - dbtColonnade = dbColonnade $ mconcat - [ sortable Nothing (textCell "Status" ) $ wgtCell . flagOld . view (resultILog . _interfaceLogTime) - , sortable (Just "interface") (textCell "Interface" ) $ \(view (resultILog . _interfaceLogInterface) -> n) -> textCell n - , sortable (Just "subtype") (i18nCell MsgInterfaceSubtype ) $ textCell . view (resultILog . _interfaceLogSubtype) - , sortable (Just "write") (i18nCell MsgInterfaceWrite ) $ (`ifIconCell` IconEdit) . view (resultILog . _interfaceLogWrite) - , sortable (Just "time") (i18nCell MsgInterfaceLastSynch ) $ dateTimeCell . view (resultILog . _interfaceLogTime) - , sortable (Just "rows") (i18nCell MsgTableRows ) $ cellMaybe numCell . view (resultILog . _interfaceLogRows) - , sortable Nothing (textCell "Info" ) $ \(view resultILog -> ilt) -> case ilt of - InterfaceLog "AVS" "Synch" True _ _ i _ -> anchorCell ProblemAvsErrorR $ toWgt $ bool i "AVS-Log" $ null i - InterfaceLog "LPR" _ _ _ _ i _ -> anchorCell PrintLogR $ toWgt $ bool i "LPR-Log" $ null i - InterfaceLog _ _ _ _ _ i _ -> textCell i - ] - dbtSorting = mconcat - [ singletonMap "interface" $ SortColumn (E.^. InterfaceLogInterface) - , singletonMap "subtype" $ SortColumn (E.^. InterfaceLogSubtype) - , singletonMap "write" $ SortColumn (E.^. InterfaceLogWrite) - , singletonMap "time" $ SortColumn (E.^. InterfaceLogTime) - , singletonMap "rows" $ SortColumn (E.^. InterfaceLogRows) - ] - dbtFilter = mempty - dbtFilterUI = mempty - dbtStyle = def - dbtIdent = "interface-log" :: Text - dbtParams = def - dbtCsvEncode = noCsvEncode - dbtCsvDecode = Nothing - dbtExtraReps = [] - resultDBTableValidator = def - & defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"] - dbTable resultDBTableValidator resultDBTable \ No newline at end of file diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index e623901f1..d1b8a0af0 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -8,6 +8,8 @@ module Handler.Health.Interface ( getHealthInterfaceR + , mkInterfaceLogTable + , runInterfaceChecks ) where @@ -17,7 +19,7 @@ import Import import qualified Data.Text as Text import Handler.Utils -import Database.Esqueleto.Experimental ((:&)(..)) +-- import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Legacy as EL (on) @@ -43,8 +45,39 @@ pbool (Text.toLower . Text.strip -> w) | w `elem` ["0", "f", "false","falsch"] = Just False | otherwise = Nothing -mkInterfaceLogTable :: [Unique InterfaceHealth] -> (Bool -> Widget) -> DB ([(Text,Bool)], Widget) -mkInterfaceLogTable interfs flagError = do + + +getHealthInterfaceR :: [Text] -> Handler Html +getHealthInterfaceR ris = do + let interfs = identifyInterfaces ris + (missing, allok, res, iltable) <- runInterfaceLogTable interfs + when missing notFound -- send 404 if an interface any interface was not found + unless allok $ sendResponseStatus internalServerError500 $ "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] + siteLayoutMsg MsgMenuHealthInterface $ do + setTitleI MsgMenuHealthInterface + [whamlet| + Interfaces healthy. + + ^{iltable} + |] + + +runInterfaceLogTable :: [Unique InterfaceHealth] -> Handler (Bool, Bool, [(Text,Bool)], Widget) +runInterfaceLogTable interfs = do + -- we abuse messageTooltip for colored icons here + msgSuccessTooltip <- messageI Success MsgMessageSuccess + -- msgWarningTooltip <- messageI Warning MsgMessageWarning + msgErrorTooltip <- messageI Error MsgMessageError + let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip + (res, twgt) <- runDB $ mkInterfaceLogTable flagError interfs + let missing = notNull [ifce | (UniqueInterfaceHealth ifce _subt _writ) <- interfs, ifce `notElem` (fst <$> res) ] + allok = all snd res + return (missing, allok, res, twgt) + + +mkInterfaceLogTable :: (Bool -> Widget) -> [Unique InterfaceHealth] -> DB ([(Text,Bool)], Widget) +mkInterfaceLogTable flagError interfs = do + runInterfaceChecks now <- liftIO getCurrentTime dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..} where @@ -62,16 +95,14 @@ mkInterfaceLogTable interfs flagError = do | (UniqueInterfaceHealth ifce subt writ) <- interfs ] let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead - return (ilog, ihour, E.joinV $ ihealth E.?. InterfaceHealthMessage) + return (ilog, ihour) queryILog :: (E.SqlExpr (Entity InterfaceLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity InterfaceHealth))) -> E.SqlExpr (Entity InterfaceLog) queryILog = $(E.sqlLOJproj 2 1) - resultILog :: Lens' (DBRow (Entity InterfaceLog, E.Value Int, E.Value (Maybe Text))) InterfaceLog + resultILog :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) InterfaceLog resultILog = _dbrOutput . _1 . _entityVal - resultHours :: Lens' (DBRow (Entity InterfaceLog, E.Value Int, E.Value (Maybe Text))) Int + resultHours :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) Int resultHours = _dbrOutput . _2 . E._unValue - -- resultErrMsg :: Traversal' (DBRow (Entity InterfaceLog, E.Value Int, E.Value (Maybe Text))) Text - -- resultErrMsg = _dbrOutput . _3 . E._unValue . _Just dbtRowKey = queryILog >>> (E.^.InterfaceLogId) colonnade now = mconcat @@ -88,6 +119,7 @@ mkInterfaceLogTable interfs flagError = do , sortable (Just "subtype") (i18nCell MsgInterfaceSubtype ) $ textCell . view (resultILog . _interfaceLogSubtype) , sortable (Just "write") (i18nCell MsgInterfaceWrite ) $ (`ifIconCell` IconEdit) . view (resultILog . _interfaceLogWrite) , sortable (Just "time") (i18nCell MsgInterfaceLastSynch ) $ dateTimeCell . view (resultILog . _interfaceLogTime) + , sortable Nothing (i18nCell MsgInterfaceFreshness ) $ numCell . view resultHours , sortable (Just "rows") (i18nCell MsgTableRows ) $ cellMaybe numCell . view (resultILog . _interfaceLogRows) , sortable (Just "success") (i18nCell MsgInterfaceSuccess ) $ \(view (resultILog . _interfaceLogSuccess) -> s) -> iconBoolCell s , sortable Nothing (i18nCell MsgInterfaceInfo ) $ \(view resultILog -> ilt) -> case ilt of @@ -95,6 +127,7 @@ mkInterfaceLogTable interfs flagError = do InterfaceLog "LPR" _ _ _ _ i _ -> anchorCell PrintLogR $ toWgt $ bool i "LPR-Log" $ null i InterfaceLog _ _ _ _ _ i _ -> textCell i ] + dbtSorting = mconcat [ singletonMap "interface" $ SortColumn $ queryILog >>> (E.^. InterfaceLogInterface) , singletonMap "subtype" $ SortColumn $ queryILog >>> (E.^. InterfaceLogSubtype) @@ -113,33 +146,44 @@ mkInterfaceLogTable interfs flagError = do dbtExtraReps = [] +-- | runs additional checks and logs results within InterfaceLogTable; assumed to executable within a handler call +runInterfaceChecks :: DB () +runInterfaceChecks = do + avsInterfaceCheck + lprAckCheck + +lprAckCheck :: DB () +lprAckCheck = return () -- !!! TODO !!! Stub + -- ensure that all received apc-idents were ok -getHealthInterfaceR :: [Text] -> Handler Html -getHealthInterfaceR ris = do - let interfs = identifyInterfaces ris - res <- runDB $ E.select $ do - (ilog :& ihealth) <- E.from (E.table @InterfaceLog - `E.leftJoin` E.table @InterfaceHealth - `E.on` (\(ilog :& ihealth) -> - ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface - E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) - E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) - )) - unless (null interfs) $ - E.where_ $ E.or [ ilog E.^. InterfaceLogInterface E.==. E.val ifce - E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.val subt - E.&&. ilog E.^. InterfaceLogWrite E.=~. E.val writ - | (UniqueInterfaceHealth ifce subt writ) <- interfs - ] - let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val 48) - return (ilog, ihour, E.joinV $ ihealth E.?. InterfaceHealthMessage) - siteLayoutMsg MsgMenuHealthInterface $ do - setTitleI MsgMenuHealthInterface - [whamlet| - TODO This page is not yet fully implemented - -

                        - $forall i <- res -
                      • - #{show i} - |] +avsInterfaceCheck :: DB () +avsInterfaceCheck = flip (maybeM $ return ()) (getBy $ UniqueInterfaceHealth "AVS" (Just "Synch") (Just True)) $ \Entity{entityVal=InterfaceHealth{interfaceHealthHours}} -> do + now <- liftIO getCurrentTime + let cutOffOldTime = addHours (-interfaceHealthHours) now + avsSynchStats <- E.select $ do + uavs <- E.from $ E.table @UserAvs + E.where_ $ uavs E.^. UserAvsLastSynch E.>. E.val cutOffOldTime + let isOk = E.isNothing (uavs E.^. UserAvsLastSynchError) + E.groupBy isOk + E.orderBy [E.descNullsLast isOk] + return (isOk, E.countRows, E.max_ $ uavs E.^. UserAvsLastSynch) + let + mkBadInfo badRows (fromMaybe cutOffOldTime -> badTime) | badRows > 0 = do + fmtCut <- formatTime SelFormatDate cutOffOldTime + fmtBad <- formatTime SelFormatDateTime badTime + return $ tshow badRows <> " Fehler seit " <> fmtCut <> ", zuletzt um " <> fmtBad + mkBadInfo _ _ = return mempty + writeAvsSynchStats okRows (fromMaybe cutOffOldTime -> okTime) badInfo = + void $ upsertBy (UniqueInterfaceSubtypeWrite "AVS" "Synch" True) + (InterfaceLog "AVS" "Synch" True okTime okRows badInfo (null badInfo)) + [InterfaceLogTime =. okTime, InterfaceLogRows =. okRows, InterfaceLogInfo =. badInfo, InterfaceLogSuccess =. null badInfo] + --case $(unValueN 3) <$> avsSynchStats of + case avsSynchStats of + ((E.Value True , E.Value okRows, E.Value okTime):(E.Value False, E.Value badRows, E.Value badTime):_) -> + writeAvsSynchStats (Just okRows) okTime =<< mkBadInfo badRows badTime + ((E.Value True , E.Value okRows, E.Value okTime):_) -> + writeAvsSynchStats (Just okRows) okTime mempty + ((E.Value False, E.Value badRows, E.Value badTime):_) -> do + lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch] + writeAvsSynchStats Nothing lastOk =<< mkBadInfo badRows badTime + _ -> return () diff --git a/templates/admin-problems.hamlet b/templates/admin-problems.hamlet index d07df69fd..b2a48143b 100644 --- a/templates/admin-problems.hamlet +++ b/templates/admin-problems.hamlet @@ -56,8 +56,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

                        _{MsgMenuInterfaces}
                        -

                        - _{MsgProblemsInterfaceSince} ^{formatTimeW SelFormatDate cutOffOldTime} +

                        + $if interfacesBadNr > 0 + _{MsgInterfacesFail interfacesBadNr} + $else + _{MsgInterfacesOk} ^{interfaceTable} From ce3852e3d365e62b32d181d58b7cbcc749e49373 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 5 Feb 2024 18:54:50 +0100 Subject: [PATCH 096/110] fix(health): fix #153 and offer interface health route matching --- .../uniworx/categories/admin/de-de-formal.msg | 2 +- messages/uniworx/categories/admin/en-eu.msg | 2 +- src/Audit.hs | 38 +++- src/Handler/Health/Interface.hs | 165 ++++++++++++------ src/Model/Migration/Definitions.hs | 8 + src/Utils.hs | 11 +- src/Utils/Lens.hs | 1 + src/Utils/Print.hs | 4 +- 8 files changed, 167 insertions(+), 64 deletions(-) diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index 6fb6a2836..eb6cfe753 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -122,7 +122,7 @@ ProblemsAvsErrorHeading: Fehlermeldungen ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit InterfacesOk: Schnittstellen sind ok. -InterfacesFail n@Int: #{tshow n} Schnittstellenprobleme! +InterfacesFail n@Int: #{pluralDEeN n "Schnittstellenproblem"}! InterfaceStatus !ident-ok: Status InterfaceName: Schnittstelle InterfaceLastSynch: Zuletzt diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index 74420ff19..13f35ed9f 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -122,7 +122,7 @@ ProblemsAvsErrorHeading: Error Log ProblemsInterfaceSince: Only considering successes and errors since InterfacesOk: Interfaces are ok. -InterfacesFail n: #{tshow n} Interface problems! +InterfacesFail n: #{pluralENsN n "interface problem"}! InterfaceStatus: Status InterfaceName: Interface InterfaceLastSynch: Last diff --git a/src/Audit.hs b/src/Audit.hs index f26af2d80..40c4a4206 100644 --- a/src/Audit.hs +++ b/src/Audit.hs @@ -8,7 +8,7 @@ module Audit , audit , AuditRemoteException(..) , getRemote - , logInterface + , logInterface, logInterface' ) where @@ -128,11 +128,39 @@ logInterface :: ( AuthId (HandlerSite m) ~ Key User -> Text -- ^ Any additional information -> ReaderT (YesodPersistBackend (HandlerSite m)) m () -- ^ Log a transaction using information available from `HandlerT`, also calls `audit` -logInterface (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogSubtype) interfaceLogSuccess interfaceLogRows (Text.strip -> interfaceLogInfo) = do - interfaceLogTime <- liftIO getCurrentTime +logInterface interfaceLogInterface interfaceLogSubtype interfaceLogSuccess interfaceLogRows interfaceLogInfo = do interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest - deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace, deleteBy & insert seems to be safest and fastest - insert_ InterfaceLog{..} + logInterface' interfaceLogInterface interfaceLogSubtype interfaceLogWrite interfaceLogSuccess interfaceLogRows interfaceLogInfo + +logInterface' :: ( AuthId (HandlerSite m) ~ Key User + , IsSqlBackend (YesodPersistBackend (HandlerSite m)) + , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m)) + , HasInstanceID (HandlerSite m) InstanceId + , YesodAuthPersist (HandlerSite m) + , MonadHandler m + , MonadCatch m + , HasAppSettings (HandlerSite m) + , HasCallStack + ) + => Text -- ^ Interface that is used + -> Text -- ^ Subtype of the interface, if any + -> Bool -- ^ True indicates Write Access to FRADrive + -> Bool -- ^ Success=True, Failure=False + -> Maybe Int -- ^ Number of transmitted datasets + -> Text -- ^ Any additional information + -> ReaderT (YesodPersistBackend (HandlerSite m)) m () +-- ^ Log a transaction using information available from `HandlerT`, also calls `audit` +logInterface' (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogSubtype) interfaceLogWrite interfaceLogSuccess interfaceLogRows (Text.strip -> interfaceLogInfo) = do + interfaceLogTime <- liftIO getCurrentTime + -- deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace: deleteBy & insert seems to be safest and fastest + -- insert_ InterfaceLog{..} + void $ upsertBy (UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite) + ( InterfaceLog{..} ) + [ InterfaceLogTime =. interfaceLogTime + , InterfaceLogRows =. interfaceLogRows + , InterfaceLogInfo =. interfaceLogInfo + , InterfaceLogSuccess =. interfaceLogSuccess + ] audit TransactionInterface { transactionInterfaceName = interfaceLogInterface , transactionInterfaceSubtype = interfaceLogSubtype diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index d1b8a0af0..c43ffaed8 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -18,24 +18,21 @@ import Import -- import qualified Data.Set as Set import qualified Data.Text as Text import Handler.Utils +import Handler.Utils.Concurrent -- import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Legacy as EL (on) +import qualified Database.Persist.Sql as E (deleteWhereCount) -identifyInterfaces :: [Text] -> [Unique InterfaceHealth] -identifyInterfaces [] = [] -identifyInterfaces [i] = [UniqueInterfaceHealth i Nothing Nothing] -identifyInterfaces [i,s] = [UniqueInterfaceHealth i (wc2null s) Nothing] -identifyInterfaces (i:s:w:r) = UniqueInterfaceHealth i (wc2null s) (pbool w) : identifyInterfaces r - -- | identify a wildcard argument wc2null :: Text -> Maybe Text -wc2null "." = Nothing +-- wc2null "." = Nothing -- does not work, since dots are eliminated in URLs -- wc2null "-" = Nothing -- used as wildcard subtype in lpr interface wc2null "_" = Nothing +wc2null "*" = Nothing wc2null o = Just o -- | sloppily parse a boolean, also see Model.Types.Avs.SloppyBool @@ -45,55 +42,92 @@ pbool (Text.toLower . Text.strip -> w) | w `elem` ["0", "f", "false","falsch"] = Just False | otherwise = Nothing +-- | parse UniqueInterfaceHealth with subtype and write arguments being optional for the last interface. Wildcards '_' or '.' are also allowed in all places. +identifyInterfaces :: [Text] -> [Unique InterfaceHealth] +identifyInterfaces [] = [] +identifyInterfaces [i] = [UniqueInterfaceHealth i Nothing Nothing] +identifyInterfaces [i,s] = [UniqueInterfaceHealth i (wc2null s) Nothing] +identifyInterfaces (i:s:w:r) = UniqueInterfaceHealth i (wc2null s) (pbool w) : identifyInterfaces r + +type ReqBanInterfaceHealth = ([Unique InterfaceHealth],[Unique InterfaceHealth]) + +-- | Interface names prefixed with '-' are to be excluded from the query +splitInterfaces :: [Unique InterfaceHealth] -> ReqBanInterfaceHealth +splitInterfaces = foldl' aux mempty + where + aux (reqs,bans) uih@(UniqueInterfaceHealth i s w) + | Just ('-', b) <- Text.uncons i = (reqs, UniqueInterfaceHealth b s w : bans) + | otherwise = (uih : reqs, bans) + +-- | check whether the first argument is equal or more specialzed (i.e. more Just) than the second +matchesUniqueInterfaceHealth :: Unique InterfaceHealth -> Unique InterfaceHealth -> Bool +matchesUniqueInterfaceHealth (UniqueInterfaceHealth ai as aw) (UniqueInterfaceHealth bi bs bw) = ai == bi && eqOrNothing as bs && eqOrNothing aw bw + where + eqOrNothing _ Nothing = True + eqOrNothing a b = a == b getHealthInterfaceR :: [Text] -> Handler Html getHealthInterfaceR ris = do - let interfs = identifyInterfaces ris - (missing, allok, res, iltable) <- runInterfaceLogTable interfs - when missing notFound -- send 404 if an interface any interface was not found - unless allok $ sendResponseStatus internalServerError500 $ "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] - siteLayoutMsg MsgMenuHealthInterface $ do + let (forced, ris') = case ris of + ("force":ris0) -> (True , ris0) + _ -> (False, ris ) + interfs = splitInterfaces $ identifyInterfaces ris' + (missing, allok, res, iltable) <- runInterfaceLogTable interfs + let badMsg = "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] + when missing notFound -- send 404 if any requested interface was not found + unless (forced || allok) $ sendResponseStatus internalServerError500 badMsg + content <- siteLayoutMsg MsgMenuHealthInterface $ do setTitleI MsgMenuHealthInterface [whamlet| - Interfaces healthy. + $if allok + Interfaces are healthy. + $else + #{badMsg} ^{iltable} |] + sendResponseStatus (bool internalServerError500 status200 allok) content -runInterfaceLogTable :: [Unique InterfaceHealth] -> Handler (Bool, Bool, [(Text,Bool)], Widget) -runInterfaceLogTable interfs = do +runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget) +runInterfaceLogTable interfs@(reqIfs,_) = do -- we abuse messageTooltip for colored icons here msgSuccessTooltip <- messageI Success MsgMessageSuccess -- msgWarningTooltip <- messageI Warning MsgMessageWarning msgErrorTooltip <- messageI Error MsgMessageError let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip (res, twgt) <- runDB $ mkInterfaceLogTable flagError interfs - let missing = notNull [ifce | (UniqueInterfaceHealth ifce _subt _writ) <- interfs, ifce `notElem` (fst <$> res) ] + let missing = notNull [ifce | (UniqueInterfaceHealth ifce _subt _writ) <- reqIfs, ifce `notElem` (fst <$> res) ] allok = all snd res return (missing, allok, res, twgt) +-- ihDebugShow :: Unique InterfaceHealth -> Text +-- ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> tshow s <> tshow w <> ")" -mkInterfaceLogTable :: (Bool -> Widget) -> [Unique InterfaceHealth] -> DB ([(Text,Bool)], Widget) -mkInterfaceLogTable flagError interfs = do - runInterfaceChecks +mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget) +mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do + -- $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs]) + void $ liftHandler $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs now <- liftIO getCurrentTime dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..} where + sanitize = text2AlphaNumPlus ['+','-','_','Ä','Ö','Ü','ß','ä','ö','ü'] dbtIdent = "interface-log" :: Text dbtProj = dbtProjId dbtSQLQuery (ilog `E.LeftOuterJoin` ihealth) = do EL.on ( ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface - E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) - E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) + E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) + E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) ) - unless (null interfs) $ - E.where_ $ E.or [ ilog E.^. InterfaceLogInterface E.==. E.val ifce - E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.val subt - E.&&. ilog E.^. InterfaceLogWrite E.=~. E.val writ - | (UniqueInterfaceHealth ifce subt writ) <- interfs - ] + let matchUIH crits = E.or + [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) + E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.val (sanitize <$> subt) + E.&&. ilog E.^. InterfaceLogWrite E.=~. E.val writ + | (UniqueInterfaceHealth ifce subt writ) <- crits + ] + unless (null reqIfs) $ E.where_ $ matchUIH reqIfs + unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead return (ilog, ihour) @@ -147,19 +181,46 @@ mkInterfaceLogTable flagError interfs = do -- | runs additional checks and logs results within InterfaceLogTable; assumed to executable within a handler call -runInterfaceChecks :: DB () -runInterfaceChecks = do - avsInterfaceCheck - lprAckCheck - -lprAckCheck :: DB () -lprAckCheck = return () -- !!! TODO !!! Stub - -- ensure that all received apc-idents were ok +runInterfaceChecks :: ReqBanInterfaceHealth -> DB () +runInterfaceChecks interfs = do + avsInterfaceCheck interfs + lprAckCheck interfs -avsInterfaceCheck :: DB () -avsInterfaceCheck = flip (maybeM $ return ()) (getBy $ UniqueInterfaceHealth "AVS" (Just "Synch") (Just True)) $ \Entity{entityVal=InterfaceHealth{interfaceHealthHours}} -> do - now <- liftIO getCurrentTime - let cutOffOldTime = addHours (-interfaceHealthHours) now +maybeRunCheck :: ReqBanInterfaceHealth -> Unique InterfaceHealth -> (UTCTime -> DB ()) -> DB () +maybeRunCheck (reqIfs,banIfs) uih act + | null reqIfs || any (matchesUniqueInterfaceHealth uih) reqIfs + , null banIfs || not (any (matchesUniqueInterfaceHealth uih) banIfs) = do + mih <- getBy uih + whenIsJust mih $ \eih -> do + now <- liftIO getCurrentTime + act $ addHours (negate $ interfaceHealthHours $ entityVal eih) now + | otherwise = return () + +-- maybeRunCheck :: Unique InterfaceHealth -> (Int -> DB ()) -> DB () +-- maybeRunCheck uih act = maybeM (return ()) (act . interfaceHealthHours . entityVal) $ getBy uih + -- maybeRunCheck uih act = getBy uih >>= flip whenIsJust (act . interfaceHealthHours . entityVal) + -- where + -- ih2hours :: Entity InterfaceHealth -> Int + -- -- ih2hours Entity{entityVal=InterfaceHealth{interfaceHealthHours=h}} = h + -- ih2hours = interfaceHealthHours . entityVal + + +lprAckCheck :: ReqBanInterfaceHealth -> DB () +lprAckCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "Printer" (Just "Acknowledge") (Just True)) $ \cutOffOldTime -> do + unproc <- selectList [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. False] [] + if notNull unproc + then mkLog False (Just $ length unproc) "Long unprocessed APC-Idents exist" + else do + oks <- E.deleteWhereCount [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. True] + if oks > 0 + then mkLog True (Just $ fromIntegral oks) "Long processed APC-Idents removed" + else mkLog True Nothing mempty + where + mkLog = logInterface' "Printer" "Acknowledge" True + + +avsInterfaceCheck :: ReqBanInterfaceHealth -> DB () +avsInterfaceCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "AVS" (Just "Synch") (Just True)) $ \cutOffOldTime -> do avsSynchStats <- E.select $ do uavs <- E.from $ E.table @UserAvs E.where_ $ uavs E.^. UserAvsLastSynch E.>. E.val cutOffOldTime @@ -167,23 +228,21 @@ avsInterfaceCheck = flip (maybeM $ return ()) (getBy $ UniqueInterfaceHealth "AV E.groupBy isOk E.orderBy [E.descNullsLast isOk] return (isOk, E.countRows, E.max_ $ uavs E.^. UserAvsLastSynch) - let + let mkBadInfo badRows (fromMaybe cutOffOldTime -> badTime) | badRows > 0 = do fmtCut <- formatTime SelFormatDate cutOffOldTime fmtBad <- formatTime SelFormatDateTime badTime return $ tshow badRows <> " Fehler seit " <> fmtCut <> ", zuletzt um " <> fmtBad mkBadInfo _ _ = return mempty - writeAvsSynchStats okRows (fromMaybe cutOffOldTime -> okTime) badInfo = - void $ upsertBy (UniqueInterfaceSubtypeWrite "AVS" "Synch" True) - (InterfaceLog "AVS" "Synch" True okTime okRows badInfo (null badInfo)) - [InterfaceLogTime =. okTime, InterfaceLogRows =. okRows, InterfaceLogInfo =. badInfo, InterfaceLogSuccess =. null badInfo] - --case $(unValueN 3) <$> avsSynchStats of - case avsSynchStats of - ((E.Value True , E.Value okRows, E.Value okTime):(E.Value False, E.Value badRows, E.Value badTime):_) -> - writeAvsSynchStats (Just okRows) okTime =<< mkBadInfo badRows badTime - ((E.Value True , E.Value okRows, E.Value okTime):_) -> - writeAvsSynchStats (Just okRows) okTime mempty - ((E.Value False, E.Value badRows, E.Value badTime):_) -> do - lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch] - writeAvsSynchStats Nothing lastOk =<< mkBadInfo badRows badTime + writeAvsSynchStats okRows badInfo = + logInterface' "AVS" "Synch" True (null badInfo) okRows badInfo + --case $(unValueN 3) <$> avsSynchStats of + case avsSynchStats of + ((E.Value True , E.Value okRows, E.Value _okTime):(E.Value False, E.Value badRows, E.Value badTime):_) -> + writeAvsSynchStats (Just okRows) =<< mkBadInfo badRows badTime + ((E.Value True , E.Value okRows, E.Value _okTime):_) -> + writeAvsSynchStats (Just okRows) mempty + ((E.Value False, E.Value badRows, E.Value badTime):_) -> + -- lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch] + writeAvsSynchStats Nothing =<< mkBadInfo badRows badTime _ -> return () diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 8e458ac47..a875b9648 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -123,6 +123,14 @@ migrateAlwaysSafe = do let itemDay = Map.findWithDefault today item changelogItemDays return [st|('#{toPathPiece item}', '#{iso8601Show itemDay}')|] in sql + -- unless (tableExists "interface_health") $ do + -- [executeQQ| + -- INSERT INTO "interface_health" (interface, subtype, write, hours) + -- VALUES + -- ('Printer', 'Acknowledge', True, 168) + -- , ('AVS' , 'Synch' , True , 96) + -- ON CONFLICT DO NOTHING; + -- |] {- Confusion about quotes, from the PostgreSQL Manual: diff --git a/src/Utils.hs b/src/Utils.hs index 2093da8b2..c47f29992 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -23,7 +23,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as CBS -import qualified Data.Char as Char +-- import qualified Data.Char as Char import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -319,9 +319,16 @@ citext2string = Text.unpack . CI.original string2citext :: String -> CI Text string2citext = CI.mk . Text.pack +text2AlphaNumPlus :: [Char] -> Text -> Text +text2AlphaNumPlus = + let alphaNum = Set.fromAscList $ ['0'..'9'] <> ['A'..'Z'] <> ['a'..'z'] + in \oks -> + let aNumPlus = Set.fromList oks <> alphaNum + in Text.filter (`Set.member` aNumPlus) + -- | Convert or remove all non-ascii characters, e.g. for filenames text2asciiAlphaNum :: Text -> Text -text2asciiAlphaNum = Text.filter (\c -> Char.isAlphaNum c && Char.isAscii c) +text2asciiAlphaNum = text2AlphaNumPlus ['-','_'] . Text.replace "ä" "ae" . Text.replace "Ä" "Ae" . Text.replace "Æ" "ae" diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 5e5f993c6..adcba7262 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -310,6 +310,7 @@ makeLenses_ ''AuthorshipStatementDefinition makeLenses_ ''PrintJob makeLenses_ ''InterfaceLog +-- makeLenses_ ''InterfaceLog -- not needed -------------------------- -- Fields for `UniWorX` -- diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 8687158b8..d4dc3f882 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -270,7 +270,7 @@ printLetter' pji pdf = do printJobFile = LBS.toStrict pdf printJobAcknowledged = Nothing qshort <- ifMaybeM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get - let logInter = flip (logInterface "LPR" qshort) (Just 1) + let logInter = flip (logInterface "Printer" qshort) (Just 1) lprPDF printJobFilename pdf >>= \case Left err -> do logInter False err @@ -288,7 +288,7 @@ reprintPDF ignoreReroute pjid = maybeM (return $ Left "Print job id is unknown." reprint :: PrintJob -> DB (Either Text Text) reprint pj@PrintJob{..} = do qshort <- ifMaybeM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get - let logInter = flip (logInterface "LPR" qshort) (Just 1) + let logInter = flip (logInterface "Printer" qshort) (Just 1) result <- lprPDF' ignoreReroute printJobFilename $ LBS.fromStrict printJobFile case result of Left err -> From 1464a9a5822250f49d06391428bbd6b171cba461 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 6 Feb 2024 00:14:53 +0000 Subject: [PATCH 097/110] chore(release): 27.4.57 --- CHANGELOG.md | 9 +++++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 13 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index d99bd198d..a09ca5698 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,15 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [27.4.57](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.56...v27.4.57) (2024-02-06) + + +### Bug Fixes + +* **course:** fix [#147](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/147) abort addd participant aborts now ([d332c0c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d332c0c11afd8b1dfe1343659f0b1626c968bbde)) +* **health:** fix [#151](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/151) by offering route /health/interface/* ([c71814d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c71814d1ef1efc16c278136dfd6ebd86bd1d20db)) +* **health:** fix [#153](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/153) and offer interface health route matching ([ce3852e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ce3852e3d365e62b32d181d58b7cbcc749e49373)) + ## [27.4.56](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.55...v27.4.56) (2023-12-20) diff --git a/nix/docker/version.json b/nix/docker/version.json index be8c9e7d6..2bc1d589a 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.56" + "version": "27.4.57" } diff --git a/package-lock.json b/package-lock.json index fb4545bc0..769a5b181 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.56", + "version": "27.4.57", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 25437a405..d92518019 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.56", + "version": "27.4.57", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 2ead3ea00..f22cd7d97 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.56 +version: 27.4.57 dependencies: - base - yesod From 42f1a802b52007ccca9595d732fc20f40cc66f6a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 6 Feb 2024 10:32:00 +0000 Subject: [PATCH 098/110] chore(health): getHealthInterfaceR responds to mime content type header --- src/Handler/Health/Interface.hs | 39 ++++++++++++++++++--------------- 1 file changed, 21 insertions(+), 18 deletions(-) diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index c43ffaed8..1b6ee1dee 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -67,27 +67,30 @@ matchesUniqueInterfaceHealth (UniqueInterfaceHealth ai as aw) (UniqueInterfaceHe eqOrNothing a b = a == b -getHealthInterfaceR :: [Text] -> Handler Html -getHealthInterfaceR ris = do - let (forced, ris') = case ris of - ("force":ris0) -> (True , ris0) - _ -> (False, ris ) - interfs = splitInterfaces $ identifyInterfaces ris' +getHealthInterfaceR :: [Text] -> Handler TypedContent +getHealthInterfaceR (dropWhile (=="force") -> ris) = do -- for backwards compatibility we ignore leading "force" + let interfs = splitInterfaces $ identifyInterfaces ris (missing, allok, res, iltable) <- runInterfaceLogTable interfs - let badMsg = "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] when missing notFound -- send 404 if any requested interface was not found - unless (forced || allok) $ sendResponseStatus internalServerError500 badMsg - content <- siteLayoutMsg MsgMenuHealthInterface $ do - setTitleI MsgMenuHealthInterface - [whamlet| - $if allok - Interfaces are healthy. - $else - #{badMsg} + let respond = sendResponseStatus (bool internalServerError500 status200 allok) + plainMsg = if allok + then "Interfaces are healthy" + else "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] + selectRep $ do + provideRep $ do + content <- siteLayoutMsg MsgMenuHealthInterface $ do + setTitleI MsgMenuHealthInterface + [whamlet| +

                        + #{plainMsg} +
                        + ^{iltable} + |] + respond content + + provideRep $ do + respond $ RepPlain $ toContent plainMsg - ^{iltable} - |] - sendResponseStatus (bool internalServerError500 status200 allok) content runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget) From 4a843fe30e35f346ffbe5c0337d69bf319cfeced Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 6 Feb 2024 10:48:54 +0000 Subject: [PATCH 099/110] refactor(health): simplfy code following HealthR handler --- src/Handler/Health/Interface.hs | 23 ++++++++++------------- 1 file changed, 10 insertions(+), 13 deletions(-) diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index 1b6ee1dee..87be63b89 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -68,28 +68,25 @@ matchesUniqueInterfaceHealth (UniqueInterfaceHealth ai as aw) (UniqueInterfaceHe getHealthInterfaceR :: [Text] -> Handler TypedContent -getHealthInterfaceR (dropWhile (=="force") -> ris) = do -- for backwards compatibility we ignore leading "force" +getHealthInterfaceR (dropWhile (=="force") -> ris) = do -- for backwards compatibility we ignore leading "force" let interfs = splitInterfaces $ identifyInterfaces ris (missing, allok, res, iltable) <- runInterfaceLogTable interfs - when missing notFound -- send 404 if any requested interface was not found - let respond = sendResponseStatus (bool internalServerError500 status200 allok) - plainMsg = if allok - then "Interfaces are healthy" - else "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] - selectRep $ do - provideRep $ do - content <- siteLayoutMsg MsgMenuHealthInterface $ do + when missing notFound -- send 404 if any requested interface was not found + let ihstatus = if allok then status200 + else internalServerError500 + plainMsg = if allok then "Interfaces are healthy." + else "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] + sendResponseStatus ihstatus <=< selectRep $ do + provideRep . siteLayoutMsg MsgMenuHealthInterface $ do setTitleI MsgMenuHealthInterface [whamlet|
                        #{plainMsg}
                        ^{iltable} - |] - respond content + |] - provideRep $ do - respond $ RepPlain $ toContent plainMsg + provideRep $ return $ RepPlain $ toContent plainMsg From 2a0bca1230b456eb413842b37f03342b25e49742 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 6 Feb 2024 15:37:00 +0000 Subject: [PATCH 100/110] refactor(health): interface-health - send text/plain by default - attempt to fix negative sub-filters for interface health --- src/Handler/Health/Interface.hs | 20 ++++++++++++-------- src/Model/Migration/Definitions.hs | 4 ++-- 2 files changed, 14 insertions(+), 10 deletions(-) diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index 87be63b89..4e551eb96 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -76,18 +76,16 @@ getHealthInterfaceR (dropWhile (=="force") -> ris) = do -- for bac else internalServerError500 plainMsg = if allok then "Interfaces are healthy." else "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] - sendResponseStatus ihstatus <=< selectRep $ do - provideRep . siteLayoutMsg MsgMenuHealthInterface $ do + sendResponseStatus ihstatus <=< selectRep $ do -- most browsers send accept:text/html, thus text/plain can be default here + provideRep . return . RepPlain $ toContent plainMsg -- /?_accept=text/plain + provideRep . siteLayoutMsg MsgMenuHealthInterface $ do -- /?_accept=text/html setTitleI MsgMenuHealthInterface [whamlet|
                        #{plainMsg}
                        ^{iltable} - |] - - provideRep $ return $ RepPlain $ toContent plainMsg - + |] runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget) @@ -105,6 +103,12 @@ runInterfaceLogTable interfs@(reqIfs,_) = do -- ihDebugShow :: Unique InterfaceHealth -> Text -- ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> tshow s <> tshow w <> ")" +-- | like (=~.) but avoids condition entirely if second argument is Nothing; Note that using =~. with E.val Nothing did not work somehow! +infixl 4 ~~. +(~~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> Maybe typ -> E.SqlExpr (E.Value Bool) +(~~.) a Nothing = E.true +(~~.) a (Just b) = a E.==. E.val b + mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget) mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do -- $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs]) @@ -122,8 +126,8 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do ) let matchUIH crits = E.or [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) - E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.val (sanitize <$> subt) - E.&&. ilog E.^. InterfaceLogWrite E.=~. E.val writ + E.&&. ilog E.^. InterfaceLogSubtype ~~. (sanitize <$> subt) + E.&&. ilog E.^. InterfaceLogWrite ~~. writ | (UniqueInterfaceHealth ifce subt writ) <- crits ] unless (null reqIfs) $ E.where_ $ matchUIH reqIfs diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index a875b9648..e7d34e713 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -125,7 +125,7 @@ migrateAlwaysSafe = do in sql -- unless (tableExists "interface_health") $ do -- [executeQQ| - -- INSERT INTO "interface_health" (interface, subtype, write, hours) + -- INSERT INTO "interface_health" ("interface", "subtype", "write", "hours") -- VALUES -- ('Printer', 'Acknowledge', True, 168) -- , ('AVS' , 'Synch' , True , 96) From 67552a666e2588c1f477eacd5036c09903b2d40e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 6 Feb 2024 15:47:17 +0000 Subject: [PATCH 101/110] refactor(health): optimize sql query, needs tests --- src/Handler/Health/Interface.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index 4e551eb96..e1a523dea 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -130,6 +130,14 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do E.&&. ilog E.^. InterfaceLogWrite ~~. writ | (UniqueInterfaceHealth ifce subt writ) <- crits ] + -- let matchUIH crits = E.or + -- [ E.and $ catMaybes + -- [ Just $ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) + -- , foldMap ((ilog E.^. InterfaceLogSubtype E.==.) . E.val . sanitize) subt + -- , foldMap ((ilog E.^. InterfaceLogWrite E.==.) . E.val ) writ + -- ] + -- | (UniqueInterfaceHealth ifce subt writ) <- crits + -- ] unless (null reqIfs) $ E.where_ $ matchUIH reqIfs unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead From 618c78a69d7db77a745282c63356a936facff70d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 7 Feb 2024 10:23:51 +0100 Subject: [PATCH 102/110] chore(health): examining cause of #155 --- src/Handler/Health/Interface.hs | 39 ++++++++++++++++++--------------- 1 file changed, 21 insertions(+), 18 deletions(-) diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index e1a523dea..42ec567fd 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -100,18 +100,19 @@ runInterfaceLogTable interfs@(reqIfs,_) = do allok = all snd res return (missing, allok, res, twgt) --- ihDebugShow :: Unique InterfaceHealth -> Text --- ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> tshow s <> tshow w <> ")" +ihDebugShow :: Unique InterfaceHealth -> Text +ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> "," <> tshow s <> "," <> tshow w <> ")" +-- NOTE: Using (~~.) instead of ()=~.) -- | like (=~.) but avoids condition entirely if second argument is Nothing; Note that using =~. with E.val Nothing did not work somehow! -infixl 4 ~~. -(~~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> Maybe typ -> E.SqlExpr (E.Value Bool) -(~~.) a Nothing = E.true -(~~.) a (Just b) = a E.==. E.val b +-- infixl 4 ~~. +-- (~~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> Maybe typ -> E.SqlExpr (E.Value Bool) +-- (~~.) _ Nothing = E.true +-- (~~.) a (Just b) = a E.==. E.val b mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget) mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do - -- $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs]) + $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs]) void $ liftHandler $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs now <- liftIO getCurrentTime dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..} @@ -124,22 +125,24 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) ) - let matchUIH crits = E.or - [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) - E.&&. ilog E.^. InterfaceLogSubtype ~~. (sanitize <$> subt) - E.&&. ilog E.^. InterfaceLogWrite ~~. writ - | (UniqueInterfaceHealth ifce subt writ) <- crits - ] + -- let matchUIH crits = E.or + -- [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) + -- E.&&. ilog E.^. InterfaceLogSubtype ~~. (sanitize <$> subt) + -- E.&&. ilog E.^. InterfaceLogWrite ~~. writ + -- | (UniqueInterfaceHealth ifce subt writ) <- crits + -- ] -- let matchUIH crits = E.or -- [ E.and $ catMaybes - -- [ Just $ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) - -- , foldMap ((ilog E.^. InterfaceLogSubtype E.==.) . E.val . sanitize) subt - -- , foldMap ((ilog E.^. InterfaceLogWrite E.==.) . E.val ) writ + -- [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) & Just + -- , (ilog E.^. InterfaceLogSubtype E.==.) . E.val . sanitize <$> subt + -- , (ilog E.^. InterfaceLogWrite E.==.) . E.val <$> writ -- ] -- | (UniqueInterfaceHealth ifce subt writ) <- crits -- ] - unless (null reqIfs) $ E.where_ $ matchUIH reqIfs - unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs + -- unless (null reqIfs) $ E.where_ $ matchUIH reqIfs + -- unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs + E.where_ $ E.not_ (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- NOT OKAY ONLY Printer F SEE ISSUE #155 + -- E.where_ $ ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||. ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F") -- OKAY let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead return (ilog, ihour) From 3303c4eebf928e527d2f9c1eb6e2495c10b94b13 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 7 Feb 2024 10:39:21 +0100 Subject: [PATCH 103/110] fix(health): negative interface routes working as intended now --- src/Handler/Health/Interface.hs | 76 ++++++++++++++------------------- 1 file changed, 31 insertions(+), 45 deletions(-) diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index 42ec567fd..f64ef254f 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -2,8 +2,6 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later -{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -- !!! TODO REMOVE ME - module Handler.Health.Interface ( @@ -62,7 +60,7 @@ splitInterfaces = foldl' aux mempty -- | check whether the first argument is equal or more specialzed (i.e. more Just) than the second matchesUniqueInterfaceHealth :: Unique InterfaceHealth -> Unique InterfaceHealth -> Bool matchesUniqueInterfaceHealth (UniqueInterfaceHealth ai as aw) (UniqueInterfaceHealth bi bs bw) = ai == bi && eqOrNothing as bs && eqOrNothing aw bw - where + where eqOrNothing _ Nothing = True eqOrNothing a b = a == b @@ -72,9 +70,9 @@ getHealthInterfaceR (dropWhile (=="force") -> ris) = do -- for bac let interfs = splitInterfaces $ identifyInterfaces ris (missing, allok, res, iltable) <- runInterfaceLogTable interfs when missing notFound -- send 404 if any requested interface was not found - let ihstatus = if allok then status200 + let ihstatus = if allok then status200 else internalServerError500 - plainMsg = if allok then "Interfaces are healthy." + plainMsg = if allok then "Interfaces are healthy." else "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] sendResponseStatus ihstatus <=< selectRep $ do -- most browsers send accept:text/html, thus text/plain can be default here provideRep . return . RepPlain $ toContent plainMsg -- /?_accept=text/plain @@ -100,19 +98,12 @@ runInterfaceLogTable interfs@(reqIfs,_) = do allok = all snd res return (missing, allok, res, twgt) -ihDebugShow :: Unique InterfaceHealth -> Text -ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> "," <> tshow s <> "," <> tshow w <> ")" - --- NOTE: Using (~~.) instead of ()=~.) --- | like (=~.) but avoids condition entirely if second argument is Nothing; Note that using =~. with E.val Nothing did not work somehow! --- infixl 4 ~~. --- (~~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> Maybe typ -> E.SqlExpr (E.Value Bool) --- (~~.) _ Nothing = E.true --- (~~.) a (Just b) = a E.==. E.val b +-- ihDebugShow :: Unique InterfaceHealth -> Text +-- ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> "," <> tshow s <> "," <> tshow w <> ")" mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget) mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do - $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs]) + -- $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs]) void $ liftHandler $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs now <- liftIO getCurrentTime dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..} @@ -122,27 +113,30 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do dbtProj = dbtProjId dbtSQLQuery (ilog `E.LeftOuterJoin` ihealth) = do EL.on ( ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface - E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) - E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) + E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) + E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) ) - -- let matchUIH crits = E.or - -- [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) - -- E.&&. ilog E.^. InterfaceLogSubtype ~~. (sanitize <$> subt) - -- E.&&. ilog E.^. InterfaceLogWrite ~~. writ - -- | (UniqueInterfaceHealth ifce subt writ) <- crits - -- ] - -- let matchUIH crits = E.or - -- [ E.and $ catMaybes - -- [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) & Just - -- , (ilog E.^. InterfaceLogSubtype E.==.) . E.val . sanitize <$> subt - -- , (ilog E.^. InterfaceLogWrite E.==.) . E.val <$> writ - -- ] - -- | (UniqueInterfaceHealth ifce subt writ) <- crits - -- ] - -- unless (null reqIfs) $ E.where_ $ matchUIH reqIfs - -- unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs - E.where_ $ E.not_ (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- NOT OKAY ONLY Printer F SEE ISSUE #155 - -- E.where_ $ ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||. ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F") -- OKAY + let matchUIH crits = E.or + [ E.and $ catMaybes + [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) & Just + , (ilog E.^. InterfaceLogSubtype E.==.) . E.val . sanitize <$> subt + , (ilog E.^. InterfaceLogWrite E.==.) . E.val <$> writ + ] + | (UniqueInterfaceHealth ifce subt writ) <- crits + ] + matchUIHnot crits = E.and + [ E.or $ catMaybes + [ ilog E.^. InterfaceLogInterface E.!=. E.val (sanitize ifce) & Just + , (ilog E.^. InterfaceLogSubtype E.!=.) . E.val . sanitize <$> subt + , (ilog E.^. InterfaceLogWrite E.!=.) . E.val <$> writ + ] + | (UniqueInterfaceHealth ifce subt writ) <- crits + ] + unless (null reqIfs) $ E.where_ $ matchUIH reqIfs + unless (null banIfs) $ E.where_ $ matchUIHnot banIfs + -- unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs -- !!! DOES NOT WORK !!! Yields strange results, see #155 + -- E.where_ $ E.not_ (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- BAD All missing, except for "Printer" "F" + -- E.where_ $ ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||. ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F") -- OKAY let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead return (ilog, ihour) @@ -211,14 +205,6 @@ maybeRunCheck (reqIfs,banIfs) uih act act $ addHours (negate $ interfaceHealthHours $ entityVal eih) now | otherwise = return () --- maybeRunCheck :: Unique InterfaceHealth -> (Int -> DB ()) -> DB () --- maybeRunCheck uih act = maybeM (return ()) (act . interfaceHealthHours . entityVal) $ getBy uih - -- maybeRunCheck uih act = getBy uih >>= flip whenIsJust (act . interfaceHealthHours . entityVal) - -- where - -- ih2hours :: Entity InterfaceHealth -> Int - -- -- ih2hours Entity{entityVal=InterfaceHealth{interfaceHealthHours=h}} = h - -- ih2hours = interfaceHealthHours . entityVal - lprAckCheck :: ReqBanInterfaceHealth -> DB () lprAckCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "Printer" (Just "Acknowledge") (Just True)) $ \cutOffOldTime -> do @@ -227,10 +213,10 @@ lprAckCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "Printer" (Ju then mkLog False (Just $ length unproc) "Long unprocessed APC-Idents exist" else do oks <- E.deleteWhereCount [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. True] - if oks > 0 + if oks > 0 then mkLog True (Just $ fromIntegral oks) "Long processed APC-Idents removed" else mkLog True Nothing mempty - where + where mkLog = logInterface' "Printer" "Acknowledge" True From 263894b05899ce55635d790f5334729fbc655ecc Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 7 Feb 2024 12:43:39 +0100 Subject: [PATCH 104/110] fix(lms): previouly failed notifications will be sent again --- src/Jobs/Handler/LMS.hs | 5 +++-- src/Jobs/Types.hs | 4 +++- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 12ab943f2..013f849b7 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -313,7 +313,8 @@ dispatchJobLmsReports qid = JobHandlerAtomic act E.&&. lreport E.^. LmsReportLock E.==. E.true ) -- B) notify all newly reported users that lms is available - let luserFltrNew luser = E.isNothing $ luser E.^. LmsUserReceived -- not seen before, just starting + let luserFltrNew luser = E.isNothing (luser E.^. LmsUserReceived) -- not seen before, just starting + E.||. E.isNothing (luser E.^. LmsUserNotified) -- a previous notification has failed notifyNewLearner (E.Value uid) = queueDBJob JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } } in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner -- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit), notified during expiry diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index dc8e04120..69ad6b4d6 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -375,6 +375,8 @@ jobNoQueueSame = \case notifyNoQueueSame :: Notification -> Maybe JobNoQueueSame notifyNoQueueSame = \case NotificationQualificationRenewal{} -> Just JobNoQueueSame -- send one at once; safe, since the job is rescheduled if sending was not acknowledged + NotificationQualificationExpiry{} -> Just JobNoQueueSame -- do not send multiple expiry messages to the same person at once + NotificationQualificationExpired{} -> Just JobNoQueueSame _ -> Nothing jobMovable :: JobCtl -> Bool From 57f5cac75af6a0d96f3216fcfbd0446d98f44345 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 8 Feb 2024 20:51:43 +0100 Subject: [PATCH 105/110] chore(release): 27.4.58 --- CHANGELOG.md | 8 ++++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 12 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index a09ca5698..1ff23608e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,14 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [27.4.58](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.57...v27.4.58) (2024-02-08) + + +### Bug Fixes + +* **health:** negative interface routes working as intended now ([3303c4e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3303c4eebf928e527d2f9c1eb6e2495c10b94b13)) +* **lms:** previouly failed notifications will be sent again ([263894b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/263894b05899ce55635d790f5334729fbc655ecc)) + ## [27.4.57](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.56...v27.4.57) (2024-02-06) diff --git a/nix/docker/version.json b/nix/docker/version.json index 2bc1d589a..0f6ee116f 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.57" + "version": "27.4.58" } diff --git a/package-lock.json b/package-lock.json index 769a5b181..16f8bd6f6 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.57", + "version": "27.4.58", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index d92518019..2eac33199 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.57", + "version": "27.4.58", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index f22cd7d97..9e9579f42 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.57 +version: 27.4.58 dependencies: - base - yesod From e2be8bbd5c82fd8a68187ee6bea4ab49e2980797 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 12 Feb 2024 11:30:54 +0100 Subject: [PATCH 106/110] chore(sql): examine #155 --- src/Database/Esqueleto/Utils.hs | 3 ++- src/Handler/Health/Interface.hs | 4 +++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 8a0a02a17..c0b80448e 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -17,6 +17,7 @@ module Database.Esqueleto.Utils , (>~.), (<~.) , or, and , any, all + -- , parens , subSelectAnd, subSelectOr , mkExactFilter, mkExactFilterWith, mkExactFilterWithComma , mkExactFilterLast, mkExactFilterLastWith diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index f64ef254f..c530b43c5 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -135,8 +135,10 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do unless (null reqIfs) $ E.where_ $ matchUIH reqIfs unless (null banIfs) $ E.where_ $ matchUIHnot banIfs -- unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs -- !!! DOES NOT WORK !!! Yields strange results, see #155 + -- unless (null banIfs) $ E.where_ $ E.not_ $ E.parens $ matchUIH banIfs -- WORKS OKAY -- E.where_ $ E.not_ (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- BAD All missing, except for "Printer" "F" - -- E.where_ $ ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||. ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F") -- OKAY + -- E.where_ $ E.not_ $ E.parens (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- WORKS OKAY + -- E.where_ $ ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||. ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F") -- WORKS OKAY let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead return (ilog, ihour) From 42695cf5ef9f21691dc027f1ec97d57eec72f03e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 12 Feb 2024 11:56:31 +0100 Subject: [PATCH 107/110] fix(sql): remove potential bug in relation to missing parenthesis after not_ --- src/Database/Esqueleto/Utils.hs | 5 ++++- src/Handler/Utils/Users.hs | 2 +- src/Jobs/Handler/LMS.hs | 4 ++-- 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index c0b80448e..127e0ed88 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -17,7 +17,7 @@ module Database.Esqueleto.Utils , (>~.), (<~.) , or, and , any, all - -- , parens + , not__, parens , subSelectAnd, subSelectOr , mkExactFilter, mkExactFilterWith, mkExactFilterWithComma , mkExactFilterLast, mkExactFilterLastWith @@ -253,6 +253,9 @@ subSelectOr q = parens . E.subSelectUnsafe $ flip (E.unsafeSqlAggregateFunction parens :: E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) parens = E.unsafeSqlFunction "" +-- | Workaround for Esqueleto-Bug not placing parenthesis after NOT, see #155 +not__ :: E.SqlExpr (E.Value Bool) -> E.SqlExpr (E.Value Bool) +not__ = E.not_ . parens -- Allow usage of Tuples as DbtRowKey, i.e. SqlIn instances for tuples $(sqlInTuples [2..16]) diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 5c85c9c73..e281c7fcf 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -189,7 +189,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) containsAsSet x y = E.and . map (\y' -> x `E.hasInfix` E.val y') $ asWords y - toSql user pl = bool id E.not_ (is _PLNegated pl) $ case pl ^. _plVar of + toSql user pl = bool id E.not__ (is _PLNegated pl) $ case pl ^. _plVar of GuessUserMatrikelnummer userMatriculation' -> user E.^. UserMatrikelnummer E.==. E.val (Just userMatriculation') GuessUserEduPersonPrincipalName userEPPN' -> user E.^. UserLdapPrimaryKey E.==. E.val (Just userEPPN') GuessUserDisplayName userDisplayName' -> user E.^. UserDisplayName `containsAsSet` userDisplayName' diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 013f849b7..136ea518e 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -202,7 +202,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act -- E.&&. luser E.?. LmsUserQualification E.?=. E.val qid -- E.&&. E.isNothing (luser E.^. LmsUserStatus) -- E.&&. E.isNothing (luser E.^. LmsUserEnded) - E.&&. E.not_ (validQualification now quser) + E.&&. E.not__ (validQualification now quser) pure (luser E.?. LmsUserId, quser E.^. QualificationUserUser) nrBlocked <- qualificationUserBlocking qid (E.unValue . snd <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once let expiredLearners = [ luid | (E.Value (Just luid), _) <- expiredUsers ] @@ -223,7 +223,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act `E.on` (\(quser :& qblock) -> qblock E.?. QualificationUserBlockQualificationUser E.?=. quser E.^. QualificationUserId E.&&. qblock `isLatestBlockBefore` E.val now ) - E.where_ $ -- E.not_ (validQualification now quser) -- currently invalid + E.where_ $ -- E.not__ (validQualification now quser) -- currently invalid quser E.^. QualificationUserQualification E.==. E.val qid -- correct qualification E.&&. quserToNotify now quser qblock -- recently became invalid or blocked pure (quser E.^. QualificationUserUser) From 192c7337491fca7092499331efe3f88e8cf682c4 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 12 Feb 2024 18:30:07 +0100 Subject: [PATCH 108/110] chore(health): migration for health defaults --- src/Model/Migration/Definitions.hs | 28 ++++++++++++++++++++-------- 1 file changed, 20 insertions(+), 8 deletions(-) diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index e7d34e713..ab0147ff4 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -49,6 +49,7 @@ import qualified Data.Time.Zones as TZ data ManualMigration = Migration20230524QualificationUserBlock | Migration20230703LmsUserStatus + | Migration20240212InitInterfaceHealth -- create table interface_health and fill with default values deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) deriving anyclass (Universe, Finite) @@ -123,14 +124,6 @@ migrateAlwaysSafe = do let itemDay = Map.findWithDefault today item changelogItemDays return [st|('#{toPathPiece item}', '#{iso8601Show itemDay}')|] in sql - -- unless (tableExists "interface_health") $ do - -- [executeQQ| - -- INSERT INTO "interface_health" ("interface", "subtype", "write", "hours") - -- VALUES - -- ('Printer', 'Acknowledge', True, 168) - -- , ('AVS' , 'Synch' , True , 96) - -- ON CONFLICT DO NOTHING; - -- |] {- Confusion about quotes, from the PostgreSQL Manual: @@ -185,6 +178,25 @@ customMigrations = mapF $ \case ; |] + Migration20240212InitInterfaceHealth -> + unlessM (tableExists "interface_health") $ do -- fill health table with some defaults + [executeQQ| + CREATE TABLE "interface_health" + ( id BIGSERIAL NOT NULL + , interface CHARACTER VARYING NOT NULL + , subtype CHARACTER VARYING + , write BOOLEAN + , hours BIGINT NOT NULL + , PRIMARY KEY(id) + , CONSTRAINT unique_interface_health UNIQUE(interface, subtype, write) + ); + INSERT INTO "interface_health" ("interface", "subtype", "write", "hours") + VALUES + ('Printer', 'Acknowledge', True, 168) + , ('AVS' , 'Synch' , True , 96) + ON CONFLICT DO NOTHING; + |] + tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool tableExists table = do From ae9be9e2856ed84d938ff21a39cc5161a7963ac4 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 13 Feb 2024 21:15:49 +0000 Subject: [PATCH 109/110] chore(release): 27.4.59 --- CHANGELOG.md | 7 +++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 11 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 1ff23608e..bb7fd8e96 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [27.4.59](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.58...v27.4.59) (2024-02-13) + + +### Bug Fixes + +* **sql:** remove potential bug in relation to missing parenthesis after not_ ([42695cf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/42695cf5ef9f21691dc027f1ec97d57eec72f03e)) + ## [27.4.58](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.57...v27.4.58) (2024-02-08) diff --git a/nix/docker/version.json b/nix/docker/version.json index 0f6ee116f..450e150fd 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.58" + "version": "27.4.59" } diff --git a/package-lock.json b/package-lock.json index 16f8bd6f6..8baaeafcc 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.58", + "version": "27.4.59", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 2eac33199..8c360c1e7 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.58", + "version": "27.4.59", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 9e9579f42..2c242b3b3 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.58 +version: 27.4.59 dependencies: - base - yesod From d4f8a6c77b2a4a4540935f7f0beca0d0605508c8 Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 21 Feb 2024 08:24:32 +0100 Subject: [PATCH 110/110] fix(doc): minor haddock problems --- src/Handler/Course/ParticipantInvite.hs | 2 +- src/Handler/Health/Interface.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 30daf6f19..53eff795d 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -193,7 +193,7 @@ handleAddUserR tid ssh csh tdesc ttyp = do currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute (_ , registerConfirmResult) <- runButtonForm FIDCourseRegisterConfirm - -- $logDebugS "***AbortProblem***" $ tshow registerConfirmResult + -- $logDebugS "***AbortProblem***" $ tshow registerConfirmResult prefillUsers <- case registerConfirmResult of Nothing -> return mempty (Just BtnCourseRegisterAbort) -> do diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index c530b43c5..7dbc96932 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -103,7 +103,7 @@ runInterfaceLogTable interfs@(reqIfs,_) = do mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget) mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do - -- $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs]) + -- $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs]) void $ liftHandler $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs now <- liftIO getCurrentTime dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..}