feat(allocations): create & edit, list & download matching logs
This commit is contained in:
Gregor Kleen
parent
0d6b1921fb
commit
5320a4fe98
@ -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
|
||||
|
||||
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
BreadcrumbNews: News
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
5
routes
5
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
|
||||
|
||||
@ -56,6 +56,7 @@ decCryptoIDs [ ''SubmissionId
|
||||
, ''WorkflowInstanceId
|
||||
, ''WorkflowWorkflowId
|
||||
, ''MaterialFileId
|
||||
, ''AllocationMatchingId
|
||||
]
|
||||
|
||||
type instance CryptoIDNamespace a WorkflowStateIndex = "WorkflowStateIndex"
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
76
src/Handler/Allocation/Edit.hs
Normal file
76
src/Handler/Allocation/Edit.hs
Normal file
@ -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
|
||||
}
|
||||
171
src/Handler/Allocation/Form.hs
Normal file
171
src/Handler/Allocation/Form.hs
Normal file
@ -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
|
||||
}
|
||||
39
src/Handler/Allocation/Matchings.hs
Normal file
39
src/Handler/Allocation/Matchings.hs
Normal file
@ -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
|
||||
}
|
||||
60
src/Handler/Allocation/New.hs
Normal file
60
src/Handler/Allocation/New.hs
Normal file
@ -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
|
||||
}
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
24
templates/allocation/matchings.hamlet
Normal file
24
templates/allocation/matchings.hamlet
Normal file
@ -0,0 +1,24 @@
|
||||
$if null matchings
|
||||
<p .explanation>
|
||||
_{MsgAllocationMatchingsNone}
|
||||
$else
|
||||
<div .scrolltable .scrolltable--bordered>
|
||||
<table .table .table--hover .table--striped>
|
||||
<thead>
|
||||
<tr .table__row--head>
|
||||
<th .table__th>
|
||||
_{MsgAllocationMatchingsTime}
|
||||
<th .table__th>
|
||||
_{MsgAllocationMatchingsFingerprint}
|
||||
<th .table__th>
|
||||
_{MsgAllocationMatchingsLog}
|
||||
<tbody>
|
||||
$forall (cID, AllocationMatching{allocationMatchingTime, allocationMatchingFingerprint}) <- matchings
|
||||
<tr .table__row>
|
||||
<td .table__td>
|
||||
^{formatTimeW SelFormatDateTime allocationMatchingTime}
|
||||
<td .table__td .allocation-matching-fingerprint>
|
||||
#{showFingerprint allocationMatchingFingerprint}
|
||||
<td .table__td>
|
||||
<a href=@{AllocationR tid ssh ash (AMatchingR cID AMLogR)}>
|
||||
_{MsgAllocationMatchingsLog}
|
||||
Loading…
Reference in New Issue
Block a user