From 747d6198c4efdafab009012dc46ed65b02303a38 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 24 Nov 2022 18:38:22 +0100 Subject: [PATCH 01/65] feat(avs): add page-action and form handler for registering avs participants --- .../courses/courses/de-de-formal.msg | 6 +++ .../categories/courses/courses/en-eu.msg | 6 +++ .../navigation/breadcrumbs/de-de-formal.msg | 1 + .../utils/navigation/breadcrumbs/en-eu.msg | 1 + .../utils/navigation/menu/de-de-formal.msg | 2 + .../uniworx/utils/navigation/menu/en-eu.msg | 2 + routes | 2 + src/Foundation/Navigation.hs | 45 ++++++++++++++++ src/Foundation/Routes.hs | 3 ++ src/Handler/Course.hs | 1 + src/Handler/Course/Avs.hs | 53 +++++++++++++++++++ 11 files changed, 122 insertions(+) create mode 100644 src/Handler/Course/Avs.hs diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index 80d5f42b0..f0012dbe0 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -286,3 +286,9 @@ CourseExamRegistrationTime: Angemeldet seit CourseParticipantStateIsActiveFilter: Ansicht CourseApply: Zum Kurs bewerben CourseAdministrator: Kursadministrator:in + +CourseAvsRegisterTitle: Teilnehmer:innen anmelden +CourseAvsRegisterParticipants: Teilnehmer:innen +CourseAvsRegisterParticipantsTip: Mehrere Teilnehmer:innen mit Komma separieren +CourseAvsRegisterCreateTutorial: Teilnehmer:innen in Tagesgruppe eintragen +CourseAvsRegisterTutorialDay: Tag diff --git a/messages/uniworx/categories/courses/courses/en-eu.msg b/messages/uniworx/categories/courses/courses/en-eu.msg index a7e8abbc5..d99c81ffd 100644 --- a/messages/uniworx/categories/courses/courses/en-eu.msg +++ b/messages/uniworx/categories/courses/courses/en-eu.msg @@ -285,3 +285,9 @@ CourseExamRegistrationTime: Registered since CourseParticipantStateIsActiveFilter: View CourseApply: Apply for course CourseAdministrator: Course administrator + +CourseAvsRegisterTitle: Register participants +CourseAvsRegisterParticipants: Participants +CourseAvsRegisterParticipantsTip: Separate multiple participants with comma +CourseAvsRegisterCreateTutorial: Add participants to day group +CourseAvsRegisterTutorialDay: Day diff --git a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg index 2552a6418..059524d1e 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg @@ -137,6 +137,7 @@ BreadcrumbCourseEventEdit: Kurstermin bearbeiten BreadcrumbExamList: Prüfungen BreadcrumbExamNew: Neue Prüfung anlegen BreadcrumbCourseApplications: Bewerbungen +BreadcrumbCourseAvsRegister: AVS-Teilnehmer:innen anmelden BreadcrumbExamEdit: Prüfung bearbeiten BreadcrumbExamUsers: Teilnehmer:innen BreadcrumbExamGrades: Prüfungsleistungen diff --git a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg index 2c8f601c5..ce41cf679 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg @@ -131,6 +131,7 @@ BreadcrumbCourseNewsNew: Add course news BreadcrumbCourseNewsEdit: Edit course news BreadcrumbCourseEventNew: New course occurrence BreadcrumbCourseEventEdit: Edit course occurrence +BreadcrumbCourseAvsRegister: Register AVS participants BreadcrumbExamList: Exams BreadcrumbExamNew: Create new exam BreadcrumbCourseApplications: Applications diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 803e46860..091a28614 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -147,5 +147,7 @@ MenuApc: Druckerei MenuPrintSend: Manueller Briefversand MenuPrintDownload: Brief herunterladen +MenuCourseAvsRegister: AVS-Teilnehmer:innen anmelden + MenuApiDocs: API-Dokumentation (Englisch) MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger) \ No newline at end of file diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 73f58d1f3..3f9ca4ee8 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -148,5 +148,7 @@ MenuApc: Printing MenuPrintSend: Send Letter MenuPrintDownload: Download Letter +MenuCourseAvsRegister: Register AVS participants + MenuApiDocs: API documentation MenuSwagger: OpenAPI 2.0 (Swagger) diff --git a/routes b/routes index 435ca94d3..09531b5bd 100644 --- a/routes +++ b/routes @@ -176,6 +176,8 @@ !/users/new CAddUserR GET POST !lecturerANDallocation-time !/users/invite CInviteR GET POST /users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant !lecturerANDapplicant + /avs CAvsR: + /register CAvsRegisterR GET POST !lecturer /correctors CHiWisR GET /communication CCommR GET POST /notes CNotesR GET POST !corrector -- THIS route is used to check for overall course corrector access! diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index b17708671..472547818 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -250,6 +250,7 @@ breadcrumb (CourseR tid ssh csh CEditR) = i18nCrumb MsgMenuCourseEdit . Just breadcrumb (CourseR tid ssh csh CUsersR) = i18nCrumb MsgMenuCourseMembers . Just $ CourseR tid ssh csh CShowR breadcrumb (CourseR tid ssh csh CAddUserR) = i18nCrumb MsgMenuCourseAddMembers . Just $ CourseR tid ssh csh CUsersR breadcrumb (CourseR tid ssh csh CInviteR) = i18nCrumb MsgBreadcrumbCourseParticipantInvitation . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh (CAvsR CAvsRegisterR)) = i18nCrumb MsgBreadcrumbCourseAvsRegister . Just $ CourseR tid ssh csh CUsersR breadcrumb (CourseR tid ssh csh CExamOfficeR) = i18nCrumb MsgMenuCourseExamOffice . Just $ CourseR tid ssh csh CShowR breadcrumb (CourseR tid ssh csh (CUserR cID)) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbUser . Just $ CourseR tid ssh csh CUsersR) $ do guardM . lift . hasReadAccessTo . CourseR tid ssh csh $ CUserR cID @@ -985,6 +986,17 @@ pageActions (CourseR tid ssh csh CShowR) = do return $ [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCourseAvsRegister + , navRoute = CourseR tid ssh csh $ CAvsR CAvsRegisterR + , navAccess' = NavAccessDB . hasWriteAccessTo . CourseR tid ssh csh $ CAvsR CAvsRegisterR + , navType = NavTypeLink { navModal = True } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = mempty + } + , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuMaterialList , navRoute = CourseR tid ssh csh MaterialListR @@ -1717,6 +1729,17 @@ pageActions (CourseR tid ssh csh SheetListR) = do ] pageActions (CourseR tid ssh csh CUsersR) = return [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCourseAvsRegister + , navRoute = CourseR tid ssh csh $ CAvsR CAvsRegisterR + , navAccess' = NavAccessDB . hasWriteAccessTo . CourseR tid ssh csh $ CAvsR CAvsRegisterR + , navType = NavTypeLink { navModal = True } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = mempty + } + , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuCourseAddMembers , navRoute = CourseR tid ssh csh CAddUserR @@ -1791,6 +1814,17 @@ pageActions (CMaterialR tid ssh csh mnm MShowR) = return ] pageActions (CourseR tid ssh csh CTutorialListR) = return [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCourseAvsRegister + , navRoute = CourseR tid ssh csh $ CAvsR CAvsRegisterR + , navAccess' = NavAccessDB . hasWriteAccessTo . CourseR tid ssh csh $ CAvsR CAvsRegisterR + , navType = NavTypeLink { navModal = True } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = mempty + } + , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuTutorialNew , navRoute = CourseR tid ssh csh CTutorialNewR @@ -1837,6 +1871,17 @@ pageActions (CTutorialR tid ssh csh tutn TUsersR) = return } , navChildren = [] } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCourseAvsRegister + , navRoute = CourseR tid ssh csh $ CAvsR CAvsRegisterR + , navAccess' = NavAccessDB . hasWriteAccessTo . CourseR tid ssh csh $ CAvsR CAvsRegisterR + , navType = NavTypeLink { navModal = True } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = mempty + } , NavPageActionSecondary { navLink = NavLink { navLabel = MsgMenuTutorialDelete diff --git a/src/Foundation/Routes.hs b/src/Foundation/Routes.hs index a6ce7b7fd..6ece00b0b 100644 --- a/src/Foundation/Routes.hs +++ b/src/Foundation/Routes.hs @@ -34,6 +34,7 @@ import ServantApi.ExternalApis.Type mkYesodData "UniWorX" uniworxRoutes deriving instance Generic CourseR +deriving instance Generic CAvsR deriving instance Generic SheetR deriving instance Generic SubmissionR deriving instance Generic MaterialR @@ -51,6 +52,7 @@ deriving instance Generic (Route UniWorX) instance Hashable CourseR +instance Hashable CAvsR instance Hashable SheetR instance Hashable SubmissionR instance Hashable MaterialR @@ -76,6 +78,7 @@ instance Ord (Route EmbeddedStatic) where compare = compare `on` renderRoute deriving instance Ord CourseR +deriving instance Ord CAvsR deriving instance Ord SheetR deriving instance Ord SubmissionR deriving instance Ord MaterialR diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 5786e3566..1efd5a085 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -11,6 +11,7 @@ import Import import qualified Database.Esqueleto.Legacy as E import qualified Database.Persist as P +import Handler.Course.Avs as Handler.Course import Handler.Course.Communication as Handler.Course import Handler.Course.Delete as Handler.Course import Handler.Course.Edit as Handler.Course diff --git a/src/Handler/Course/Avs.hs b/src/Handler/Course/Avs.hs new file mode 100644 index 000000000..fbc20efc1 --- /dev/null +++ b/src/Handler/Course/Avs.hs @@ -0,0 +1,53 @@ +-- SPDX-FileCopyrightText: 2022 Sarah Vaupel +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +module Handler.Course.Avs + ( getCAvsRegisterR, postCAvsRegisterR + ) where + +import Import + +import Handler.Utils + +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Time.Zones as TZ + + +data CourseAvsRegisterForm = CourseAvsRegisterForm + { cavsregParticipants :: Set Text -- TODO: NonEmpty + , cavsregTutorial :: Maybe Day + } + deriving (Eq, Ord, Show, Read, Generic, Typeable) + +makeLenses_ ''CourseAvsRegisterForm + +courseAvsRegisterForm :: Maybe CourseAvsRegisterForm -> AForm Handler CourseAvsRegisterForm +courseAvsRegisterForm template = wFormToAForm $ do + today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime + + let + cfCommaSeparatedSet :: forall m. Functor m => Field m Text -> Field m (Set Text) + cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.splitOn ",") (Text.intercalate ", " . Set.toList) + + aFormToWForm $ CourseAvsRegisterForm + <$> areq (textField & cfCommaSeparatedSet) (fslI MsgCourseAvsRegisterParticipants & setTooltip MsgCourseAvsRegisterParticipantsTip) (cavsregParticipants <$> template) + <*> optionalActionA + ( areq dayField (fslI MsgCourseAvsRegisterTutorialDay) (Just . fromMaybe today . join $ cavsregTutorial <$> template) + ) + (fslI MsgCourseAvsRegisterCreateTutorial) (is _Just . cavsregTutorial <$> template) + + +getCAvsRegisterR, postCAvsRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCAvsRegisterR = postCAvsRegisterR +postCAvsRegisterR _tid _ssh _csh = do + ((_result, formView), formEnctype) <- runFormPost . renderAForm FormStandard $ courseAvsRegisterForm Nothing + + -- TODO: process result + + defaultLayout $ do + setTitleI MsgCourseAvsRegisterTitle + wrapForm formView def + { formEncoding = formEnctype + } From 64d3ceb56d4a7ce09d7760c7452f48e12b182070 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 24 Nov 2022 18:51:00 +0100 Subject: [PATCH 02/65] feat(avs): register course participants for day groups per default --- src/Handler/Course/Avs.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Course/Avs.hs b/src/Handler/Course/Avs.hs index fbc20efc1..dc4bfe53f 100644 --- a/src/Handler/Course/Avs.hs +++ b/src/Handler/Course/Avs.hs @@ -36,7 +36,7 @@ courseAvsRegisterForm template = wFormToAForm $ do <*> optionalActionA ( areq dayField (fslI MsgCourseAvsRegisterTutorialDay) (Just . fromMaybe today . join $ cavsregTutorial <$> template) ) - (fslI MsgCourseAvsRegisterCreateTutorial) (is _Just . cavsregTutorial <$> template) + (fslI MsgCourseAvsRegisterCreateTutorial) ((is _Just . cavsregTutorial <$> template) <|> Just True) getCAvsRegisterR, postCAvsRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html From 5ef36f1d1c0bd92773bbb58af417bae8307a3610 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 24 Nov 2022 18:57:55 +0100 Subject: [PATCH 03/65] fix(routes): remove redundant auth tag --- routes | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/routes b/routes index 09531b5bd..cb840852e 100644 --- a/routes +++ b/routes @@ -177,7 +177,7 @@ !/users/invite CInviteR GET POST /users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant !lecturerANDapplicant /avs CAvsR: - /register CAvsRegisterR GET POST !lecturer + /register CAvsRegisterR GET POST /correctors CHiWisR GET /communication CCommR GET POST /notes CNotesR GET POST !corrector -- THIS route is used to check for overall course corrector access! From 4a00907bdad26208329080ad87fe52daa33775ff Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Mon, 28 Nov 2022 19:55:14 +0100 Subject: [PATCH 04/65] feat(course-users): fuse avs register form with CAddUserR --- .../navigation/breadcrumbs/de-de-formal.msg | 1 - .../utils/navigation/breadcrumbs/en-eu.msg | 1 - .../utils/navigation/menu/de-de-formal.msg | 2 - .../uniworx/utils/navigation/menu/en-eu.msg | 2 - routes | 2 - src/Foundation/Navigation.hs | 45 ---------------- src/Foundation/Routes.hs | 3 -- src/Handler/Course.hs | 1 - src/Handler/Course/Avs.hs | 53 ------------------- src/Handler/Course/ParticipantInvite.hs | 46 ++++++++++++---- 10 files changed, 35 insertions(+), 121 deletions(-) delete mode 100644 src/Handler/Course/Avs.hs diff --git a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg index 059524d1e..2552a6418 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg @@ -137,7 +137,6 @@ BreadcrumbCourseEventEdit: Kurstermin bearbeiten BreadcrumbExamList: Prüfungen BreadcrumbExamNew: Neue Prüfung anlegen BreadcrumbCourseApplications: Bewerbungen -BreadcrumbCourseAvsRegister: AVS-Teilnehmer:innen anmelden BreadcrumbExamEdit: Prüfung bearbeiten BreadcrumbExamUsers: Teilnehmer:innen BreadcrumbExamGrades: Prüfungsleistungen diff --git a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg index ce41cf679..2c8f601c5 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg @@ -131,7 +131,6 @@ BreadcrumbCourseNewsNew: Add course news BreadcrumbCourseNewsEdit: Edit course news BreadcrumbCourseEventNew: New course occurrence BreadcrumbCourseEventEdit: Edit course occurrence -BreadcrumbCourseAvsRegister: Register AVS participants BreadcrumbExamList: Exams BreadcrumbExamNew: Create new exam BreadcrumbCourseApplications: Applications diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 091a28614..803e46860 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -147,7 +147,5 @@ MenuApc: Druckerei MenuPrintSend: Manueller Briefversand MenuPrintDownload: Brief herunterladen -MenuCourseAvsRegister: AVS-Teilnehmer:innen anmelden - MenuApiDocs: API-Dokumentation (Englisch) MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger) \ No newline at end of file diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 3f9ca4ee8..73f58d1f3 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -148,7 +148,5 @@ MenuApc: Printing MenuPrintSend: Send Letter MenuPrintDownload: Download Letter -MenuCourseAvsRegister: Register AVS participants - MenuApiDocs: API documentation MenuSwagger: OpenAPI 2.0 (Swagger) diff --git a/routes b/routes index cb840852e..435ca94d3 100644 --- a/routes +++ b/routes @@ -176,8 +176,6 @@ !/users/new CAddUserR GET POST !lecturerANDallocation-time !/users/invite CInviteR GET POST /users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant !lecturerANDapplicant - /avs CAvsR: - /register CAvsRegisterR GET POST /correctors CHiWisR GET /communication CCommR GET POST /notes CNotesR GET POST !corrector -- THIS route is used to check for overall course corrector access! diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 472547818..b17708671 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -250,7 +250,6 @@ breadcrumb (CourseR tid ssh csh CEditR) = i18nCrumb MsgMenuCourseEdit . Just breadcrumb (CourseR tid ssh csh CUsersR) = i18nCrumb MsgMenuCourseMembers . Just $ CourseR tid ssh csh CShowR breadcrumb (CourseR tid ssh csh CAddUserR) = i18nCrumb MsgMenuCourseAddMembers . Just $ CourseR tid ssh csh CUsersR breadcrumb (CourseR tid ssh csh CInviteR) = i18nCrumb MsgBreadcrumbCourseParticipantInvitation . Just $ CourseR tid ssh csh CShowR -breadcrumb (CourseR tid ssh csh (CAvsR CAvsRegisterR)) = i18nCrumb MsgBreadcrumbCourseAvsRegister . Just $ CourseR tid ssh csh CUsersR breadcrumb (CourseR tid ssh csh CExamOfficeR) = i18nCrumb MsgMenuCourseExamOffice . Just $ CourseR tid ssh csh CShowR breadcrumb (CourseR tid ssh csh (CUserR cID)) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbUser . Just $ CourseR tid ssh csh CUsersR) $ do guardM . lift . hasReadAccessTo . CourseR tid ssh csh $ CUserR cID @@ -986,17 +985,6 @@ pageActions (CourseR tid ssh csh CShowR) = do return $ [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuCourseAvsRegister - , navRoute = CourseR tid ssh csh $ CAvsR CAvsRegisterR - , navAccess' = NavAccessDB . hasWriteAccessTo . CourseR tid ssh csh $ CAvsR CAvsRegisterR - , navType = NavTypeLink { navModal = True } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = mempty - } - , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuMaterialList , navRoute = CourseR tid ssh csh MaterialListR @@ -1729,17 +1717,6 @@ pageActions (CourseR tid ssh csh SheetListR) = do ] pageActions (CourseR tid ssh csh CUsersR) = return [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuCourseAvsRegister - , navRoute = CourseR tid ssh csh $ CAvsR CAvsRegisterR - , navAccess' = NavAccessDB . hasWriteAccessTo . CourseR tid ssh csh $ CAvsR CAvsRegisterR - , navType = NavTypeLink { navModal = True } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = mempty - } - , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuCourseAddMembers , navRoute = CourseR tid ssh csh CAddUserR @@ -1814,17 +1791,6 @@ pageActions (CMaterialR tid ssh csh mnm MShowR) = return ] pageActions (CourseR tid ssh csh CTutorialListR) = return [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuCourseAvsRegister - , navRoute = CourseR tid ssh csh $ CAvsR CAvsRegisterR - , navAccess' = NavAccessDB . hasWriteAccessTo . CourseR tid ssh csh $ CAvsR CAvsRegisterR - , navType = NavTypeLink { navModal = True } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = mempty - } - , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuTutorialNew , navRoute = CourseR tid ssh csh CTutorialNewR @@ -1871,17 +1837,6 @@ pageActions (CTutorialR tid ssh csh tutn TUsersR) = return } , navChildren = [] } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuCourseAvsRegister - , navRoute = CourseR tid ssh csh $ CAvsR CAvsRegisterR - , navAccess' = NavAccessDB . hasWriteAccessTo . CourseR tid ssh csh $ CAvsR CAvsRegisterR - , navType = NavTypeLink { navModal = True } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = mempty - } , NavPageActionSecondary { navLink = NavLink { navLabel = MsgMenuTutorialDelete diff --git a/src/Foundation/Routes.hs b/src/Foundation/Routes.hs index 6ece00b0b..a6ce7b7fd 100644 --- a/src/Foundation/Routes.hs +++ b/src/Foundation/Routes.hs @@ -34,7 +34,6 @@ import ServantApi.ExternalApis.Type mkYesodData "UniWorX" uniworxRoutes deriving instance Generic CourseR -deriving instance Generic CAvsR deriving instance Generic SheetR deriving instance Generic SubmissionR deriving instance Generic MaterialR @@ -52,7 +51,6 @@ deriving instance Generic (Route UniWorX) instance Hashable CourseR -instance Hashable CAvsR instance Hashable SheetR instance Hashable SubmissionR instance Hashable MaterialR @@ -78,7 +76,6 @@ instance Ord (Route EmbeddedStatic) where compare = compare `on` renderRoute deriving instance Ord CourseR -deriving instance Ord CAvsR deriving instance Ord SheetR deriving instance Ord SubmissionR deriving instance Ord MaterialR diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 1efd5a085..5786e3566 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -11,7 +11,6 @@ import Import import qualified Database.Esqueleto.Legacy as E import qualified Database.Persist as P -import Handler.Course.Avs as Handler.Course import Handler.Course.Communication as Handler.Course import Handler.Course.Delete as Handler.Course import Handler.Course.Edit as Handler.Course diff --git a/src/Handler/Course/Avs.hs b/src/Handler/Course/Avs.hs deleted file mode 100644 index dc4bfe53f..000000000 --- a/src/Handler/Course/Avs.hs +++ /dev/null @@ -1,53 +0,0 @@ --- SPDX-FileCopyrightText: 2022 Sarah Vaupel --- --- SPDX-License-Identifier: AGPL-3.0-or-later - -module Handler.Course.Avs - ( getCAvsRegisterR, postCAvsRegisterR - ) where - -import Import - -import Handler.Utils - -import qualified Data.Set as Set -import qualified Data.Text as Text -import qualified Data.Time.Zones as TZ - - -data CourseAvsRegisterForm = CourseAvsRegisterForm - { cavsregParticipants :: Set Text -- TODO: NonEmpty - , cavsregTutorial :: Maybe Day - } - deriving (Eq, Ord, Show, Read, Generic, Typeable) - -makeLenses_ ''CourseAvsRegisterForm - -courseAvsRegisterForm :: Maybe CourseAvsRegisterForm -> AForm Handler CourseAvsRegisterForm -courseAvsRegisterForm template = wFormToAForm $ do - today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime - - let - cfCommaSeparatedSet :: forall m. Functor m => Field m Text -> Field m (Set Text) - cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.splitOn ",") (Text.intercalate ", " . Set.toList) - - aFormToWForm $ CourseAvsRegisterForm - <$> areq (textField & cfCommaSeparatedSet) (fslI MsgCourseAvsRegisterParticipants & setTooltip MsgCourseAvsRegisterParticipantsTip) (cavsregParticipants <$> template) - <*> optionalActionA - ( areq dayField (fslI MsgCourseAvsRegisterTutorialDay) (Just . fromMaybe today . join $ cavsregTutorial <$> template) - ) - (fslI MsgCourseAvsRegisterCreateTutorial) ((is _Just . cavsregTutorial <$> template) <|> Just True) - - -getCAvsRegisterR, postCAvsRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getCAvsRegisterR = postCAvsRegisterR -postCAvsRegisterR _tid _ssh _csh = do - ((_result, formView), formEnctype) <- runFormPost . renderAForm FormStandard $ courseAvsRegisterForm Nothing - - -- TODO: process result - - defaultLayout $ do - setTitleI MsgCourseAvsRegisterTitle - wrapForm formView def - { formEncoding = formEnctype - } diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 6f1f83149..fc8d44312 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Winnie Ros +-- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Winnie Ros -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -16,25 +16,48 @@ module Handler.Course.ParticipantInvite import Import -import Utils.Form import Handler.Utils import Handler.Utils.Invitations import Handler.Utils.Course -import qualified Data.CaseInsensitive as CI - -import qualified Data.Set as Set -import qualified Data.Map as Map - import Jobs.Queue -import Data.Aeson hiding (Result(..)) - import Control.Monad.Except (MonadError(..)) +import Data.Aeson hiding (Result(..)) +import qualified Data.CaseInsensitive as CI +import qualified Data.HashSet as HashSet +import qualified Data.Map as Map +import qualified Data.Text as Text +import qualified Data.Time.Zones as TZ +import qualified Data.Set as Set + import Generics.Deriving.Monoid (memptydefault, mappenddefault) -import qualified Data.HashSet as HashSet + +data CourseAvsRegisterForm = CourseAvsRegisterForm + { cavsregParticipants :: Set Text -- TODO: NonEmpty + , cavsregTutorial :: Maybe Day + } + deriving (Eq, Ord, Show, Read, Generic, Typeable) + +makeLenses_ ''CourseAvsRegisterForm + +-- TODO: merge to postCAddUserR +_courseAvsRegisterForm :: Maybe CourseAvsRegisterForm -> AForm Handler CourseAvsRegisterForm +_courseAvsRegisterForm template = wFormToAForm $ do + today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime + + let + cfCommaSeparatedSet :: forall m. Functor m => Field m Text -> Field m (Set Text) + cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.splitOn ",") (Text.intercalate ", " . Set.toList) + + aFormToWForm $ CourseAvsRegisterForm + <$> areq (textField & cfCommaSeparatedSet) (fslI MsgCourseAvsRegisterParticipants & setTooltip MsgCourseAvsRegisterParticipantsTip) (cavsregParticipants <$> template) + <*> optionalActionA + ( areq dayField (fslI MsgCourseAvsRegisterTutorialDay) (Just . fromMaybe today . join $ cavsregTutorial <$> template) + ) + (fslI MsgCourseAvsRegisterCreateTutorial) ((is _Just . cavsregTutorial <$> template) <|> Just True) -- Invitations for ordinary participants of this course @@ -123,6 +146,7 @@ getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler getCAddUserR = postCAddUserR postCAddUserR tid ssh csh = do cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh + ((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do enlist <- wreq checkBoxField (fslI MsgCourseParticipantEnlistDirectly) (Just False) @@ -138,7 +162,6 @@ postCAddUserR tid ssh csh = do formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $ hoist runDBJobs . registerUsers' cid - let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading siteLayoutMsg heading $ do @@ -148,6 +171,7 @@ postCAddUserR tid ssh csh = do , formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR } + registerUsers :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] (YesodJobDB UniWorX) () registerUsers cid = registerUsers' cid . Map.fromSet (const Nothing) From 94300211adcaec253dc143048aab6d1e1af0e8c4 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 29 Nov 2022 18:20:26 +0100 Subject: [PATCH 05/65] minor --- src/Handler/Admin.hs | 17 +++++++++++++++++ src/Handler/Profile.hs | 1 - 2 files changed, 17 insertions(+), 1 deletion(-) diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index e627fbec3..6e430b1b5 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -8,6 +8,9 @@ module Handler.Admin import Import +-- import qualified Database.Esqueleto.Experimental as E +-- import qualified Database.Esqueleto.Utils as E + import Handler.Admin.Test as Handler.Admin import Handler.Admin.ErrorMessage as Handler.Admin import Handler.Admin.Tokens as Handler.Admin @@ -15,8 +18,22 @@ import Handler.Admin.Crontab as Handler.Admin import Handler.Admin.Avs as Handler.Admin import Handler.Admin.Ldap as Handler.Admin + getAdminR :: Handler Html getAdminR = siteLayoutMsg MsgAdminHeading $ do setTitleI MsgAdminHeading i18n MsgAdminPageEmpty + +{- +mkBadAddressTable = do + let dbtSQLQuery user -> do + E.where_ $ E.isNothing (user E.^. UserPostAddress) + E.&&. E.not ((user E.^. UserEmail) `E.like` E.val "%@%.%") + pure user + dbtRowKey = (E.^. UserId) + dbtProj = dbtProjFilteredPostId -- TODO: still don't understand the choices here + dbtColonnade = +-} + + \ No newline at end of file diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 7c8660ee2..8e30ae3e4 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -1002,7 +1002,6 @@ mkCorrectionsTable = in dbTableWidget' validator DBTable{..} - -- | Table listing all qualifications that the given user is enrolled in mkQualificationsTable :: UserId -> DB Widget mkQualificationsTable = From ddc71d7fd06e3cc86e476999d9a277a8f95bd7ad Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Sun, 4 Dec 2022 19:13:39 +0100 Subject: [PATCH 06/65] chore(add-users): remove invite functionality, implement avs form stub --- .../courses/courses/de-de-formal.msg | 10 +- .../categories/courses/courses/en-eu.msg | 8 + routes | 1 - src/Foundation/Navigation.hs | 1 - src/Handler/Course/ParticipantInvite.hs | 205 +++++------------- 5 files changed, 67 insertions(+), 158 deletions(-) diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index f0012dbe0..33609c82d 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -107,8 +107,16 @@ CourseParticipantInvitationAccepted courseName@Text: Sie wurden als Teilnehmer:i CourseParticipantEnlistDirectly: Bekannte Nutzer:innen sofort als Teilnehmer:in eintragen CourseSubmissionGroup: Feste Abgabegruppe SubmissionGroupEmptyIsUnsetTip: Leer lassen um Benutzer:innen aus den jeweiligen Abgabegruppen ersatzlos zu entfernen -CourseParticipantsRegisterHeading: Kursteilnehmer :innen hinzufügen +CourseParticipantsRegisterHeading: Kursteilnehmer:innen hinzufügen +CourseParticipantsRegisterUsersField: Zum Kurs anzumeldende Personen +CourseParticipantsRegisterUsersFieldTip: Bitte Personalnummer angeben. Mehrere Personen bitte mit Komma getrennt angeben. +CourseParticipantsRegisterTutorialOption: Kursteilnehmer:innen zu Übungsgruppe anmelden? +CourseParticipantsRegisterTutorialField: Übungsgruppe +CourseParticipantsRegisterTutorialFieldTip: Ist aktuell keine Übungsgruppe mit diesem Namen vorhanden, wird eine neue erstellt. Ist bereits eine Übungsgruppe mit diesem Namen vorhanden, werden die Kursteilnehmenden dieser hinzugefügt. +CourseParticipantsRegisterNoneGiven: Es wurden keine anzumeldenden Personen angegeben! + CourseParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt +CourseParticipantsAddedByAvs n@Int: #{n} AVS-Nutzer erfolgreich angemeldet (TODO) CourseParticipantsAlreadyRegistered n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} #{pluralDE n "ist" "sind"} bereits angemeldet CourseParticipantsRegistered n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} erfolgreich angemeldet CourseApplicationText: Text-Bewerbung diff --git a/messages/uniworx/categories/courses/courses/en-eu.msg b/messages/uniworx/categories/courses/courses/en-eu.msg index d99c81ffd..40e1ff960 100644 --- a/messages/uniworx/categories/courses/courses/en-eu.msg +++ b/messages/uniworx/categories/courses/courses/en-eu.msg @@ -108,7 +108,15 @@ CourseParticipantEnlistDirectly: Enrol known users directly CourseSubmissionGroup: Registered submission group SubmissionGroupEmptyIsUnsetTip: Leave empty to remove users from their respective submission groups CourseParticipantsRegisterHeading: Add course participants +CourseParticipantsRegisterUsersField: Persons to register for course +CourseParticipantsRegisterUsersFieldTip: Please enter personal number. Please separate multiple entries with commas. +CourseParticipantsRegisterTutorialOption: Register course participants for tutorial? +CourseParticipantsRegisterTutorialField: Tutorial +CourseParticipantsRegisterTutorialFieldTip: If there is no tutorial with this name, a new one will be created. If there is a tutorial with this name, the course participants will be registered for it. +CourseParticipantsRegisterNoneGiven: No persons given to register! + CourseParticipantsInvited n: #{n} #{pluralEN n "invitation" "invitations"} sent via email +CourseParticipantsAddedByAvs n: #{n} AVS users successfully registered (TODO) CourseParticipantsAlreadyRegistered n: #{n} #{pluralEN n "participant is" "participants are"} already enrolled CourseParticipantsRegistered n: Successfully registered #{n} #{pluralEN n "participant" "participants"} CourseApplicationText: Application text diff --git a/routes b/routes index 435ca94d3..09ef362ad 100644 --- a/routes +++ b/routes @@ -174,7 +174,6 @@ /delete CDeleteR GET POST !lecturerANDemptyANDallocation-time /users CUsersR GET POST !/users/new CAddUserR GET POST !lecturerANDallocation-time - !/users/invite CInviteR GET POST /users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant !lecturerANDapplicant /correctors CHiWisR GET /communication CCommR GET POST diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index b17708671..de957e320 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -249,7 +249,6 @@ breadcrumb (CourseR tid ssh csh CShowR) = useRunDB . maybeT (i18nCrumb MsgBreadc breadcrumb (CourseR tid ssh csh CEditR) = i18nCrumb MsgMenuCourseEdit . Just $ CourseR tid ssh csh CShowR breadcrumb (CourseR tid ssh csh CUsersR) = i18nCrumb MsgMenuCourseMembers . Just $ CourseR tid ssh csh CShowR breadcrumb (CourseR tid ssh csh CAddUserR) = i18nCrumb MsgMenuCourseAddMembers . Just $ CourseR tid ssh csh CUsersR -breadcrumb (CourseR tid ssh csh CInviteR) = i18nCrumb MsgBreadcrumbCourseParticipantInvitation . Just $ CourseR tid ssh csh CShowR breadcrumb (CourseR tid ssh csh CExamOfficeR) = i18nCrumb MsgMenuCourseExamOffice . Just $ CourseR tid ssh csh CShowR breadcrumb (CourseR tid ssh csh (CUserR cID)) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbUser . Just $ CourseR tid ssh csh CUsersR) $ do guardM . lift . hasReadAccessTo . CourseR tid ssh csh $ CUserR cID diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index fc8d44312..059734222 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -2,137 +2,39 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later -{-# OPTIONS_GHC -fno-warn-orphans #-} - module Handler.Course.ParticipantInvite - ( InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..) - , getCInviteR, postCInviteR - , getCAddUserR, postCAddUserR + ( getCAddUserR, postCAddUserR , AddParticipantsResult(..) , addParticipantsResultMessages , registerUsers, registerUser - , registerUsers', registerUser' ) where import Import import Handler.Utils -import Handler.Utils.Invitations import Handler.Utils.Course +import Handler.Utils.Avs import Jobs.Queue -import Control.Monad.Except (MonadError(..)) - -import Data.Aeson hiding (Result(..)) -import qualified Data.CaseInsensitive as CI -import qualified Data.HashSet as HashSet +--import Data.Aeson hiding (Result(..)) +--import qualified Data.CaseInsensitive as CI +--import qualified Data.HashSet as HashSet +import Data.List (genericLength) import qualified Data.Map as Map import qualified Data.Text as Text import qualified Data.Time.Zones as TZ import qualified Data.Set as Set +import Control.Monad.Except (MonadError(..)) import Generics.Deriving.Monoid (memptydefault, mappenddefault) -data CourseAvsRegisterForm = CourseAvsRegisterForm - { cavsregParticipants :: Set Text -- TODO: NonEmpty - , cavsregTutorial :: Maybe Day - } - deriving (Eq, Ord, Show, Read, Generic, Typeable) - -makeLenses_ ''CourseAvsRegisterForm - --- TODO: merge to postCAddUserR -_courseAvsRegisterForm :: Maybe CourseAvsRegisterForm -> AForm Handler CourseAvsRegisterForm -_courseAvsRegisterForm template = wFormToAForm $ do - today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime - - let - cfCommaSeparatedSet :: forall m. Functor m => Field m Text -> Field m (Set Text) - cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.splitOn ",") (Text.intercalate ", " . Set.toList) - - aFormToWForm $ CourseAvsRegisterForm - <$> areq (textField & cfCommaSeparatedSet) (fslI MsgCourseAvsRegisterParticipants & setTooltip MsgCourseAvsRegisterParticipantsTip) (cavsregParticipants <$> template) - <*> optionalActionA - ( areq dayField (fslI MsgCourseAvsRegisterTutorialDay) (Just . fromMaybe today . join $ cavsregTutorial <$> template) - ) - (fslI MsgCourseAvsRegisterCreateTutorial) ((is _Just . cavsregTutorial <$> template) <|> Just True) - - --- Invitations for ordinary participants of this course -instance IsInvitableJunction CourseParticipant where - type InvitationFor CourseParticipant = Course - data InvitableJunction CourseParticipant = JunctionParticipant - { jParticipantRegistration :: UTCTime - , jParticipantAllocated :: Maybe AllocationId - , jParticipantState :: CourseParticipantState - } deriving (Eq, Ord, Read, Show, Generic, Typeable) - data InvitationDBData CourseParticipant = InvDBDataParticipant - -- no data needed in DB to manage participant invitation - deriving (Eq, Ord, Read, Show, Generic, Typeable) - data InvitationTokenData CourseParticipant = InvTokenDataParticipant - { invTokenParticipantSubmissionGroup :: Maybe SubmissionGroupName - } - deriving (Eq, Ord, Read, Show, Generic, Typeable) - - _InvitableJunction = iso - (\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantAllocated courseParticipantState)) - (\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantAllocated courseParticipantState) -> CourseParticipant{..}) - -instance ToJSON (InvitableJunction CourseParticipant) where - toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } - toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } -instance FromJSON (InvitableJunction CourseParticipant) where - parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } - -instance ToJSON (InvitationDBData CourseParticipant) where - toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } - toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } -instance FromJSON (InvitationDBData CourseParticipant) where - parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } - -instance ToJSON (InvitationTokenData CourseParticipant) where - toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3, omitNothingFields = True } - toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3, omitNothingFields = True } -instance FromJSON (InvitationTokenData CourseParticipant) where - parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3, omitNothingFields = True } - -participantInvitationConfig :: InvitationConfig CourseParticipant -participantInvitationConfig = InvitationConfig{..} - where - invitationRoute (Entity _ Course{..}) _ = return $ CourseR courseTerm courseSchool courseShorthand CInviteR - invitationResolveFor _ = do - cRoute <- getCurrentRoute - case cRoute of - Just (CourseR tid csh ssh CInviteR) -> - getKeyBy404 $ TermSchoolCourseShort tid csh ssh - _other -> - error "participantInvitationConfig called from unsupported route" - invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand - invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName - invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|] - invitationTokenConfig _ _ = do - itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId - return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing - invitationRestriction _ _ = return Authorized - invitationForm _ _ _ = hoistAForm lift . wFormToAForm $ do - now <- liftIO getCurrentTime - return . pure . (, ()) $ JunctionParticipant now Nothing CourseParticipantActive - invitationInsertHook _ (Entity _ Course{..}) (_, InvTokenDataParticipant{..}) CourseParticipant{..} _ act = do - deleteBy $ UniqueParticipant courseParticipantUser courseParticipantCourse -- there are no foreign key references to @{CourseParticipant}; therefor we can delete and recreate to simulate upsert - res <- act -- insertUnique - audit $ TransactionCourseParticipantEdit courseParticipantCourse courseParticipantUser - void $ setUserSubmissionGroup courseParticipantCourse courseParticipantUser invTokenParticipantSubmissionGroup - memcachedByInvalidate (AuthCacheCourseRegisteredList courseTerm courseSchool courseShorthand) (Proxy @(Set UserId)) - return res - invitationSuccessMsg (Entity _ Course{..}) _ = - return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName) - invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR - data AddParticipantsResult = AddParticipantsResult { aurAlreadyRegistered - , aurSuccess :: Set UserId + , aurAlreadyTutorialMember + , aurRegisterSuccess + , aurTutorialSuccess :: Set UserId } deriving (Read, Show, Generic, Typeable) instance Semigroup AddParticipantsResult where @@ -142,50 +44,53 @@ instance Monoid AddParticipantsResult where mempty = memptydefault mappend = (<>) + getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCAddUserR = postCAddUserR postCAddUserR tid ssh csh = do - cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh + cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh + -- mr <- getMessageRender + today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime - ((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do - enlist <- wreq checkBoxField (fslI MsgCourseParticipantEnlistDirectly) (Just False) + let + cfCommaSeparatedSet :: forall m. Functor m => Field m Text -> Field m (Set Text) + cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.splitOn ",") (Text.intercalate ", " . Set.toList) - let submissionGroupOpts = optionsPersist [SubmissionGroupCourse ==. cid] [Asc SubmissionGroupName] submissionGroupName <&> fmap (submissionGroupName . entityVal) - mbGrp <- wopt (textField & cfStrip & cfCI & addDatalist submissionGroupOpts) (fslI MsgCourseSubmissionGroup & setTooltip MsgSubmissionGroupEmptyIsUnsetTip) Nothing + ((usersToRegister, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do + users <- wreq (textField & cfCommaSeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty + mTutorial <- optionalActionW + ( areq textField (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just $ tshow today) ) -- TODO: use user date display setting + ( fslI MsgCourseParticipantsRegisterTutorialOption ) + ( Just True ) + return $ Map.fromSet . const <$> mTutorial <*> users - mr <- getMessageRender - users <- wreq (multiUserInvitationField . maybe MUIAlwaysInvite (const $ MUILookupAnyUser Nothing) $ formResultToMaybe enlist) - (fslpI MsgCourseParticipantInviteField (mr MsgLdapIdentificationOrEmail) & setTooltip MsgMultiEmailFieldTip) Nothing + formResultModal usersToRegister (CourseR tid ssh csh CUsersR) $ + registerUsers cid -- TODO: register for tutorial, if specified - return $ Map.fromSet . const <$> mbGrp <*> users + let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading - formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $ - hoist runDBJobs . registerUsers' cid - - let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading - - siteLayoutMsg heading $ do - setTitleI heading - wrapForm formWgt def - { formEncoding - , formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR - } + siteLayoutMsg heading $ do + setTitleI heading + wrapForm formWgt def + { formEncoding + , formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR + } -registerUsers :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] (YesodJobDB UniWorX) () -registerUsers cid = registerUsers' cid . Map.fromSet (const Nothing) +registerUsers :: CourseId -> Map Text (Maybe Text) -> WriterT [Message] Handler () +registerUsers cid usersToRegister = do + avsUsers :: Map Text (Maybe UserId) <- fmap Map.fromList . forM (Map.keys usersToRegister) $ \userIdent -> do + mUser <- liftHandler $ upsertAvsUser userIdent -- TODO: upsertAvsUser should return whole Entity + return (userIdent, mUser) -registerUsers' :: CourseId -> Map (Either UserEmail UserId) (Maybe SubmissionGroupName) -> WriterT [Message] (YesodJobDB UniWorX) () -registerUsers' cid users = do - let (emails,uids) = partitionKeysEither users + when (null avsUsers) $ + tell . pure =<< messageI Error MsgCourseParticipantsRegisterNoneGiven - -- send Invitation eMails to unkown users - lift $ sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant{..})) | (mail, invTokenParticipantSubmissionGroup) <- Map.toList emails] -- register known users - tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT $ imapM_ (registerUser' cid) uids + -- tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT $ imapM_ (registerUser cid) uids - unless (null emails) $ - tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails + -- unless (null avsUsers) $ + -- tell . pure <=< messageI Success . MsgCourseParticipantsAddedByAvs $ length avsUsers addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) @@ -199,21 +104,18 @@ addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|] modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered") tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent) + -- TODO: aurAlreadyTutorialMember - unless (null aurSuccess) $ - tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurSuccess + unless (null aurRegisterSuccess) $ + tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurRegisterSuccess + unless (null aurTutorialSuccess) $ + tell . pure <=< messageI Success . MsgCourseUsersTutorialRegistered . genericLength $ Set.toList aurTutorialSuccess registerUser :: CourseId -> UserId -> WriterT AddParticipantsResult (YesodJobDB UniWorX) () -registerUser cid uid = registerUser' cid uid Nothing - -registerUser' :: CourseId - -> UserId - -> Maybe SubmissionGroupName - -> WriterT AddParticipantsResult (YesodJobDB UniWorX) () -registerUser' cid uid mbGrp = exceptT tell tell $ do +registerUser cid uid = exceptT tell tell $ do whenM (lift . lift $ exists [CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive]) $ throwError $ mempty { aurAlreadyRegistered = Set.singleton uid } @@ -233,11 +135,4 @@ registerUser' cid uid mbGrp = exceptT tell tell $ do lift . lift . audit $ TransactionCourseParticipantEdit cid uid lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid - void . lift . lift $ setUserSubmissionGroup cid uid mbGrp - - return $ mempty { aurSuccess = Set.singleton uid } - - -getCInviteR, postCInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getCInviteR = postCInviteR -postCInviteR = invitationR participantInvitationConfig + return $ mempty { aurRegisterSuccess = Set.singleton uid } From cba73bf2ca6825e9d4d00e51440354aba4cf57f0 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Sun, 4 Dec 2022 19:34:45 +0100 Subject: [PATCH 07/65] feat(course-users): register avs-upserted users --- src/Handler/Course/Application/List.hs | 76 +++++++++++++------------ src/Handler/Course/ParticipantInvite.hs | 22 +++---- 2 files changed, 47 insertions(+), 51 deletions(-) diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index 124c46139..ab20de652 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -2,6 +2,8 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later +-- TODO: probably remove applications in general + {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} @@ -28,10 +30,10 @@ import qualified Data.Map as Map import qualified Data.Conduit.List as C -import Handler.Course.ParticipantInvite +-- import Handler.Course.ParticipantInvite import Handler.Utils.StudyFeatures -import Jobs.Queue +-- import Jobs.Queue type CourseApplicationsTableExpr = ( E.SqlExpr (Entity CourseApplication) @@ -574,7 +576,7 @@ postCApplicationsR tid ssh csh = do registrationOpen = maybe True (now <) - ((acceptRes, acceptWgt'), acceptEnc) <- runFormPost . identifyForm BtnAcceptApplications . renderAForm FormStandard $ + ((_acceptRes, acceptWgt'), acceptEnc) <- runFormPost . identifyForm BtnAcceptApplications . renderAForm FormStandard $ (,) <$> apopt (selectField optionsFinite) (fslI MsgAcceptApplicationsMode & setTooltip MsgAcceptApplicationsModeTip) (Just AcceptApplicationsInvite) <*> apopt (selectField optionsFinite) (fslI MsgAcceptApplicationsSecondary & setTooltip MsgAcceptApplicationsSecondaryTip) (Just AcceptApplicationsSecondaryTime) @@ -584,47 +586,47 @@ postCApplicationsR tid ssh csh = do , formEncoding = acceptEnc } - when mayAccept $ - formResult acceptRes $ \(invMode, appsSecOrder) -> do - runDBJobs $ do - Entity cid Course{..} <- getBy404 $ TermSchoolCourseShort tid ssh csh - participants <- count [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ] - let openCapacity = subtract participants <$> courseCapacity + -- when mayAccept $ + -- formResult acceptRes $ \(invMode, appsSecOrder) -> do + -- runDBJobs $ do + -- -- Entity cid Course{..} <- getBy404 $ TermSchoolCourseShort tid ssh csh + -- -- participants <- count [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ] + -- -- let openCapacity = subtract participants <$> courseCapacity - applications <- E.select . E.from $ \(user `E.InnerJoin` application) -> do - E.on $ user E.^. UserId E.==. application E.^. CourseApplicationUser + -- -- applications <- E.select . E.from $ \(user `E.InnerJoin` application) -> do + -- -- E.on $ user E.^. UserId E.==. application E.^. CourseApplicationUser - E.where_ $ application E.^. CourseApplicationCourse E.==. E.val cid - E.&&. E.isNothing (application E.^. CourseApplicationAllocation) - E.&&. E.not_ (application E.^. CourseApplicationRatingVeto) - E.&&. E.maybe E.true (`E.in_` E.valList (filter (view $ passingGrade . _Wrapped) universeF)) (application E.^. CourseApplicationRatingPoints ) + -- -- E.where_ $ application E.^. CourseApplicationCourse E.==. E.val cid + -- -- E.&&. E.isNothing (application E.^. CourseApplicationAllocation) + -- -- E.&&. E.not_ (application E.^. CourseApplicationRatingVeto) + -- -- E.&&. E.maybe E.true (`E.in_` E.valList (filter (view $ passingGrade . _Wrapped) universeF)) (application E.^. CourseApplicationRatingPoints ) - E.where_ . E.not_ . E.exists . E.from $ \participant -> - E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid - E.&&. participant E.^. CourseParticipantUser E.==. user E.^. UserId - E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive + -- -- E.where_ . E.not_ . E.exists . E.from $ \participant -> + -- -- E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid + -- -- E.&&. participant E.^. CourseParticipantUser E.==. user E.^. UserId + -- -- E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive - return (user, application) + -- -- return (user, application) - let - ratingL = _2 . _entityVal . _courseApplicationRatingPoints . to (Down . ExamGradeDefCenter) - cmp = case appsSecOrder of - AcceptApplicationsSecondaryTime - -> comparing . view $ $(multifocusG 2) ratingL (_2 . _entityVal . _courseApplicationTime) - AcceptApplicationsSecondaryRandom - -> comparing $ view ratingL - sortedApplications <- unstableSortBy cmp applications + -- -- let + -- -- ratingL = _2 . _entityVal . _courseApplicationRatingPoints . to (Down . ExamGradeDefCenter) + -- -- cmp = case appsSecOrder of + -- -- AcceptApplicationsSecondaryTime + -- -- -> comparing . view $ $(multifocusG 2) ratingL (_2 . _entityVal . _courseApplicationTime) + -- -- AcceptApplicationsSecondaryRandom + -- -- -> comparing $ view ratingL + -- -- sortedApplications <- unstableSortBy cmp applications - let applicants = sortedApplications - & nubOrdOn (view $ _1 . _entityKey) - & maybe id take openCapacity - & setOf (case invMode of - AcceptApplicationsDirect -> folded . _1 . _entityKey . to Right - AcceptApplicationsInvite -> folded . _1 . _entityVal . _userEmail . to Left - ) + -- -- let applicants = sortedApplications + -- -- & nubOrdOn (view $ _1 . _entityKey) + -- -- & maybe id take openCapacity + -- -- & setOf (case invMode of + -- -- AcceptApplicationsDirect -> folded . _1 . _entityKey . to Right + -- -- AcceptApplicationsInvite -> folded . _1 . _entityVal . _userEmail . to Left + -- -- ) - mapM_ addMessage' <=< execWriterT $ registerUsers cid applicants - redirect $ CourseR tid ssh csh CUsersR + -- -- mapM_ addMessage' <=< execWriterT $ registerUsers cid applicants + -- redirect $ CourseR tid ssh csh CUsersR let studyFeaturesWarning = $(i18nWidgetFile "applications-list-info") diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 059734222..be819aaba 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -4,15 +4,11 @@ module Handler.Course.ParticipantInvite ( getCAddUserR, postCAddUserR - , AddParticipantsResult(..) - , addParticipantsResultMessages - , registerUsers, registerUser ) where import Import import Handler.Utils -import Handler.Utils.Course import Handler.Utils.Avs import Jobs.Queue @@ -65,7 +61,7 @@ postCAddUserR tid ssh csh = do return $ Map.fromSet . const <$> mTutorial <*> users formResultModal usersToRegister (CourseR tid ssh csh CUsersR) $ - registerUsers cid -- TODO: register for tutorial, if specified + hoist runDBJobs . registerUsers cid -- TODO: register for tutorial, if specified let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading @@ -77,20 +73,18 @@ postCAddUserR tid ssh csh = do } -registerUsers :: CourseId -> Map Text (Maybe Text) -> WriterT [Message] Handler () +registerUsers :: CourseId -> Map Text (Maybe Text) -> WriterT [Message] (YesodJobDB UniWorX) () registerUsers cid usersToRegister = do avsUsers :: Map Text (Maybe UserId) <- fmap Map.fromList . forM (Map.keys usersToRegister) $ \userIdent -> do mUser <- liftHandler $ upsertAvsUser userIdent -- TODO: upsertAvsUser should return whole Entity return (userIdent, mUser) - when (null avsUsers) $ - tell . pure =<< messageI Error MsgCourseParticipantsRegisterNoneGiven - - -- register known users - -- tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT $ imapM_ (registerUser cid) uids - - -- unless (null avsUsers) $ - -- tell . pure <=< messageI Success . MsgCourseParticipantsAddedByAvs $ length avsUsers + if + | null avsUsers + -> tell . pure =<< messageI Error MsgCourseParticipantsRegisterNoneGiven + | otherwise + -- register retrieved users + -> tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT $ mapM_ (registerUser cid) (catMaybes $ Map.elems avsUsers) addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) From 214610007cbfe7ec05e95d240bba81968804364b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 5 Dec 2022 18:40:57 +0100 Subject: [PATCH 08/65] chore(admin): add sql queries for some problems admins have to handle --- src/Handler/Admin.hs | 85 ++++++++++++++++++++++++++++++++++++---- src/Handler/Utils/Avs.hs | 2 +- 2 files changed, 78 insertions(+), 9 deletions(-) diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 6e430b1b5..87f0902ee 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -8,8 +8,9 @@ module Handler.Admin import Import --- import qualified Database.Esqueleto.Experimental as E --- import qualified Database.Esqueleto.Utils as E +import Database.Esqueleto.Experimental ((:&)(..)) +import qualified Database.Esqueleto.Experimental as E +import qualified Database.Esqueleto.Utils as E import Handler.Admin.Test as Handler.Admin import Handler.Admin.ErrorMessage as Handler.Admin @@ -20,16 +21,84 @@ import Handler.Admin.Ldap as Handler.Admin getAdminR :: Handler Html -getAdminR = - siteLayoutMsg MsgAdminHeading $ do - setTitleI MsgAdminHeading - i18n MsgAdminPageEmpty +getAdminR = do + _userReachability <- runDB areAllUsersReachable + + + siteLayoutMsg MsgAdminHeading $ do + setTitleI MsgAdminHeading + i18n MsgAdminPageEmpty + + +areAllUsersReachable :: DB Bool +areAllUsersReachable = isNothing <$> E.selectOne getUnreachableUsers + +getUnreachableUsers :: E.SqlQuery (E.SqlExpr (Entity User)) +getUnreachableUsers = do + user <- E.from $ E.table @User + E.where_ $ E.isNothing (user E.^. UserPostAddress) + E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%") + return user + +allDriversHaveAvsId :: DB Bool +allDriversHaveAvsId = do + now <- liftIO getCurrentTime + let nowaday = utctDay now + isNothing <$> E.selectOne (getDriversWithoutAvsId nowaday) + +-- | Returns users more than once if they own multiple avs-related valid licences, but no AvsID is known +getDriversWithoutAvsId :: Day -> E.SqlQuery (E.SqlExpr (Entity User)) +getDriversWithoutAvsId nowaday = do + (usr :& qualUsr :& qual) <- E.from $ E.table @User + `E.innerJoin` E.table @QualificationUser + `E.on` (\(usr :& qualUsr) -> usr E.^. UserId E.==. qualUsr E.^. QualificationUserUser) + `E.innerJoin` E.table @Qualification + `E.on` (\(_usr :& qualUsr :& qual) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification) + E.where_ $ -- is avs licence + E.isJust (qual E.^. QualificationAvsLicence) + E.&&. -- currently valid + (E.val nowaday `E.between` ( qualUsr E.^. QualificationUserFirstHeld + , qualUsr E.^. QualificationUserValidUntil)) + E.&&. -- not blocked + E.isNothing (qualUsr E.^. QualificationUserBlockedDue) + E.&&. -- AvsId is unknown + E.notExists (do + avsUsr <- E.from $ E.table @UserAvs + E.where_ $ avsUsr E.^. UserAvsUser E.==. usr E.^. UserId + ) + return usr + +-- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known +getDriversWithoutAvsId' :: Day -> E.SqlQuery (E.SqlExpr (Entity User)) +getDriversWithoutAvsId' nowaday = do + usr <- E.from $ E.table @User + E.where_ $ + E.exists (do -- a valid avs licence + (qual :& qualUsr) <- E.from (E.table @Qualification + `E.innerJoin` E.table @QualificationUser + `E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification)) + E.where_ $ -- is avs licence + E.isJust (qual E.^. QualificationAvsLicence) + E.&&. -- currently valid + (E.val nowaday `E.between` ( qualUsr E.^. QualificationUserFirstHeld + , qualUsr E.^. QualificationUserValidUntil)) + E.&&. -- not blocked + E.isNothing (qualUsr E.^. QualificationUserBlockedDue) + E.&&. -- matches user + (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId) + ) + E.&&. + E.notExists (do -- a known AvsId + avsUsr <- E.from $ E.table @UserAvs + E.where_ $ avsUsr E.^. UserAvsUser E.==. usr E.^. UserId + ) + return usr {- -mkBadAddressTable = do +mkUnreachableUsersTable = do let dbtSQLQuery user -> do E.where_ $ E.isNothing (user E.^. UserPostAddress) - E.&&. E.not ((user E.^. UserEmail) `E.like` E.val "%@%.%") + E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%") pure user dbtRowKey = (E.^. UserId) dbtProj = dbtProjFilteredPostId -- TODO: still don't understand the choices here diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index d97f2e8e5..e37e4593d 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -181,7 +181,7 @@ computeDifferingLicences (AvsResponseGetLicences licences) = do E.&&. (quali E.^. QualificationAvsLicence E.==. E.justVal lic) -- correct type of licence E.&&. (E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld ,qualUser E.^. QualificationUserValidUntil)) -- currently valid - E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue) -- no blocked + E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue) -- not blocked ) `E.innerJoin` E.table @UserAvs `E.on` (\(_ :& qualUser :& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser) From 2a981489938c7443dab5aecdcb38b8cc06baf7e9 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 6 Dec 2022 18:20:09 +0100 Subject: [PATCH 09/65] chore(admin): add problem overview on admin main page --- .../uniworx/categories/admin/de-de-formal.msg | 13 +- messages/uniworx/categories/admin/en-eu.msg | 12 +- .../uniworx/categories/term/de-de-formal.msg | 2 +- messages/uniworx/categories/term/en-eu.msg | 2 +- src/Handler/Admin.hs | 167 +++++++++++------- src/Handler/Admin/Avs.hs | 2 +- src/Handler/Utils/Avs.hs | 68 ++++--- templates/admin-problems.hamlet | 43 +++++ test/Utils/TypesSpec.hs | 4 +- 9 files changed, 210 insertions(+), 103 deletions(-) create mode 100644 templates/admin-problems.hamlet diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index d11cce147..18693317d 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -79,7 +79,7 @@ StudyFeatureInferenceNoNameConflicts: Keine Konflikte beobachtet StudyFeatureInferenceNameConflictsHeading: Studiengangseinträge mit beobachteten Konflikten AdminHeading !ident-ok: Administration -AdminPageEmpty: Diese Seite soll eine Übersichtsseite für Administrator:innen werden. Aktuell finden sich hier nur Links zu wichtigen Administrator-Funktionalitäten. + BearerTokenImpersonate: Auftreten als BearerTokenImpersonateNone: Keine Änderung BearerTokenImpersonateSingle: Einzelner Benutzer/Einzelne Benutzerin @@ -94,3 +94,14 @@ BearerTokenArchiveName !ident-ok: tokens.zip TestDownloadDirect: Direkte Generierung TestDownloadInTransaction: Generierung während Datenbank-Transaktion TestDownloadFromDatabase: Generierung während Download aus Datenbank + +ProblemsHeadingDrivers: Synchronisation Fahrberechtigungen mit Ausweisverwaltung +ProblemsAvsProblem e@Text: Synchronisation mit AVS/MoBaKo komplett fehlgeschlagen: #{e} +ProblemsDriverSynch0: Alle Sperrungen von Fahrberechtigungen sind im AVS eingetragen +ProblemsDriverSynch1: Alle gültigen Vorfeld-Fahrberechtigungen 'F' sind im AVS eingetragen +ProblemsDriverSynch2: Alle gültigen Rollfeld-Fahrberechtigungen 'R' sind im AVS eingetragen +ProblemsRDriversHaveFs: Alle Inhaber einer Rollfeld-Fahrberechtigung besitzen auch eine gültige Vorfeld-Fahrberechtigung +ProblemsDriversHaveAvsIds: Alle Inhaber einer Fahrberechtigung konnten einer AVS Identifikationsnummer zugeordnet werden +ProblemsHeadingUsers: Allgemein +ProblemsUsersAreReachable: Für alle Benutzer ist eine E-Mail oder postalische Adresse bekannt +ProblemsNoStalePrintJobs n@Integer: Alle Briefversandaufträge der vergangenen #{show n} Tage wurden von der Druckerei bestätigt \ 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 25d9dcff0..bcde387b8 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -79,7 +79,6 @@ StudyFeatureInferenceNoNameConflicts: No observed conflicts StudyFeatureInferenceNameConflictsHeading: Fields of study with observed conflicts AdminHeading: Administration -AdminPageEmpty: This page shall provide an overview for administrators in the future. For now there are only links to important administrator-functions. BearerTokenImpersonate: Impersonate BearerTokenImpersonateNone: No one @@ -95,3 +94,14 @@ BearerTokenArchiveName: tokens.zip TestDownloadDirect: Direct generation TestDownloadInTransaction: Generate during database transaction TestDownloadFromDatabase: Generate while streaming from database + +ProblemsHeadingDrivers: Synchronisation of Driving Licences with Airport ID Card Center +ProblemsAvsProblem e: Synchronisation with AVS/MoBaKo failed entirely: #{e} +ProblemsDriverSynch0: All revocations of driving licences were successfully registered with AVS +ProblemsDriverSynch1: All valid apron driving licences 'F' were successfully registered with AVS +ProblemsDriverSynch2: All valid maneuvering area driving licences 'R' were successfully registered with AVS +ProblemsRDriversHaveFs: All driving licence 'R' holders also have a valid 'F' licence +ProblemsDriversHaveAvsIds: All driving licence holder could be matched with their AVS id +ProblemsHeadingUsers: Miscellaneous +ProblemsUsersAreReachable: Either Email or postal address is known for all users +ProblemsNoStalePrintJobs n: All requests for letter mailing within the last #{show n} days were acknowledged as printed by the airport printing center \ No newline at end of file diff --git a/messages/uniworx/categories/term/de-de-formal.msg b/messages/uniworx/categories/term/de-de-formal.msg index 9166aaf30..8a93e5698 100644 --- a/messages/uniworx/categories/term/de-de-formal.msg +++ b/messages/uniworx/categories/term/de-de-formal.msg @@ -28,7 +28,7 @@ TermLectureStartTooltip: Muss am oder nach dem Beginn liegen TermLectureEndTooltip: Muss am oder vor dem Ende liegen TermActive: Aktiv TermActiveTooltip: Zeitraum in dem Lehrende Kurse anlegen dürfen; kann auf angegebene Lehrende eingeschränkt werden -TermActiveForPlaceholder: Email (optional) +TermActiveForPlaceholder: E-Mail (optional) NumCourses num@Int64: #{num} #{pluralDE num "Kurs" "Kurse"} TermsHeading: Semesterübersicht TermEditHeading: Semester editieren/anlegen diff --git a/messages/uniworx/categories/term/en-eu.msg b/messages/uniworx/categories/term/en-eu.msg index 4491e0ef4..7880cc072 100644 --- a/messages/uniworx/categories/term/en-eu.msg +++ b/messages/uniworx/categories/term/en-eu.msg @@ -28,7 +28,7 @@ TermLectureStartTooltip: Must be on or after starting day TermLectureEndTooltip: Must be before or on ending day TermActive: Active TermActiveTooltip: Timeframe when lecturers may add courses; maybe restricted for specified lecturers -TermActiveForPlaceholder: E-Mail (optional) +TermActiveForPlaceholder: Email (optional) NumCourses num: #{num} #{pluralEN num "course" "courses"} TermsHeading: Semesters TermEditHeading: Edit semester diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 87f0902ee..232d7cdf6 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -12,6 +12,9 @@ import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Utils as E +import Handler.Utils.DateTime +import Handler.Utils.Avs + import Handler.Admin.Test as Handler.Admin import Handler.Admin.ErrorMessage as Handler.Admin import Handler.Admin.Tokens as Handler.Admin @@ -22,78 +25,25 @@ import Handler.Admin.Ldap as Handler.Admin getAdminR :: Handler Html getAdminR = do - _userReachability <- runDB areAllUsersReachable - + now <- liftIO getCurrentTime + let nowaday = utctDay now + cutOffPrintDays = 7 + cutOffPrintJob = addLocalDays (-cutOffPrintDays) now + (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs) <- runDB $ (,,,) + <$> areAllUsersReachable + <*> allDriversHaveAvsId nowaday + <*> allRDriversHaveFs nowaday + <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <=. cutOffPrintJob]) + diffLics <- try retrieveDifferingLicences <&> \case + (Left e) -> Left $ tshow (e :: SomeException) + (Right (to0, to1, to2)) -> Right (null to0, null to1, null to2) siteLayoutMsg MsgAdminHeading $ do setTitleI MsgAdminHeading - i18n MsgAdminPageEmpty + -- TODO: use MessageStatus for colored icons; hide long AVS errormessage in modal; count avs differences instead of simple bool + $(widgetFile "admin-problems") -areAllUsersReachable :: DB Bool -areAllUsersReachable = isNothing <$> E.selectOne getUnreachableUsers - -getUnreachableUsers :: E.SqlQuery (E.SqlExpr (Entity User)) -getUnreachableUsers = do - user <- E.from $ E.table @User - E.where_ $ E.isNothing (user E.^. UserPostAddress) - E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%") - return user - -allDriversHaveAvsId :: DB Bool -allDriversHaveAvsId = do - now <- liftIO getCurrentTime - let nowaday = utctDay now - isNothing <$> E.selectOne (getDriversWithoutAvsId nowaday) - --- | Returns users more than once if they own multiple avs-related valid licences, but no AvsID is known -getDriversWithoutAvsId :: Day -> E.SqlQuery (E.SqlExpr (Entity User)) -getDriversWithoutAvsId nowaday = do - (usr :& qualUsr :& qual) <- E.from $ E.table @User - `E.innerJoin` E.table @QualificationUser - `E.on` (\(usr :& qualUsr) -> usr E.^. UserId E.==. qualUsr E.^. QualificationUserUser) - `E.innerJoin` E.table @Qualification - `E.on` (\(_usr :& qualUsr :& qual) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification) - E.where_ $ -- is avs licence - E.isJust (qual E.^. QualificationAvsLicence) - E.&&. -- currently valid - (E.val nowaday `E.between` ( qualUsr E.^. QualificationUserFirstHeld - , qualUsr E.^. QualificationUserValidUntil)) - E.&&. -- not blocked - E.isNothing (qualUsr E.^. QualificationUserBlockedDue) - E.&&. -- AvsId is unknown - E.notExists (do - avsUsr <- E.from $ E.table @UserAvs - E.where_ $ avsUsr E.^. UserAvsUser E.==. usr E.^. UserId - ) - return usr - --- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known -getDriversWithoutAvsId' :: Day -> E.SqlQuery (E.SqlExpr (Entity User)) -getDriversWithoutAvsId' nowaday = do - usr <- E.from $ E.table @User - E.where_ $ - E.exists (do -- a valid avs licence - (qual :& qualUsr) <- E.from (E.table @Qualification - `E.innerJoin` E.table @QualificationUser - `E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification)) - E.where_ $ -- is avs licence - E.isJust (qual E.^. QualificationAvsLicence) - E.&&. -- currently valid - (E.val nowaday `E.between` ( qualUsr E.^. QualificationUserFirstHeld - , qualUsr E.^. QualificationUserValidUntil)) - E.&&. -- not blocked - E.isNothing (qualUsr E.^. QualificationUserBlockedDue) - E.&&. -- matches user - (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId) - ) - E.&&. - E.notExists (do -- a known AvsId - avsUsr <- E.from $ E.table @UserAvs - E.where_ $ avsUsr E.^. UserAvsUser E.==. usr E.^. UserId - ) - return usr - {- mkUnreachableUsersTable = do let dbtSQLQuery user -> do @@ -105,4 +55,85 @@ mkUnreachableUsersTable = do dbtColonnade = -} - \ No newline at end of file +areAllUsersReachable :: DB Bool +areAllUsersReachable = isNothing <$> E.selectOne getUnreachableUsers + +getUnreachableUsers :: E.SqlQuery (E.SqlExpr (Entity User)) +getUnreachableUsers = do + user <- E.from $ E.table @User + E.where_ $ E.isNothing (user E.^. UserPostAddress) + E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%") + return user + +allDriversHaveAvsId :: Day -> DB Bool +allDriversHaveAvsId = fmap isNothing . E.selectOne . getDriversWithoutAvsId + +qIsValid :: E.SqlExpr (Entity QualificationUser) -> Day -> E.SqlExpr (E.Value Bool) +qIsValid qualUsr nowaday = + E.isNothing (qualUsr E.^. QualificationUserBlockedDue) -- not blocked + E.&&. -- currently valid + (E.val nowaday `E.between` + ( qualUsr E.^. QualificationUserFirstHeld + , qualUsr E.^. QualificationUserValidUntil)) + +{- +-- | Returns users more than once if they own multiple avs-related valid licences, but no AvsID is known +getDriversWithoutAvsId' :: Day -> E.SqlQuery (E.SqlExpr (Entity User)) +getDriversWithoutAvsId' nowaday = do + (usr :& qualUsr :& qual) <- E.from $ E.table @User + `E.innerJoin` E.table @QualificationUser + `E.on` (\(usr :& qualUsr) -> usr E.^. UserId E.==. qualUsr E.^. QualificationUserUser) + `E.innerJoin` E.table @Qualification + `E.on` (\(_usr :& qualUsr :& qual) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification) + E.where_ $ -- is avs licence + E.isJust (qual E.^. QualificationAvsLicence) + E.&&. (qualUsr `qIsValid` nowaday) + E.&&. -- AvsId is unknown + E.notExists (do + avsUsr <- E.from $ E.table @UserAvs + E.where_ $ avsUsr E.^. UserAvsUser E.==. usr E.^. UserId + ) + return usr +-} + +-- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known +getDriversWithoutAvsId :: Day -> E.SqlQuery (E.SqlExpr (Entity User)) +getDriversWithoutAvsId nowaday = do + usr <- E.from $ E.table @User + E.where_ $ + E.exists (do -- a valid avs licence + (qual :& qualUsr) <- E.from (E.table @Qualification + `E.innerJoin` E.table @QualificationUser + `E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification)) + E.where_ $ -- is avs licence + E.isJust (qual E.^. QualificationAvsLicence) + E.&&. (qualUsr `qIsValid` nowaday) -- currently valid + E.&&. -- matches user + (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId) + ) + E.&&. + E.notExists (do -- a known AvsId + avsUsr <- E.from $ E.table @UserAvs + E.where_ $ avsUsr E.^. UserAvsUser E.==. usr E.^. UserId + ) + return usr + + +allRDriversHaveFs :: Day -> DB Bool +allRDriversHaveFs = fmap isNothing . E.selectOne . getDriversRWithoutF + +-- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known +getDriversRWithoutF :: Day -> E.SqlQuery (E.SqlExpr (Entity User)) +getDriversRWithoutF nowaday = do + usr <- E.from $ E.table @User + let hasValidQual lic = do + (qual :& qualUsr) <- E.from (E.table @Qualification + `E.innerJoin` E.table @QualificationUser + `E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification)) + E.where_ $ (qual E.^. QualificationAvsLicence E.==. E.justVal lic) -- matches licence + E.&&. (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId) -- matches user + E.&&. (qualUsr `qIsValid` nowaday) -- currently valid + E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld) + E.&&. E.notExists (hasValidQual AvsLicenceVorfeld) + return usr + diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 6d24f2ffa..d455788ae 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -209,7 +209,7 @@ postAdminAvsR = do let msg = tshow (e :: SomeException) return $ Just [whamlet|

Licence check error:

#{msg}|] BtnSynchLicences -> do - res <- try checkLicences + res <- try synchAvsLicences case res of (Right True) -> return $ Just [whamlet|

Success:

Licences sychronized.|] diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index dc17218ab..79835197e 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -8,8 +8,9 @@ module Handler.Utils.Avs ( upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard -- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface - , setLicence, setLicenceAvs, setLicencesAvs, computeDifferingLicences - , checkLicences + , setLicence, setLicenceAvs, setLicencesAvs + , retrieveDifferingLicences, computeDifferingLicences + , synchAvsLicences , lookupAvsUser, lookupAvsUsers , AvsException(..) ) where @@ -145,8 +146,8 @@ setLicencesAvs persLics = do -- | Retrieve all currently valid driving licences and check against our database -- Only react to changes as compared to last seen status in avs.model -- TODO: run in a background job, once the interface is actually available -checkLicences :: Handler Bool -checkLicences = do +synchAvsLicences :: Handler Bool +synchAvsLicences = do AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery allLicences <- throwLeftM avsQueryGetAllLicences deltaLicences <- computeDifferingLicences allLicences @@ -157,7 +158,20 @@ checkLicences = do return setResponse computeDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonLicence) -computeDifferingLicences (AvsResponseGetLicences licences) = do +computeDifferingLicences argl = do + (setTo0, setTo1, setTo2) <- getDifferingLicences argl + return $ Set.map (AvsPersonLicence AvsNoLicence) setTo0 + <> Set.map (AvsPersonLicence AvsLicenceVorfeld) setTo1 + <> Set.map (AvsPersonLicence AvsLicenceRollfeld) setTo2 + +retrieveDifferingLicences :: Handler (Set AvsPersonId, Set AvsPersonId, Set AvsPersonId) +retrieveDifferingLicences = do + AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery + allLicences <- throwLeftM avsQueryGetAllLicences + getDifferingLicences allLicences + +getDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonId, Set AvsPersonId, Set AvsPersonId) +getDifferingLicences (AvsResponseGetLicences licences) = do now <- liftIO getCurrentTime --let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld) licences -- rollfeld = Set.filter (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld @@ -203,30 +217,28 @@ computeDifferingLicences (AvsResponseGetLicences licences) = do let setTo0 = vorfRevoke -- ready to use with SET 0 setTo1 = (vorfGrant Set.\\ rollGrant ) `Set.union` (rollRevoke Set.\\ vorfRevoke) setTo2 = (rollGrant Set.\\ vorfRevoke) `Set.intersection` (vorfGrant `Set.union` vorORrollfeld) - {- - Cases to consider (AVS_Licence,has_valid_F, has_valid_R) -> (vorfeld@(toset,unset), rollfeld@(toset,unset)) : - A (0,0,0) -> ((_,_),(_,_)) : nop; avs_id not returned from queries, no problem - B (0,0,1) -> ((_,_),(x,_)) : nop; do nothing -- CHECK since id is returned by roll-query - C (0,1,0) -> ((x,_),(_,_)) : set F for id - D (0,1,1) -> ((x,_),(x,_)) : set R for id - E (1,0,0) -> ((_,x),(_,_)) : set 0 for id - F (1,0,1) -> ((_,x),(x,_)) : set 0 for id - G (1,1,0) -> ((_,_),(_,_)) : nop - H (1,1,1) -> ((_,_),(x,_)) : set R for id - I (2,0,0) -> ((_,x),(_,x)) : set 0 for id - J (2,0,1) -> ((_,x),(_,_)) : set 0 for id - K (2,1,0) -> ((_,_),(_,x)) : set F for id - L (2,1,1) -> ((_,_),(_,_)) : nop + return (setTo0, setTo1, setTo2) + {- Cases to consider (AVS_Licence,has_valid_F, has_valid_R) -> (vorfeld@(toset,unset), rollfeld@(toset,unset)) : + A (0,0,0) -> ((_,_),(_,_)) : nop; avs_id not returned from queries, no problem + B (0,0,1) -> ((_,_),(x,_)) : nop; do nothing -- CHECK since id is returned by roll-query + C (0,1,0) -> ((x,_),(_,_)) : set F for id + D (0,1,1) -> ((x,_),(x,_)) : set R for id + E (1,0,0) -> ((_,x),(_,_)) : set 0 for id + F (1,0,1) -> ((_,x),(x,_)) : set 0 for id + G (1,1,0) -> ((_,_),(_,_)) : nop + H (1,1,1) -> ((_,_),(x,_)) : set R for id + I (2,0,0) -> ((_,x),(_,x)) : set 0 for id + J (2,0,1) -> ((_,x),(_,_)) : set 0 for id + K (2,1,0) -> ((_,_),(_,x)) : set F for id + L (2,1,1) -> ((_,_),(_,_)) : nop - PROBLEM: B & H in conflict! (Note that nop is automatic except for case B) - Results: - set to 0: determined by vorfeld-unset -- zuerst - set to 1: vorfeld-set && nicht in rollfeld-set || rollfeld-unset && nicht in vorfeld-unset - set to 2: rollfeld-set && nicht in vorfeld-unset && (in vorfeld-set || AVS_Licence>0 == vorORrollfeld) - -} - return $ Set.map (AvsPersonLicence AvsNoLicence) setTo0 - <> Set.map (AvsPersonLicence AvsLicenceVorfeld) setTo1 - <> Set.map (AvsPersonLicence AvsLicenceRollfeld) setTo2 + PROBLEM: B & H in conflict! (Note that nop is automatic except for case B) + Results: + set to 0: determined by vorfeld-unset -- zuerst + set to 1: vorfeld-set && nicht in rollfeld-set || rollfeld-unset && nicht in vorfeld-unset + set to 2: rollfeld-set && nicht in vorfeld-unset && (in vorfeld-set || AVS_Licence>0 == vorORrollfeld) + -} + -- | Always update AVS Data upsertAvsUser :: Text -> Handler (Maybe UserId) -- TODO: change to Entity diff --git a/templates/admin-problems.hamlet b/templates/admin-problems.hamlet new file mode 100644 index 000000000..94467b4b8 --- /dev/null +++ b/templates/admin-problems.hamlet @@ -0,0 +1,43 @@ +$newline never + +$# SPDX-FileCopyrightText: 2022 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +
+

+ _{MsgProblemsHeadingDrivers} + +
+
#{boolSymbol driversHaveAvsIds} +
_{MsgProblemsDriversHaveAvsIds} + + $case diffLics + $of Left err +
#{boolSymbol False} +
_{MsgProblemsAvsProblem err} + + $of Right (ok0,ok1,ok2) +
#{boolSymbol ok2} +
_{MsgProblemsDriverSynch2} + +
#{boolSymbol ok1} +
_{MsgProblemsDriverSynch1} + +
#{boolSymbol ok0} +
_{MsgProblemsDriverSynch0} + +
#{boolSymbol rDriversHaveFs} +
_{MsgProblemsRDriversHaveFs} + + +
+

+ _{MsgProblemsHeadingUsers} + +
+
#{boolSymbol usersAreReachable} +
_{MsgProblemsUsersAreReachable} + +
#{boolSymbol noStalePrintJobs} +
_{MsgProblemsNoStalePrintJobs cutOffPrintDays} diff --git a/test/Utils/TypesSpec.hs b/test/Utils/TypesSpec.hs index d1a82bb09..b3b8aaea6 100644 --- a/test/Utils/TypesSpec.hs +++ b/test/Utils/TypesSpec.hs @@ -126,7 +126,7 @@ spec = do [ eqLaws, showLaws, jsonLaws] describe "AvsLicence" $ do - it "ordering is consistent with its PersistField instance" . property $ -- this assumption is used in Handler.Utils.Avs.checkLicences + it "ordering is consistent with its PersistField instance" . property $ -- this assumption is used in Handler.Utils.Avs.synchAvsLicences \a (b :: AvsLicence) -> compare a b == compare (toPersistValue a) (toPersistValue b) it "assigns AvsLicence fixed SQL values" . example $ do -- ensure that DB encoding does not change unnoticed toPersistValue AvsLicenceVorfeld `shouldBe` toPersistValue (1::Int64) @@ -140,7 +140,7 @@ spec = do \p0 p1@AvsPersonLicence{avsLicenceRampLicence=v1} -> let p2@AvsPersonLicence{avsLicenceRampLicence=v2} = p0 in (v1 /= v2) ==> compare p1 p2 == compare v1 v2 - it "has antitone Function avsPersonLicenceIsGEQ" . property $ -- this assumption is used in Handler.Utils.Avs.checkLicences + it "has antitone Function avsPersonLicenceIsGEQ" . property $ -- this assumption is used in Handler.Utils.Avs.synchAvsLicences \j k l -> j < k ==> avsPersonLicenceIsLEQ j l >= avsPersonLicenceIsLEQ k l describe "Ord AvsDataCard" $ do From 2235e644447d02b6643d5683c37190367dfeceb3 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 6 Dec 2022 22:27:26 +0100 Subject: [PATCH 10/65] refactor(users-add): shorten upsert-avs --- src/Handler/Course/ParticipantInvite.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index be819aaba..9d0222c35 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -75,9 +75,8 @@ postCAddUserR tid ssh csh = do registerUsers :: CourseId -> Map Text (Maybe Text) -> WriterT [Message] (YesodJobDB UniWorX) () registerUsers cid usersToRegister = do - avsUsers :: Map Text (Maybe UserId) <- fmap Map.fromList . forM (Map.keys usersToRegister) $ \userIdent -> do - mUser <- liftHandler $ upsertAvsUser userIdent -- TODO: upsertAvsUser should return whole Entity - return (userIdent, mUser) + avsUsers :: Map Text (Maybe UserId) <- flip Map.traverseWithKey usersToRegister $ \userIdent _ -> + liftHandler $ upsertAvsUser userIdent -- TODO: upsertAvsUser should return whole Entity if | null avsUsers @@ -127,6 +126,6 @@ registerUser cid uid = exceptT tell tell $ do , CourseParticipantState =. CourseParticipantActive ] lift . lift . audit $ TransactionCourseParticipantEdit cid uid - lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid + lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid -- TODO: send Notification at all? return $ mempty { aurRegisterSuccess = Set.singleton uid } From 1445c8f69a335d9c8ff8626033eb683afd6cfd02 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 6 Dec 2022 22:44:39 +0100 Subject: [PATCH 11/65] chore(users-add): add missing cases of participant result messages --- .../categories/courses/courses/de-de-formal.msg | 1 + .../uniworx/categories/courses/courses/en-eu.msg | 1 + src/Handler/Course/ParticipantInvite.hs | 9 ++++++--- .../courseInvitationAlreadyRegistered.hamlet | 8 ++++---- .../courseInvitationAlreadyTutorialMember.hamlet | 12 ++++++++++++ 5 files changed, 24 insertions(+), 7 deletions(-) create mode 100644 templates/messages/courseInvitationAlreadyTutorialMember.hamlet diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index 33609c82d..85acabc35 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -118,6 +118,7 @@ CourseParticipantsRegisterNoneGiven: Es wurden keine anzumeldenden Personen ange CourseParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt CourseParticipantsAddedByAvs n@Int: #{n} AVS-Nutzer erfolgreich angemeldet (TODO) CourseParticipantsAlreadyRegistered n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} #{pluralDE n "ist" "sind"} bereits angemeldet +CourseParticipantsAlreadyTutorialMember n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} #{pluralDE n "ist" "sind"} bereits in dieser Übungsgruppe angemeldet CourseParticipantsRegistered n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} erfolgreich angemeldet CourseApplicationText: Text-Bewerbung CourseApplicationFollowInstructions: Beachten Sie die Anweisungen zur Bewerbung! diff --git a/messages/uniworx/categories/courses/courses/en-eu.msg b/messages/uniworx/categories/courses/courses/en-eu.msg index 40e1ff960..2fbddbd73 100644 --- a/messages/uniworx/categories/courses/courses/en-eu.msg +++ b/messages/uniworx/categories/courses/courses/en-eu.msg @@ -118,6 +118,7 @@ CourseParticipantsRegisterNoneGiven: No persons given to register! CourseParticipantsInvited n: #{n} #{pluralEN n "invitation" "invitations"} sent via email CourseParticipantsAddedByAvs n: #{n} AVS users successfully registered (TODO) CourseParticipantsAlreadyRegistered n: #{n} #{pluralEN n "participant is" "participants are"} already enrolled +CourseParticipantsAlreadyTutorialMember n: #{n} #{pluralEN n "participant is" "participants are"} already registered for this tutorial CourseParticipantsRegistered n: Successfully registered #{n} #{pluralEN n "participant" "participants"} CourseApplicationText: Application text CourseApplicationFollowInstructions: Please follow the instructions for applications! diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 9d0222c35..b2c0ece45 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -90,14 +90,17 @@ addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => AddParticipantsResult -> ReaderT (YesodPersistBackend UniWorX) m [Message] addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do - aurAlreadyRegistered' <- - fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurAlreadyRegistered) + aurAlreadyRegistered' <- fmap sort (lift . mapM getJust $ Set.toList aurAlreadyRegistered) + aurAlreadyTutorialMember' <- fmap sort (lift . mapM getJust $ Set.toList aurAlreadyTutorialMember) unless (null aurAlreadyRegistered) $ do let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|] modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered") tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent) - -- TODO: aurAlreadyTutorialMember + unless (null aurAlreadyTutorialMember) $ do + let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyTutorialMember (length aurAlreadyTutorialMember)}|] + modalContent = $(widgetFile "messages/courseInvitationAlreadyTutorialMember") + tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent) unless (null aurRegisterSuccess) $ tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurRegisterSuccess diff --git a/templates/messages/courseInvitationAlreadyRegistered.hamlet b/templates/messages/courseInvitationAlreadyRegistered.hamlet index d01becfb3..927e4fb90 100644 --- a/templates/messages/courseInvitationAlreadyRegistered.hamlet +++ b/templates/messages/courseInvitationAlreadyRegistered.hamlet @@ -1,12 +1,12 @@ $newline never -$# SPDX-FileCopyrightText: 2022 Gregor Kleen +$# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel $# $# SPDX-License-Identifier: AGPL-3.0-or-later

_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}