From 5320a4fe98f26576e6b72a1411107f410333009a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 8 Jun 2021 00:47:47 +0200 Subject: [PATCH] feat(allocations): create & edit, list & download matching logs --- frontend/src/app.sass | 2 +- .../courses/allocation/de-de-formal.msg | 66 +++++++ .../categories/courses/allocation/en-eu.msg | 66 +++++++ .../navigation/breadcrumbs/de-de-formal.msg | 4 + .../utils/navigation/breadcrumbs/en-eu.msg | 6 +- .../utils/navigation/menu/de-de-formal.msg | 3 + .../uniworx/utils/navigation/menu/en-eu.msg | 3 + routes | 5 + src/CryptoID.hs | 1 + src/Foundation/I18n.hs | 7 +- src/Foundation/Navigation.hs | 37 ++++ src/Foundation/Routes.hs | 2 + src/Foundation/Yesod/Middleware.hs | 11 +- src/Handler/Allocation.hs | 3 + src/Handler/Allocation/Edit.hs | 76 ++++++++ src/Handler/Allocation/Form.hs | 171 ++++++++++++++++++ src/Handler/Allocation/Matchings.hs | 39 ++++ src/Handler/Allocation/New.hs | 60 ++++++ src/Handler/Utils/DateTime.hs | 8 +- src/Handler/Utils/Form.hs | 17 ++ templates/allocation/matchings.hamlet | 24 +++ 21 files changed, 604 insertions(+), 7 deletions(-) create mode 100644 src/Handler/Allocation/Edit.hs create mode 100644 src/Handler/Allocation/Form.hs create mode 100644 src/Handler/Allocation/Matchings.hs create mode 100644 src/Handler/Allocation/New.hs create mode 100644 templates/allocation/matchings.hamlet diff --git a/frontend/src/app.sass b/frontend/src/app.sass index f6bd8a949..75601816f 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -761,7 +761,7 @@ section background-color: hsla($hue, 75%, 50%, $opacity) !important -.uuid, .pseudonym, .ldap-primary-key, .email, .file-path, .metric-value, .metric-label, .workflow-payload--text, .cryptoid +.uuid, .pseudonym, .ldap-primary-key, .email, .file-path, .metric-value, .metric-label, .workflow-payload--text, .cryptoid, .allocation-matching-fingerprint font-family: var(--font-monospace) .shown diff --git a/messages/uniworx/categories/courses/allocation/de-de-formal.msg b/messages/uniworx/categories/courses/allocation/de-de-formal.msg index c26a91771..195269d41 100644 --- a/messages/uniworx/categories/courses/allocation/de-de-formal.msg +++ b/messages/uniworx/categories/courses/allocation/de-de-formal.msg @@ -168,3 +168,69 @@ AllocationPrioritiesOrdinal: Dringlichkeiten durch Sortierung AllocationUsersCsvSheetName tid@TermId ssh@SchoolId ash@AllocationShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase ash} Bewerber AllocationApplication: Bewerbung AllocationProcess: Platzvergabe + +AllocationFormTerm: Semester +AllocationFormSchool: Institut +AllocationFormShorthand: Kürzel +AllocationFormName !ident-ok: Name +AllocationFormDescriptions: Beschreibungen +AllocationFormDescription: Beschreibung +AllocationFormDescriptionTip: Wird allen Benutzern auf der Seite der Zentralanmeldung angezeigt +AllocationFormStaffDescription: Beschreibung für Dozierende +AllocationFormStaffDescriptionTip: Wird nur (potentiellen) Dozierenden angezeigt; sowohl beim Anlegen eines Kurses, wie auch auf der Seite der Zentralanmeldung +AllocationFormDeadlines: Fristen +AllocationFormStaffRegisterFrom: Eintragung der Kurse ab +AllocationFormStaffRegisterFromTip: Ab diesem Zeitpunkt können Kursverwalter ihre Kurse selbstständig zur Zentralanmeldung eintragen. Falls kein Zeitpunkt angegeben wird, ist dies nie gestattet. +AllocationFormStaffRegisterTo: Eintragung der Kurse bis +AllocationFormStaffRegisterToTip: Falls kein Zeitpunkt angegeben wird, ist die Eintragung zunächst für immer möglich. +AllocationFormStaffAllocationFrom: Bewertung der Bewerbungen ab +AllocationFormStaffAllocationFromTip: Ab diesem Zeitpunkt dürfen Kursverwalter:innen Bewerbungen zu ihren Kursen bewerten. Falls kein Zeitpunkt angegeben wird, ist dies nie gestattet. +AllocationFormStaffAllocationTo: Bewertung der Bewerbungen bis +AllocationFormStaffAllocationToTip: Falls kein Zeitpunkt angegeben wird, ist die Bewertung zunächst für immer möglich. +AllocationFormRegisterFrom: Bewerbung ab +AllocationFormRegisterFromTip: Ab diesem Zeitpunkt dürfen alle Benutzer Bewerbungen zu den teilnehmenden Kursen hinterlegen. Falls kein Zeitpunkt angegeben wird, ist dies nie gestattet. +AllocationFormRegisterTo: Bewerbung bis +AllocationFormRegisterToTip: Falls kein Zeitpunkt angegeben wird, ist Bewerbung zunächst für immer möglich. +AllocationFormRegisterByStaffFrom: An- und Abmeldung durch Kursverwalter:innen ab +AllocationFormRegisterByStaffFromTip: Ab diesem Zeitpunkt dürfen Kursverwalter:innen Studierende direkt zu ihren Kursen anmelden. Falls kein Zeitpunkt angegeben wird, ist dies für an der Zentralanmeldung teilnehmende Kurse nie gestattet. +AllocationFormRegisterByStaffTo: An- und Abmeldung durch Kursverwalter:innen bis +AllocationFormRegisterByStaffToTip: Falls kein Zeitpunkt angegeben wird, ist An- und Abmeldung zunächst für immer möglich. +AllocationFormRegisterByCourse: An- und Abmeldung nach Kursregeln ab +AllocationFormRegisterByCourseTip: Ab diesem Zeitpunkt folgt selbstständige An- und Abmeldung zu bzw. von den teilnehmenden Kursen wieder den Regeln des jeweiligen Kurses. Falls kein Zeitpunkt angegeben wird, ist direkte An- und Abmeldung nie gestattet. +AllocationFormOverrideDeregister: Direkte Abmeldung frühestens ab +AllocationFormOverrideDeregisterTip: Bis zu diesem Zeitpunkt dürfen Teilnehmende sich nicht von teilnehmenden Kursen abmelden, selbst wenn dies nach Kursregeln gestattet wäre. Falls kein Zeitpunkt angegeben wird, ist Abmeldung nach Kursregeln gestattet (bzw. ab „_{MsgAllocationFormRegisterByCourse}“). + +AllocationFormStaffRegisterToMustBeAfterFrom: „_{MsgAllocationFormStaffRegisterTo}“ muss nach „_{MsgAllocationFormStaffRegisterFrom}“ liegen. +AllocationFormStaffAllocationToMustBeAfterFrom: „_{MsgAllocationFormStaffAllocationTo}“ muss nach „_{MsgAllocationFormStaffAllocationFrom}“ liegen. +AllocationFormRegisterToMustBeAfterFrom: „_{MsgAllocationFormRegisterTo}“ muss nach „_{MsgAllocationFormRegisterFrom}“ liegen. +AllocationFormRegisterByStaffToMustBeAfterFrom: „_{MsgAllocationFormRegisterByStaffTo}“ muss nach „_{MsgAllocationFormRegisterByStaffFrom}“ liegen. +AllocationFormStaffRegisterFromMustBeBeforeStaffAllocationFrom: „_{MsgAllocationFormStaffRegisterFrom}“ muss vor „_{MsgAllocationFormStaffAllocationFrom}“ liegen. +AllocationFormStaffRegisterToMustBeBeforeStaffAllocationTo: „_{MsgAllocationFormStaffRegisterTo}“ muss vor „_{MsgAllocationFormStaffAllocationTo}“ liegen. +AllocationFormStaffRegisterFromMustBeBeforeRegisterFrom: „_{MsgAllocationFormStaffRegisterFrom}“ muss vor „_{MsgAllocationFormRegisterFrom}“ liegen. +AllocationFormStaffRegisterToMustBeBeforeRegisterTo: „_{MsgAllocationFormStaffRegisterTo}“ muss vor „_{MsgAllocationFormRegisterTo}“ liegen. +AllocationFormStaffAllocationToShouldBeBeforeRegisterByStaffFrom: „_{MsgAllocationFormStaffAllocationTo}“ sollte vor „_{MsgAllocationFormRegisterByStaffFrom}“ liegen. +AllocationFormStaffAllocationToShouldBeBeforeRegisterByCourse: „_{MsgAllocationFormStaffAllocationTo}“ sollte vor „_{MsgAllocationFormRegisterByCourse}“ liegen. +AllocationFormStaffAllocationToShouldBeAfterRegisterTo: „_{MsgAllocationFormStaffAllocationTo}“ sollte nach „_{MsgAllocationFormRegisterTo}“ liegen. +AllocationFormRegisterToShouldBeBeforeRegisterByStaffFrom: „_{MsgAllocationFormRegisterTo}“ sollte vor „_{MsgAllocationFormRegisterByStaffFrom}“ liegen. +AllocationFormRegisterToShouldBeBeforeRegisterByCourse: „_{MsgAllocationFormRegisterTo}“ sollte vor „_{MsgAllocationFormRegisterByCourse}“ liegen. +AllocationFormRegisterByStaffFromShouldBeBeforeRegisterByCourse: „_{MsgAllocationFormRegisterByStaffFrom}“ sollte vor „_{MsgAllocationFormRegisterByCourse}“ liegen. + +AllocationNewSuccess: Zentralanmeldung erfolgreich angelegt +AllocationNewAlreadyExists: Eine Zentralanmeldung mit diesem Namen/Kürzel existiert bereits für diese Kombination aus Semester und Institut. + +TitleAllocationNew: Neue Zentralanmeldung anlegen + +TitleAllocationEdit tid@TermId ssh@SchoolId ash@AllocationShorthand: #{toPathPiece tid}-#{ssh}-#{ash}: Zentralanmeldung bearbeiten +HeadingAllocationEdit tid@TermId ssh@SchoolId aname@AllocationName: Zentralanmeldung bearbeiten: _{ShortTermIdentifier (unTermKey tid)}, #{ssh}, #{aname} + +AllocationEditSuccess: Zentralanmeldung erfolgreich bearbeitet +AllocationEditAlreadyExists: Eine andere Zentralanmeldung mit diesem Namen/Kürzel existiert bereits für diese Kombination aus Semester und Institut. + +TitleAllocationMatchings tid@TermId ssh@SchoolId ash@AllocationShorthand: #{toPathPiece tid}-#{ssh}-#{ash}: Verteilungen +HeadingAllocationMatchings tid@TermId ssh@SchoolId aname@AllocationName: Verteilungen: _{ShortTermIdentifier (unTermKey tid)}, #{ssh}, #{aname} +AllocationMatchingsNone: Noch keine Verteilungen +AllocationMatchingsLog: Protokoll +AllocationMatchingsTime: Zeitpunkt +AllocationMatchingsFingerprint: Prüfsumme + +AllocationMatchingLogFileName tid@TermId ssh@SchoolId ash@AllocationShorthand cID@CryptoUUIDAllocationMatching: za-verteilung.#{toPathPiece tid}-#{ssh}-#{ash}.#{toPathPiece cID}.log \ No newline at end of file diff --git a/messages/uniworx/categories/courses/allocation/en-eu.msg b/messages/uniworx/categories/courses/allocation/en-eu.msg index 7be2c90b9..6150f9cb4 100644 --- a/messages/uniworx/categories/courses/allocation/en-eu.msg +++ b/messages/uniworx/categories/courses/allocation/en-eu.msg @@ -167,3 +167,69 @@ AllocationPrioritiesOrdinal: Priorities based on sorted list AllocationUsersCsvSheetName tid ssh ash: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase ash} Applicants AllocationApplication: Application AllocationProcess: Allocation process + +AllocationFormTerm: Term +AllocationFormSchool: Department +AllocationFormShorthand: Shorthand +AllocationFormName: Name +AllocationFormDescriptions: Description +AllocationFormDescription: Description +AllocationFormDescriptionTip: Will be shown to all users on the page of the allocation +AllocationFormStaffDescription: Description for lecturers +AllocationFormStaffDescriptionTip: Will only be shown to (potential) lecturers; will be displayed both when creating a course and on the page of the allocation +AllocationFormDeadlines: Deadlines +AllocationFormStaffRegisterFrom: Register courses from +AllocationFormStaffRegisterFromTip: Starting at this time lecturers may register their courses for the allocation. If no timestamp is given, this will never be permitted. +AllocationFormStaffRegisterTo: Register courses until +AllocationFormStaffRegisterToTip: If no timestamp is given, registration will initially be possible forever. +AllocationFormStaffAllocationFrom: Rating of applications from +AllocationFormStaffAllocationFromTip: Starting at this time lecturers may rate applications for their courses. If no timestamp is given, this will never be permitted. +AllocationFormStaffAllocationTo: Rating of applications until +AllocationFormStaffAllocationToTip: If no timestamp is given, rating will initially be possible forever. +AllocationFormRegisterFrom: Application from +AllocationFormRegisterFromTip: Starting at this time all users may provide applications for courses participating in this allocation. If no timestamp is given, this will never be permitted. +AllocationFormRegisterTo: Application to +AllocationFormRegisterToTip: If no timestamp is given, application will initially be possible forever. +AllocationFormRegisterByStaffFrom: (De-)registration by lecturers from +AllocationFormRegisterByStaffFromTip: Starting at this time lecturers may (de-)register participants from/to their courses directly. If no timestamp is given, this will never be permitted. +AllocationFormRegisterByStaffTo: (De-)registration by lecturers until +AllocationFormRegisterByStaffToTip: If no timestamp is given, (de-)registration will initially be possible forever. +AllocationFormRegisterByCourse: (De-)registration according to course rules from +AllocationFormRegisterByCourseTip: Starting at this time users may (de-)register themselves from/to courses participating in the allocation according to the rules of the respective course. If no timestamp is given, direct (de-)registration will never be permitted. +AllocationFormOverrideDeregister: Direct deregistration from +AllocationFormOverrideDeregisterTip: Up to this time participants of courses participating in the allocation may not deregister themselves, even if it would be allowed according to course rules. If no timestamp is given, deregistration is allowed according to course rules (or as per “_{MsgAllocationFormRegisterByCourse}”). + +AllocationFormStaffRegisterToMustBeAfterFrom: “_{MsgAllocationFormStaffRegisterTo}” must be after “_{MsgAllocationFormStaffRegisterFrom}”. +AllocationFormStaffAllocationToMustBeAfterFrom: “_{MsgAllocationFormStaffAllocationTo}” must be after “_{MsgAllocationFormStaffAllocationFrom}”. +AllocationFormRegisterToMustBeAfterFrom: “_{MsgAllocationFormRegisterTo}” must be after “_{MsgAllocationFormRegisterFrom}”. +AllocationFormRegisterByStaffToMustBeAfterFrom: “_{MsgAllocationFormRegisterByStaffTo}” must be after “_{MsgAllocationFormRegisterByStaffFrom}”. +AllocationFormStaffRegisterFromMustBeBeforeStaffAllocationFrom: “_{MsgAllocationFormStaffRegisterFrom}” must be before “_{MsgAllocationFormStaffAllocationFrom}”. +AllocationFormStaffRegisterToMustBeBeforeStaffAllocationTo: “_{MsgAllocationFormStaffRegisterTo}” must be before “_{MsgAllocationFormStaffAllocationTo}”. +AllocationFormStaffRegisterFromMustBeBeforeRegisterFrom: “_{MsgAllocationFormStaffRegisterFrom}” must be before “_{MsgAllocationFormRegisterFrom}”. +AllocationFormStaffRegisterToMustBeBeforeRegisterTo: “_{MsgAllocationFormStaffRegisterTo}” must be before “_{MsgAllocationFormRegisterTo}”. +AllocationFormStaffAllocationToShouldBeBeforeRegisterByStaffFrom: “_{MsgAllocationFormStaffAllocationTo}” should be before “_{MsgAllocationFormRegisterByStaffFrom}”. +AllocationFormStaffAllocationToShouldBeBeforeRegisterByCourse: “_{MsgAllocationFormStaffAllocationTo}” should be before “_{MsgAllocationFormRegisterByCourse}”. +AllocationFormStaffAllocationToShouldBeAfterRegisterTo: “_{MsgAllocationFormStaffAllocationTo}” should be after “_{MsgAllocationFormRegisterTo}”. +AllocationFormRegisterToShouldBeBeforeRegisterByStaffFrom: “_{MsgAllocationFormRegisterTo}” should be before “_{MsgAllocationFormRegisterByStaffFrom}”. +AllocationFormRegisterToShouldBeBeforeRegisterByCourse: “_{MsgAllocationFormRegisterTo}” should be before “_{MsgAllocationFormRegisterByCourse}”. +AllocationFormRegisterByStaffFromShouldBeBeforeRegisterByCourse: “_{MsgAllocationFormRegisterByStaffFrom}” should be before “_{MsgAllocationFormRegisterByCourse}”. + +AllocationNewSuccess: Successfully created allocation +AllocationNewAlreadyExists: An allocation with this name/shorthand already exists for this term and department. + +TitleAllocationNew: Create new allocation + +TitleAllocationEdit tid ssh ash: #{toPathPiece tid}-#{ssh}-#{ash}: Edit allocation +HeadingAllocationEdit tid ssh aname: Edit allocation: _{ShortTermIdentifier (unTermKey tid)}, #{ssh}, #{aname} + +AllocationEditSuccess: Successfully edited allocation +AllocationEditAlreadyExists: Another allocation with this name/shorthand already exists for this term and department. + +TitleAllocationMatchings tid ssh ash: #{toPathPiece tid}-#{ssh}-#{ash}: Matchings +HeadingAllocationMatchings tid ssh aname: Matchings: _{ShortTermIdentifier (unTermKey tid)}, #{ssh}, #{aname} +AllocationMatchingsNone: No matchings yet +AllocationMatchingsLog: Log +AllocationMatchingsTime: Timestamp +AllocationMatchingsFingerprint: Fingerprint + +AllocationMatchingLogFileName tid ssh ash cID: allocation-matching.#{toPathPiece tid}-#{ssh}-#{ash}.#{toPathPiece cID}.log diff --git a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg index 2910b508b..a266c9861 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg @@ -16,6 +16,10 @@ BreadcrumbCourseFavourite: Favorisieren BreadcrumbCourse: Kurs BreadcrumbAllocationRegister: Teilnahme registrieren BreadcrumbAllocation: Zentralanmeldung +BreadcrumbAllocationNew: Neue Zentralanmeldung +BreadcrumbAllocationEdit: Bearbeiten +BreadcrumbAllocationMatchings: Verteilungen +BreadcrumbAllocationMatchingLog: Verteilungs-Protokoll BreadcrumbTerm !ident-ok: Semester BreadcrumbSchool: Institut BreadcrumbUser: Benutzer:in diff --git a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg index 03b0fcc13..4128ffd30 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg @@ -16,6 +16,10 @@ BreadcrumbCourseFavourite: Favourite BreadcrumbCourse: Course BreadcrumbAllocationRegister: Register participation BreadcrumbAllocation: Central allocation +BreadcrumbAllocationNew: New Allocation +BreadcrumbAllocationEdit: Edit +BreadcrumbAllocationMatchings: Matchings +BreadcrumbAllocationMatchingLog: Matching log BreadcrumbTerm: Semester BreadcrumbSchool: Department BreadcrumbUser: User @@ -178,4 +182,4 @@ BreadcrumbSheetNew: Create new exercise sheet BreadcrumbSheetCurrent: Current exercise sheet BreadcrumbSheetOldUnassigned: Submissions without corrector BreadcrumbLogin: Login -BreadcrumbNews: News \ No newline at end of file +BreadcrumbNews: News diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 38f5e5972..6787ac3ad 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -25,6 +25,9 @@ MenuProfile: Anpassen MenuLogin !ident-ok: Login MenuLogout !ident-ok: Logout MenuAllocationList: Zentralanmeldungen +MenuAllocationNew: Neue Zentralanmeldung anlegen +MenuAllocationEdit: Zentralanmeldung bearbeiten +MenuAllocationMatchings: Verteilungen MenuCourseList: Kurse MenuCourseMembers: Kursteilnehmer:innen MenuCourseAddMembers: KursteilnehmerInnen hinzufügen diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index da0cebf85..262c1fa85 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -25,6 +25,9 @@ MenuProfile: Settings MenuLogin: Login MenuLogout: Logout MenuAllocationList: Central allocations +MenuAllocationNew: Create new allocation +MenuAllocationEdit: Edit allocation +MenuAllocationMatchings: Matchings MenuCourseList: Courses MenuCourseMembers: Participants MenuCourseAddMembers: Add participants diff --git a/routes b/routes index 223c0114e..4a62bdbbc 100644 --- a/routes +++ b/routes @@ -154,8 +154,10 @@ /delete SWWDeleteR GET POST /allocation/ AllocationListR GET !free +!/allocation/new AllocationNewR GET POST !allocation-admin /allocation/#TermId/#SchoolId/#AllocationShorthand AllocationR: / AShowR GET POST !free + /edit AEditR GET POST !allocation-admin /register ARegisterR POST !time /course/#CryptoUUIDCourse/apply AApplyR POST !timeANDallocation-registered /users AUsersR GET POST !allocation-admin @@ -163,6 +165,9 @@ /priorities APriosR GET POST !allocation-admin /compute AComputeR GET POST !allocation-admin /accept AAcceptR GET POST !allocation-admin + /matchings AMatchingListR GET + /matchings/#CryptoUUIDAllocationMatching AMatchingR: + /log AMLogR GET /participants ParticipantsListR GET !evaluation /participants/#TermId/#SchoolId ParticipantsR GET !evaluation diff --git a/src/CryptoID.hs b/src/CryptoID.hs index f16aee18d..be3e30c80 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -56,6 +56,7 @@ decCryptoIDs [ ''SubmissionId , ''WorkflowInstanceId , ''WorkflowWorkflowId , ''MaterialFileId + , ''AllocationMatchingId ] type instance CryptoIDNamespace a WorkflowStateIndex = "WorkflowStateIndex" diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 10874dd1c..6d700a78f 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -140,6 +140,11 @@ maybeToMessage :: ToMessage m => Text -> Maybe m -> Text -> Text maybeToMessage _ Nothing _ = mempty maybeToMessage before (Just x) after = before <> toMessage x <> after + +newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier + deriving stock (Eq, Ord, Read, Show) + + -- Messages creates type UniWorXMessage and RenderMessage UniWorX instance mkMessage ''UniWorX "messages/uniworx/misc" "de-de-formal" mkMessageAddition ''UniWorX "Test" "messages/uniworx/test" "de-de-formal" @@ -190,8 +195,6 @@ instance RenderMessage UniWorX TermIdentifier where Winter -> renderMessage' $ MsgWinterTerm year where renderMessage' = renderMessage foundation ls -newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier - deriving stock (Eq, Ord, Read, Show) instance RenderMessage UniWorX ShortTermIdentifier where renderMessage foundation ls (ShortTermIdentifier TermIdentifier{..}) = case season of Summer -> renderMessage' $ MsgSummerTermShort year diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index d57751dd8..eadcaf463 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -191,11 +191,15 @@ breadcrumb (TermSchoolCourseListR tid ssh) = useRunDB . maybeT (i18nCrumb MsgBre return (CI.original $ unSchoolKey ssh, Just $ TermCourseListR tid) breadcrumb AllocationListR = i18nCrumb MsgAllocationListTitle $ Just NewsR +breadcrumb AllocationNewR = i18nCrumb MsgBreadcrumbAllocationNew $ Just AllocationListR breadcrumb (AllocationR tid ssh ash sRoute) = case sRoute of AShowR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbAllocation $ Just AllocationListR) $ do mr <- getMessageRender Entity _ Allocation{allocationName} <- MaybeT . getBy $ TermSchoolAllocationShort tid ssh ash return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{CI.original (unSchoolKey ssh)})|], Just AllocationListR) + AEditR -> i18nCrumb MsgBreadcrumbAllocationEdit . Just $ AllocationR tid ssh ash AShowR + AMatchingListR -> i18nCrumb MsgBreadcrumbAllocationMatchings . Just $ AllocationR tid ssh ash AShowR + AMatchingR _ AMLogR -> i18nCrumb MsgBreadcrumbAllocationMatchingLog . Just $ AllocationR tid ssh ash AMatchingListR ARegisterR -> i18nCrumb MsgBreadcrumbAllocationRegister . Just $ AllocationR tid ssh ash AShowR AApplyR cID -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ AllocationR tid ssh ash AShowR) $ do cid <- decrypt cID @@ -1444,6 +1448,19 @@ pageActions TermShowR = do , navChildren = participantsSecondary } ] +pageActions AllocationListR = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuAllocationNew + , navRoute = AllocationNewR + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] pageActions (AllocationR tid ssh ash AShowR) = return [ NavPageActionPrimary { navLink = NavLink @@ -1478,6 +1495,26 @@ pageActions (AllocationR tid ssh ash AShowR) = return } , navChildren = [] } + , NavPageActionSecondary + { navLink = NavLink + { navLabel = MsgMenuAllocationEdit + , navRoute = AllocationR tid ssh ash AEditR + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } + , NavPageActionSecondary + { navLink = NavLink + { navLabel = MsgMenuAllocationMatchings + , navRoute = AllocationR tid ssh ash AMatchingListR + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = True } + , navQuick' = mempty + , navForceActive = False + } + } ] pageActions (AllocationR tid ssh ash AUsersR) = return [ NavPageActionPrimary diff --git a/src/Foundation/Routes.hs b/src/Foundation/Routes.hs index bb5dc51eb..9e7bc4c76 100644 --- a/src/Foundation/Routes.hs +++ b/src/Foundation/Routes.hs @@ -44,6 +44,7 @@ deriving instance Generic GlobalWorkflowInstanceR deriving instance Generic GlobalWorkflowWorkflowR deriving instance Generic SchoolWorkflowInstanceR deriving instance Generic SchoolWorkflowWorkflowR +deriving instance Generic AMatchingR deriving instance Generic (Route UniWorX) instance Ord (Route Auth) where @@ -70,6 +71,7 @@ deriving instance Ord GlobalWorkflowInstanceR deriving instance Ord GlobalWorkflowWorkflowR deriving instance Ord SchoolWorkflowInstanceR deriving instance Ord SchoolWorkflowWorkflowR +deriving instance Ord AMatchingR deriving instance Ord (Route UniWorX) data RouteChildren diff --git a/src/Foundation/Yesod/Middleware.hs b/src/Foundation/Yesod/Middleware.hs index 683bb8ab6..942150d67 100644 --- a/src/Foundation/Yesod/Middleware.hs +++ b/src/Foundation/Yesod/Middleware.hs @@ -225,6 +225,7 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) . , verifyCourseNews , verifyWorkflowWorkflow , verifyMaterialVideo + , verifyAllocationMatchingLog ] where normalizeRender :: Route UniWorX -> WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX)) (Route UniWorX) @@ -359,6 +360,14 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) . MaterialFile{materialFileMaterial} <- lift . lift $ get404 mfId Material{materialName, materialCourse} <- lift . lift $ get404 materialFileMaterial Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 materialCourse - let newRoute = CMaterialR courseTerm courseSchool courseShorthand materialName (MVideoR cID) + let newRoute = CMaterialR courseTerm courseSchool courseShorthand materialName $ MVideoR cID + tell . Any $ route /= newRoute + return newRoute + verifyAllocationMatchingLog = maybeOrig $ \route -> do + AllocationR _tid _ssh _ash (AMatchingR cID AMLogR) <- return route + amId <- decrypt cID + AllocationMatching{allocationMatchingAllocation} <- lift . lift $ get404 amId + Allocation{allocationTerm, allocationSchool, allocationShorthand} <- lift . lift $ get404 allocationMatchingAllocation + let newRoute = AllocationR allocationTerm allocationSchool allocationShorthand $ AMatchingR cID AMLogR tell . Any $ route /= newRoute return newRoute diff --git a/src/Handler/Allocation.hs b/src/Handler/Allocation.hs index 088af6f42..a3eace4f6 100644 --- a/src/Handler/Allocation.hs +++ b/src/Handler/Allocation.hs @@ -12,3 +12,6 @@ import Handler.Allocation.AddUser as Handler.Allocation import Handler.Allocation.Prios as Handler.Allocation import Handler.Allocation.Compute as Handler.Allocation import Handler.Allocation.Accept as Handler.Allocation +import Handler.Allocation.Edit as Handler.Allocation +import Handler.Allocation.New as Handler.Allocation +import Handler.Allocation.Matchings as Handler.Allocation diff --git a/src/Handler/Allocation/Edit.hs b/src/Handler/Allocation/Edit.hs new file mode 100644 index 000000000..43fa5c5e3 --- /dev/null +++ b/src/Handler/Allocation/Edit.hs @@ -0,0 +1,76 @@ +module Handler.Allocation.Edit + ( getAEditR, postAEditR + ) where + +import Import +import Handler.Utils + +import Handler.Allocation.Form + + +getAEditR, postAEditR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html +getAEditR = postAEditR +postAEditR tid ssh ash = do + (Allocation{..}, (mAct, (formView, formEnc))) <- runDB $ do + Entity aId alloc@Allocation{..} <- getBy404 $ TermSchoolAllocationShort tid ssh ash + + let template = AllocationForm + { afTerm = allocationTerm + , afSchool = allocationSchool + , afShorthand = allocationShorthand + , afName = allocationName + , afDescription = allocationDescription + , afStaffDescription = allocationStaffDescription + , afStaffRegisterFrom = allocationStaffRegisterFrom + , afStaffRegisterTo = allocationStaffRegisterTo + , afRegisterFrom = allocationRegisterFrom + , afRegisterTo = allocationRegisterTo + , afStaffAllocationFrom = allocationStaffAllocationFrom + , afStaffAllocationTo = allocationStaffAllocationTo + , afRegisterByStaffFrom = allocationRegisterByStaffFrom + , afRegisterByStaffTo = allocationRegisterByStaffTo + , afRegisterByCourse = allocationRegisterByCourse + , afOverrideDeregister = allocationOverrideDeregister + } + + ((formRes, formView), formEnc) <- runFormPost . renderAForm FormStandard . allocationForm $ Just template + + mAct <- formResultMaybe formRes $ \AllocationForm{..} -> runMaybeT $ do + didUpdate <- fmap (is _Nothing) . lift $ replaceUnique aId alloc + { allocationTerm = afTerm + , allocationSchool = afSchool + , allocationShorthand = afShorthand + , allocationName = afName + , allocationDescription = afDescription + , allocationStaffDescription = afStaffDescription + , allocationStaffRegisterFrom = afStaffRegisterFrom + , allocationStaffRegisterTo = afStaffRegisterTo + , allocationStaffAllocationFrom = afStaffAllocationFrom + , allocationStaffAllocationTo = afStaffAllocationTo + , allocationRegisterFrom = afRegisterFrom + , allocationRegisterTo = afRegisterTo + , allocationRegisterByStaffFrom = afRegisterByStaffFrom + , allocationRegisterByStaffTo = afRegisterByStaffTo + , allocationRegisterByCourse = afRegisterByCourse + , allocationOverrideDeregister = afOverrideDeregister + } + + unless didUpdate $ do + addMessageI Error MsgAllocationEditAlreadyExists + mzero + + return $ do + addMessageI Success MsgAllocationEditSuccess + redirect $ AllocationR afTerm afSchool afShorthand AShowR + + return (alloc, (mAct, (formView, formEnc))) + + sequence_ mAct + + siteLayoutMsg (MsgHeadingAllocationEdit allocationTerm allocationSchool allocationName) $ do + setTitleI $ MsgTitleAllocationEdit allocationTerm allocationSchool allocationShorthand + + wrapForm formView def + { formAction = Just . SomeRoute $ AllocationR tid ssh ash AEditR + , formEncoding = formEnc + } diff --git a/src/Handler/Allocation/Form.hs b/src/Handler/Allocation/Form.hs new file mode 100644 index 000000000..99c701832 --- /dev/null +++ b/src/Handler/Allocation/Form.hs @@ -0,0 +1,171 @@ +module Handler.Allocation.Form + ( AllocationForm(..) + , allocationForm + ) where + +import Import + +import Handler.Utils + +import qualified Database.Esqueleto as E + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +import qualified Control.Monad.State.Class as State + + +data AllocationForm = AllocationForm + { afTerm :: TermId + , afSchool :: SchoolId + , afShorthand :: AllocationShorthand + , afName :: AllocationName + , afDescription, afStaffDescription :: Maybe StoredMarkup + , afStaffRegisterFrom, afStaffRegisterTo + , afRegisterFrom, afRegisterTo + , afStaffAllocationFrom, afStaffAllocationTo + , afRegisterByStaffFrom, afRegisterByStaffTo + , afRegisterByCourse, afOverrideDeregister :: Maybe UTCTime + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + + +allocationForm :: Maybe AllocationForm + -> AForm (YesodDB UniWorX) AllocationForm +allocationForm mTemplate = validateAForm validateAllocationForm . wFormToAForm $ do + mayEditTerms <- lift . lift $ hasWriteAccessTo TermEditR + termOptions <- + let termQuery :: E.SqlQuery (E.SqlExpr (E.Value TermId)) + termQuery = E.from $ \t -> do + unless mayEditTerms $ + E.where_ $ E.just (t E.^. TermId) E.==. E.val (afTerm <$> mTemplate) + E.||. t E.^. TermActive + E.orderBy [E.desc $ t E.^. TermStart] + return $ t E.^. TermId + in lift . lift $ mkOptionsE + termQuery + (return . toPathPiece . E.unValue) + (return . ShortTermIdentifier . unTermKey . E.unValue) + (return . E.unValue) + + muid <- maybeAuthId + schoolOptions <- + let schoolQuery :: E.SqlQuery (E.SqlExpr (Entity School)) + schoolQuery = E.from $ \s -> do + E.where_ $ E.exists (E.from $ \userFunction -> do + E.where_ $ userFunction E.^. UserFunctionSchool E.==. s E.^. SchoolId + E.&&. E.just (userFunction E.^. UserFunctionUser) E.==. E.val muid + E.&&. userFunction E.^. UserFunctionFunction `E.in_` E.valList [SchoolAdmin, SchoolAllocation] + ) + E.||. E.just (s E.^. SchoolId) E.==. E.val (afSchool <$> mTemplate) + E.orderBy [E.asc $ s E.^. SchoolShorthand] + return s + in lift . lift $ mkOptionsE + schoolQuery + (return . toPathPiece . entityKey) + (return . schoolName . entityVal) + (return . entityKey) + + template <- maybe (lift . lift $ suggestAllocationForm termOptions schoolOptions) (return . Just) mTemplate + + aFormToWForm . hoistAForm liftHandler $ AllocationForm + <$> areq (selectField $ return termOptions) (fslI MsgAllocationFormTerm) (afTerm <$> template) + <*> areq (selectField $ return schoolOptions) (fslI MsgAllocationFormSchool) (afSchool <$> template) + <*> areq (textField & cfStrip & cfCI) (fslI MsgAllocationFormShorthand) (afShorthand <$> template) + <*> areq (textField & cfStrip & cfCI) (fslI MsgAllocationFormName) (afName <$> template) + <* aformSection MsgAllocationFormDescriptions + <*> aopt htmlField (fslI MsgAllocationFormDescription & setTooltip MsgAllocationFormDescriptionTip) (afDescription <$> template) + <*> aopt htmlField (fslI MsgAllocationFormStaffDescription & setTooltip MsgAllocationFormStaffDescriptionTip) (afStaffDescription <$> template) + <* aformSection MsgAllocationFormDeadlines + <*> aopt utcTimeField (fslI MsgAllocationFormStaffRegisterFrom & setTooltip MsgAllocationFormStaffRegisterFromTip) (afStaffRegisterFrom <$> template) + <*> aopt utcTimeField (fslI MsgAllocationFormStaffRegisterTo & setTooltip MsgAllocationFormStaffRegisterToTip) (afStaffRegisterTo <$> template) + <*> aopt utcTimeField (fslI MsgAllocationFormRegisterFrom & setTooltip MsgAllocationFormRegisterFromTip) (afRegisterFrom <$> template) + <*> aopt utcTimeField (fslI MsgAllocationFormRegisterTo & setTooltip MsgAllocationFormRegisterToTip) (afRegisterTo <$> template) + <*> aopt utcTimeField (fslI MsgAllocationFormStaffAllocationFrom & setTooltip MsgAllocationFormStaffAllocationFromTip) (afStaffAllocationFrom <$> template) + <*> aopt utcTimeField (fslI MsgAllocationFormStaffAllocationTo & setTooltip MsgAllocationFormStaffAllocationToTip) (afStaffAllocationTo <$> template) + <*> aopt utcTimeField (fslI MsgAllocationFormRegisterByStaffFrom & setTooltip MsgAllocationFormRegisterByStaffFromTip) (afRegisterByStaffFrom <$> template) + <*> aopt utcTimeField (fslI MsgAllocationFormRegisterByStaffTo & setTooltip MsgAllocationFormRegisterByStaffToTip) (afRegisterByStaffTo <$> template) + <*> aopt utcTimeField (fslI MsgAllocationFormRegisterByCourse & setTooltip MsgAllocationFormRegisterByCourseTip) (afRegisterByCourse <$> template) + <*> aopt utcTimeField (fslI MsgAllocationFormOverrideDeregister & setTooltip MsgAllocationFormOverrideDeregisterTip) (afOverrideDeregister <$> template) + +validateAllocationForm :: FormValidator AllocationForm (YesodDB UniWorX) () +validateAllocationForm = do + AllocationForm{..} <- State.get + + guardValidation MsgAllocationFormStaffRegisterToMustBeAfterFrom + $ NTop afStaffRegisterFrom <= NTop afStaffRegisterTo + guardValidation MsgAllocationFormStaffAllocationToMustBeAfterFrom + $ NTop afStaffAllocationFrom <= NTop afStaffAllocationTo + guardValidation MsgAllocationFormRegisterToMustBeAfterFrom + $ NTop afRegisterFrom <= NTop afRegisterTo + guardValidation MsgAllocationFormRegisterByStaffToMustBeAfterFrom + $ NTop afRegisterByStaffFrom <= NTop afRegisterByStaffTo + + guardValidation MsgAllocationFormStaffRegisterFromMustBeBeforeStaffAllocationFrom + $ NTop afStaffRegisterFrom <= NTop afStaffAllocationFrom + guardValidation MsgAllocationFormStaffRegisterToMustBeBeforeStaffAllocationTo + $ NTop afStaffRegisterTo <= NTop afStaffAllocationTo + + guardValidation MsgAllocationFormStaffRegisterFromMustBeBeforeRegisterFrom + $ NTop afStaffRegisterFrom <= NTop afRegisterFrom + guardValidation MsgAllocationFormStaffRegisterToMustBeBeforeRegisterTo + $ NTop afStaffRegisterTo <= NTop afRegisterTo + + warnValidation MsgAllocationFormStaffAllocationToShouldBeBeforeRegisterByStaffFrom + $ NTop afStaffAllocationTo <= NTop afRegisterByStaffFrom + warnValidation MsgAllocationFormStaffAllocationToShouldBeBeforeRegisterByCourse + $ NTop afStaffAllocationTo <= NTop afRegisterByCourse + warnValidation MsgAllocationFormStaffAllocationToShouldBeAfterRegisterTo + $ NTop afStaffAllocationTo >= NTop afRegisterTo + + warnValidation MsgAllocationFormRegisterToShouldBeBeforeRegisterByStaffFrom + $ NTop afRegisterTo <= NTop afRegisterByStaffFrom + warnValidation MsgAllocationFormRegisterToShouldBeBeforeRegisterByCourse + $ NTop afRegisterTo <= NTop afRegisterByCourse + + warnValidation MsgAllocationFormRegisterByStaffFromShouldBeBeforeRegisterByCourse + $ NTop afRegisterByStaffFrom <= NTop afRegisterByCourse + +suggestAllocationForm :: OptionList TermId -> OptionList SchoolId + -> DB (Maybe AllocationForm) +suggestAllocationForm (Set.fromList . map optionInternalValue . olOptions -> terms) (Set.fromList . map optionInternalValue . olOptions -> schools) = runMaybeT $ do + allocs <- lift . E.select . E.from $ \alloc -> do + E.where_ $ alloc E.^. AllocationSchool `E.in_` E.valList (Set.toList schools) + return ( alloc E.^. AllocationTerm + , alloc E.^. AllocationSchool + , alloc E.^. AllocationShorthand + ) + let allocTerms = Map.fromListWith (<>) $ do + (E.Value tid, E.Value ssh, E.Value ash) <- allocs + return ((ssh, ash), Set.singleton tid) + nextAlloc = flip Map.mapMaybe allocTerms $ \(Set.toDescList -> tids) -> case tids of + TermKey t1 : TermKey t2 : _ -> Just . TermKey . toEnum $ fromEnum t1 + (fromEnum t1 - fromEnum t2) + TermKey t1 : _ -> Just . TermKey $ succ t1 + _other -> Nothing + maxAllocTerm <- hoistMaybe . fmap maximum . fromNullable $ Map.mapMaybe Set.lookupMax allocTerms + ((ssh, ash), tid) <- hoistMaybe . fmap (minimumBy $ comparing (view _2) <> comparing (view _1)) . fromNullable . Map.toList $ Map.filter (\t -> t >= maxAllocTerm && t `Set.member` terms) nextAlloc + oldTid <- hoistMaybe $ Set.lookupMax =<< Map.lookup (ssh, ash) allocTerms + oldTerm <- MaybeT $ get oldTid + newTerm <- MaybeT $ get tid + Entity _ Allocation{..} <- MaybeT . getBy $ TermSchoolAllocationShort oldTid ssh ash + + let dayOffset = (diffDays `on` termLectureStart) newTerm oldTerm + addTime = addLocalDays dayOffset + + return AllocationForm + { afTerm = tid + , afSchool = ssh + , afShorthand = ash + , afName = allocationName + , afDescription = allocationDescription + , afStaffDescription = allocationStaffDescription + , afStaffRegisterFrom = addTime <$> allocationStaffRegisterFrom + , afStaffRegisterTo = addTime <$> allocationStaffRegisterTo + , afStaffAllocationFrom = addTime <$> allocationStaffAllocationFrom + , afStaffAllocationTo = addTime <$> allocationStaffAllocationTo + , afRegisterFrom = addTime <$> allocationRegisterFrom + , afRegisterTo = addTime <$> allocationRegisterTo + , afRegisterByStaffFrom = addTime <$> allocationRegisterByStaffFrom + , afRegisterByStaffTo = addTime <$> allocationRegisterByStaffTo + , afRegisterByCourse = addTime <$> allocationRegisterByCourse + , afOverrideDeregister = addTime <$> allocationOverrideDeregister + } diff --git a/src/Handler/Allocation/Matchings.hs b/src/Handler/Allocation/Matchings.hs new file mode 100644 index 000000000..2b893ec8a --- /dev/null +++ b/src/Handler/Allocation/Matchings.hs @@ -0,0 +1,39 @@ +module Handler.Allocation.Matchings + ( getAMatchingListR + , getAMLogR + ) where + +import Import +import Handler.Utils + +import Data.ByteString.Base32 +import qualified Data.ByteArray as BA +import qualified Data.CaseInsensitive as CI + + +getAMatchingListR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html +getAMatchingListR tid ssh ash = do + (Allocation{..}, matchings) <- runDB $ do + Entity aId alloc <- getBy404 $ TermSchoolAllocationShort tid ssh ash + matchings <- selectList [ AllocationMatchingAllocation ==. aId ] [ Desc AllocationMatchingTime ] + matchings' <- forM matchings $ \(Entity matchingId m) -> (, m) <$> encrypt matchingId + return (alloc, matchings') + + siteLayoutMsg (MsgHeadingAllocationMatchings allocationTerm allocationSchool allocationName) $ do + setTitleI $ MsgTitleAllocationMatchings allocationTerm allocationSchool allocationShorthand + + $(widgetFile "allocation/matchings") + where + showFingerprint = CI.foldCase . encodeBase32Unpadded . BA.convert + +getAMLogR :: TermId -> SchoolId -> AllocationShorthand -> CryptoUUIDAllocationMatching -> Handler TypedContent +getAMLogR tid ssh ash cID = serveOneFile $ do + matchingId <- decrypt @AllocationMatchingId cID + AllocationMatching{..} <- lift $ get404 matchingId + mr <- getMessageRender + let fileReferenceTitle = unpack . mr $ MsgAllocationMatchingLogFileName tid ssh ash cID + yield FileReference + { fileReferenceTitle + , fileReferenceContent = Just allocationMatchingLog + , fileReferenceModified = allocationMatchingTime + } diff --git a/src/Handler/Allocation/New.hs b/src/Handler/Allocation/New.hs new file mode 100644 index 000000000..b8e280512 --- /dev/null +++ b/src/Handler/Allocation/New.hs @@ -0,0 +1,60 @@ +module Handler.Allocation.New + ( getAllocationNewR, postAllocationNewR + ) where + +import Import +import Handler.Utils + +import Handler.Allocation.Form + +import qualified Crypto.Random as Crypto + + +getAllocationNewR, postAllocationNewR :: Handler Html +getAllocationNewR = postAllocationNewR +postAllocationNewR = do + (mAct, (formView, formEnc)) <- runDB $ do + ((formRes, formView), formEnc) <- runFormPost . renderAForm FormStandard $ allocationForm Nothing + + mAct <- formResultMaybe formRes $ \AllocationForm{..} -> runMaybeT $ do + allocationMatchingSeed <- liftIO $ Crypto.getRandomBytes 32 + + insertRes <- lift $ insertUnique Allocation + { allocationTerm = afTerm + , allocationSchool = afSchool + , allocationShorthand = afShorthand + , allocationName = afName + , allocationDescription = afDescription + , allocationStaffDescription = afStaffDescription + , allocationStaffRegisterFrom = afStaffRegisterFrom + , allocationStaffRegisterTo = afStaffRegisterTo + , allocationStaffAllocationFrom = afStaffAllocationFrom + , allocationStaffAllocationTo = afStaffAllocationTo + , allocationRegisterFrom = afRegisterFrom + , allocationRegisterTo = afRegisterTo + , allocationRegisterByStaffFrom = afRegisterByStaffFrom + , allocationRegisterByStaffTo = afRegisterByStaffTo + , allocationRegisterByCourse = afRegisterByCourse + , allocationOverrideDeregister = afOverrideDeregister + , allocationMatchingSeed + } + + unless (is _Just insertRes) $ do + addMessageI Error MsgAllocationNewAlreadyExists + mzero + + return $ do + addMessageI Success MsgAllocationNewSuccess + redirect $ AllocationR afTerm afSchool afShorthand AShowR + + return (mAct, (formView, formEnc)) + + sequence_ mAct + + siteLayoutMsg MsgTitleAllocationNew $ do + setTitleI MsgTitleAllocationNew + + wrapForm formView def + { formAction = Just $ SomeRoute AllocationNewR + , formEncoding = formEnc + } diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index a52f429d8..7b7dfd322 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -12,6 +12,7 @@ module Handler.Utils.DateTime , getTimeLocale, getDateTimeFormat , getDateTimeFormatter , validDateTimeFormats, dateTimeFormatOptions + , addLocalDays , addOneWeek, addWeeks , weeksToAdd , setYear @@ -222,11 +223,14 @@ addOneWeek :: UTCTime -> UTCTime addOneWeek = addWeeks 1 addWeeks :: Integer -> UTCTime -> UTCTime -addWeeks n utct = localTimeToUTCTZ appTZ newLocal +addWeeks = addLocalDays . (* 7) + +addLocalDays :: Integer -> UTCTime -> UTCTime +addLocalDays n utct = localTimeToUTCTZ appTZ newLocal where oldLocal = utcToLocalTime utct oldDay = localDay oldLocal - newDay = addDays (7*n) oldDay + newDay = addDays n oldDay newLocal = oldLocal { localDay = newDay } weeksToAdd :: UTCTime -> UTCTime -> Integer diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 3bc02b7ef..9fc79c27c 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -38,8 +38,10 @@ import qualified Data.Conduit.List as C (mapMaybe, mapMaybeM) import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E +import qualified Database.Esqueleto.Internal.Internal as E (SqlSelect) import qualified Data.Set as Set +import qualified Data.Sequence as Seq import Data.Map ((!), (!?)) import qualified Data.Map as Map @@ -1515,6 +1517,21 @@ optionsPersistCryptoId filts ords toDisplay = do ents <- runDB $ selectList filts ords optionsCryptoIdF ents (return . entityKey) (return . toDisplay . entityVal) +mkOptionsE :: forall a r b msg. + ( RenderMessage UniWorX msg + , E.SqlSelect a r + ) + => E.SqlQuery a + -> (r -> YesodDB UniWorX Text) + -> (r -> YesodDB UniWorX msg) + -> (r -> YesodDB UniWorX b) + -> YesodDB UniWorX (OptionList b) +mkOptionsE query toExternal toDisplay toInternal = do + mr <- getMessageRender + let toOption x = Option <$> (mr <$> toDisplay x) <*> toInternal x <*> toExternal x + fmap (mkOptionList . toList) . runConduit $ + E.selectSource query .| C.mapM toOption .| C.foldMap Seq.singleton + optionsCryptoIdE :: forall backend a msg. ( HasCryptoUUID (Key a) (HandlerFor UniWorX) , RenderMessage UniWorX msg diff --git a/templates/allocation/matchings.hamlet b/templates/allocation/matchings.hamlet new file mode 100644 index 000000000..68f8c3b63 --- /dev/null +++ b/templates/allocation/matchings.hamlet @@ -0,0 +1,24 @@ +$if null matchings +

+ _{MsgAllocationMatchingsNone} +$else +

+ + + + + $forall (cID, AllocationMatching{allocationMatchingTime, allocationMatchingFingerprint}) <- matchings + +
+ _{MsgAllocationMatchingsTime} + + _{MsgAllocationMatchingsFingerprint} + + _{MsgAllocationMatchingsLog} +
+ ^{formatTimeW SelFormatDateTime allocationMatchingTime} + + #{showFingerprint allocationMatchingFingerprint} + + + _{MsgAllocationMatchingsLog}