diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 6013ff38e..012dd8d13 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -658,11 +658,21 @@ section .heated --hotness: 0 - --red: calc(var(--hotness) * 200) - --green: calc(255 - calc(var(--hotness) * 255)) - --opacity: calc(calc(var(--red) / 600) + 0.1) - font-weight: var(--weight, 600) - background-color: rgba(var(--red), var(--green), 0, var(--opacity)) + + $hue: calc(120 - var(--hotness) * 120) + $opacity: calc(var(--hotness) * var(--hotness) / 3 + 0.1) + + background-color: hsla($hue, 75%, 50%, $opacity) !important + font-weight: calc(var(--hotness) * 200 + 400) + +.dual-heated + --hotness: 0 + + $hue: calc(240 - var(--hotness) * 120) + $opacity: calc(((var(--hotness) - 1) * (var(--hotness) - 1)) / 3 + 0.1) + + background-color: hsla($hue, 75%, 50%, $opacity) !important + font-weight: calc(((var(--hotness) - 1) * (var(--hotness) - 1)) * 200 + 400) .uuid font-family: monospace @@ -1232,3 +1242,17 @@ a.breadcrumbs__home font-family: monospace overflow: auto max-height: 75vh + +.labeled-checkbox + display: grid + grid-gap: 0 7px + grid-template-columns: 20px 1fr + grid-template-areas: "checkbox label" + + &__checkbox + grid-area: checkbox + place-self: start center + line-height: 0 + + &__label + grid-area: label diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index cbdda090b..80a9bd0b2 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -32,6 +32,8 @@ BtnLecInvDecline: Ablehnen BtnCorrInvAccept: Annehmen BtnCorrInvDecline: Ablehnen BtnSubmissionsAssign: Abgaben automatisch zuteilen +BtnAllocationCompute: Vergabe berechnen +BtnAllocationAccept: Vergabe akzeptieren Aborted: Abgebrochen @@ -1220,6 +1222,8 @@ MenuParticipantsList: Kursteilnehmerlisten MenuParticipantsIntersect: Überschneidung von Kursteilnehmern MenuAllocationUsers: Bewerber MenuAllocationPriorities: Zentrale Dringlichkeiten +MenuAllocationCompute: Platzvergabe berechnen +MenuAllocationAccept: Platzvergabe akzeptieren BreadcrumbSubmissionFile: Datei BreadcrumbSubmissionUserInvite: Einladung zur Abgabe @@ -1287,6 +1291,8 @@ BreadcrumbExamAutoOccurrence: Automatische Termin-/Raumverteilung BreadcrumbStorageKey: Lokalen Schlüssel generieren BreadcrumbAllocationUsers: Bewerber BreadcrumbAllocationPriorities: Zentrale Dringlichkeiten +BreadcrumbAllocationCompute: Platzvergabe berechnen +BreadcrumbAllocationAccept: Platzvergabe akzeptieren ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn} ExternalExamGrades coursen@CourseName examn@ExamName: Prüfungsleistungen: #{coursen}, #{examn} @@ -2355,7 +2361,6 @@ InfoLecturerTutorials: Tutorien InfoLecturerExams: Prüfungen InfoLecturerAllocations: Zentralanmeldungen -ParticipantsIntersectCourseOption tid@TermId ssh@SchoolId coursen@CourseName: #{tid} - #{ssh} - #{coursen} ParticipantsIntersectCourses: Kurse AllocationUsersTitle tid@TermId ssh@SchoolId ash@AllocationShorthand: #{tid}-#{ssh}-#{ash}: Bewerber @@ -2393,4 +2398,26 @@ ExampleUser2Surname: Musterstudent ExampleUser2DisplayName: Musterstudent Martha ExampleUser3FirstName: Maria ExampleUser3Surname: Beispiel -ExampleUser3DisplayName: Beispiel \ No newline at end of file +ExampleUser3DisplayName: Beispiel + +AllocationUsersMissingPriorities: Teilnehmer ohne zentrale Dringlichkeit +AllocationUsersMissingPrioritiesTip: Es muss sichergestellt sein, dass keine Teilnehmer unberechtigt aus der Zentralvergabe ausgeschlossen werden, indem ihnen keine zentrale Dringlichkeit zugewiesen wurde. +AllocationUsersMissingPrioritiesOk: Es wurde sichergestellt, dass es für jeden der genannten Benutzer einen zulässigen Grund gibt, warum dieser nicht an der Zentralanmeldung teilnehmen sollte. +AllocationRestrictCourses: Kurse einschränken +AllocationRestrictCoursesTip: Sollen nur Plätze für eine Teilmenge von Kursen zugewiesen werden? So können u.A. Nachrücker verteilt werden. Diese Funktionalität sollte nur verwendet werden, wenn manche Kurse aus zulässigen Gründen ausgeschlossen werden müssen; z.B. weil ein Seminar bereits ein Treffen zur Organisation hatte und nun keine weiteren Teilnehmer mehr akzeptieren kann. +AllocationRestrictCoursesSelection: Kurse +AllocationRestrictCoursesSelectionTip: Teilnehmer werden nur auf die Kurse verteilt, die hier angegeben werden. +AllocationUsersMissingPrioritiesNotOk: Zentralvergabe kann nicht erfolgen, solange nicht allen Teilnehmern, die nicht explizit von der Vergabe ausgeschlossen wurden („Teilnehmer ohne zentrale Dringlichkeit”), eine zentrale Dringlichkeit zugewiesen wurde! +AllocationComputed: Eine mögliche Zentralvergabe wurde berechnet und in Ihrer Session gespeichert. Es wurden noch keine Änderungen vorgenommen! +AllocationOnlyCompute: Durch Senden dieses Formulars wird zunächst nur eine mögliche Zentralvergabe berechnet und zur Kontrolle temporär gespeichert. Es werden keine Änderungen am Stand der Datenbank vorgenommen oder Benachrichtigungen verschickt. +AllocationAcceptFormDoesNotMatchSession: Das Formular zum Akzeptieren der Vergabe wurde für ein anderes Vergabeergebnis erzeugt, als aktuell in Ihrer Session gespeichert ist. +ComputedAllocation: Berechnete Vergabe +AllocationAccepted: Zentralvergabe gespeichert. +AllocationMatchedUsers: Neu zugeteilt +AllocationUnmatchedUsers: Teilnehmer ohne zugeteilte Plätze +AllocationUnmatchedCourses: Kurse ohne zugeteilte Teilnehmer +AllocationTime: Zeitpunkt der Vergabe +AllocationRequestedPlaces: Angefragte Plätze +AllocationOfferedPlaces: Angebotene Plätze + +CourseOption tid@TermId ssh@SchoolId coursen@CourseName: #{tid} - #{ssh} - #{coursen} \ No newline at end of file diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 9b7872b1c..1a986ce37 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -2355,7 +2355,6 @@ InfoLecturerTutorials: Tutorials InfoLecturerExams: Exams InfoLecturerAllocations: Central allocations -ParticipantsIntersectCourseOption tid ssh coursen: #{tid} - #{ssh} - #{coursen} ParticipantsIntersectCourses: Courses AllocationUsersTitle tid ssh ash: #{tid}-#{ssh}-#{ash}: Applicants @@ -2393,4 +2392,6 @@ ExampleUser2Surname: Musterstudent ExampleUser2DisplayName: Musterstudent Martha ExampleUser3FirstName: Maria ExampleUser3Surname: Example -ExampleUser3DisplayName: Example \ No newline at end of file +ExampleUser3DisplayName: Example + +CourseOption tid ssh coursen: #{tid} - #{ssh} - #{coursen} \ No newline at end of file diff --git a/package.yaml b/package.yaml index cf102e0d6..c4616ebab 100644 --- a/package.yaml +++ b/package.yaml @@ -185,8 +185,10 @@ default-extensions: - DeriveFunctor - DeriveFoldable - DeriveTraversable + - DeriveAnyClass - DerivingStrategies - DerivingVia + - GeneralizedNewtypeDeriving - DataKinds - BinaryLiterals - PolyKinds diff --git a/routes b/routes index 0e6777f0a..125b6da56 100644 --- a/routes +++ b/routes @@ -110,6 +110,8 @@ /course/#CryptoUUIDCourse/apply AApplyR POST !timeANDallocation-registered /users AUsersR GET POST !allocation-admin /priorities APriosR GET POST !allocation-admin + /compute AComputeR GET POST !allocation-admin + /accept AAcceptR GET POST !allocation-admin /participants ParticipantsListR GET !evaluation /participants/#TermId/#SchoolId ParticipantsR GET !evaluation diff --git a/src/Crypto/Hash/Instances.hs b/src/Crypto/Hash/Instances.hs index ae803ae92..27304d542 100644 --- a/src/Crypto/Hash/Instances.hs +++ b/src/Crypto/Hash/Instances.hs @@ -43,3 +43,6 @@ instance HashAlgorithm hash => ToJSON (Digest hash) where instance HashAlgorithm hash => FromJSON (Digest hash) where parseJSON = withText "Digest" $ either (fail . unpack) return . parseUrlPiece + +instance Hashable (Digest hash) where + hashWithSalt s = (hashWithSalt s :: ByteString -> Int) . convert diff --git a/src/Foundation.hs b/src/Foundation.hs index 35bcd7871..ff2328d83 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -2033,6 +2033,8 @@ instance YesodBreadcrumbs UniWorX where return (CI.original courseName, Just $ AllocationR tid ssh ash AShowR) AUsersR -> i18nCrumb MsgBreadcrumbAllocationUsers . Just $ AllocationR tid ssh ash AShowR APriosR -> i18nCrumb MsgBreadcrumbAllocationPriorities . Just $ AllocationR tid ssh ash AUsersR + AComputeR -> i18nCrumb MsgBreadcrumbAllocationCompute . Just $ AllocationR tid ssh ash AUsersR + AAcceptR -> i18nCrumb MsgBreadcrumbAllocationAccept . Just $ AllocationR tid ssh ash AUsersR breadcrumb ParticipantsListR = i18nCrumb MsgBreadcrumbParticipantsList $ Just CourseListR breadcrumb (ParticipantsR _ _) = i18nCrumb MsgBreadcrumbParticipants $ Just ParticipantsListR @@ -3024,6 +3026,17 @@ pageActions (AllocationR tid ssh ash AShowR) = return } , navChildren = [] } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuAllocationCompute + , navRoute = AllocationR tid ssh ash AComputeR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } ] pageActions (AllocationR tid ssh ash AUsersR) = return [ NavPageActionPrimary @@ -3037,6 +3050,17 @@ pageActions (AllocationR tid ssh ash AUsersR) = return } , navChildren = [] } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuAllocationCompute + , navRoute = AllocationR tid ssh ash AComputeR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } ] pageActions CourseListR = do participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR diff --git a/src/Handler/Allocation.hs b/src/Handler/Allocation.hs index 9ff9b336a..5162e86a5 100644 --- a/src/Handler/Allocation.hs +++ b/src/Handler/Allocation.hs @@ -9,3 +9,5 @@ import Handler.Allocation.Register as Handler.Allocation import Handler.Allocation.List as Handler.Allocation import Handler.Allocation.Users as Handler.Allocation import Handler.Allocation.Prios as Handler.Allocation +import Handler.Allocation.Compute as Handler.Allocation +import Handler.Allocation.Accept as Handler.Allocation diff --git a/src/Handler/Allocation/Accept.hs b/src/Handler/Allocation/Accept.hs new file mode 100644 index 000000000..f52641ad3 --- /dev/null +++ b/src/Handler/Allocation/Accept.hs @@ -0,0 +1,163 @@ +module Handler.Allocation.Accept + ( SessionDataAllocationResults(..) + , AllocationAcceptButton(..) + , allocationAcceptForm + , getAAcceptR, postAAcceptR + ) where + +import Import +import Handler.Utils +import Handler.Utils.Allocation + +import Data.Map ((!?)) +import qualified Data.Map as Map + +import qualified Database.Esqueleto as E +import qualified Control.Monad.State.Class as State + +import Data.Semigroup (Dual(..)) + + +newtype SessionDataAllocationResults = SessionDataAllocationResults + { getSessionDataAllocationResults :: Map ( TermId + , SchoolId + , AllocationShorthand + ) + ( UTCTime + , AllocationFingerprint + , Set (UserId, CourseId) + , Seq (MatchingLog UserId CourseId Natural) + ) + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (ToJSON, FromJSON) + deriving (Monoid, Semigroup) via Dual (Map (TermId, SchoolId, AllocationShorthand) (UTCTime, AllocationFingerprint, Set (UserId, CourseId), Seq (MatchingLog UserId CourseId Natural))) + +makeWrapped ''SessionDataAllocationResults + + +data AllocationAcceptButton + = BtnAllocationAccept + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + +nullaryPathPiece ''AllocationAcceptButton $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''AllocationAcceptButton id + +instance Button UniWorX AllocationAcceptButton where + btnClasses BtnAllocationAccept = [BCIsButton, BCPrimary] + + +allocationAcceptForm :: AllocationId -> DB (Maybe (Form (UTCTime, AllocationFingerprint, Set (UserId, CourseId), Seq (MatchingLog UserId CourseId Natural)))) +allocationAcceptForm aId = runMaybeT $ do + Allocation{..} <- MaybeT $ get aId + SessionDataAllocationResults allocMap <- MaybeT $ lookupSessionJson SessionAllocationResults + allocRes@(allocTime, allocFp, allocMatching, _) <- hoistMaybe $ allocMap !? (allocationTerm, allocationSchool, allocationShorthand) + $logInfoS "allocationAcceptForm" $ tshow allocRes + + allocationUsers <- fmap (map $ bimap E.unValue E.unValue) . lift . E.select . E.from $ \allocationUser -> do + E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val aId + E.&&. E.not_ (E.isNothing $ allocationUser E.^. AllocationUserPriority) + let applications = E.subSelectCount . E.from $ \courseApplication -> + E.where_ $ courseApplication E.^. CourseApplicationAllocation E.==. E.val (Just aId) + E.&&. courseApplication E.^. CourseApplicationUser E.==. allocationUser E.^. AllocationUserUser + return . (allocationUser E.^. AllocationUserUser, ) $ E.case_ + [ E.when_ (E.castNum (allocationUser E.^. AllocationUserTotalCourses) E.>. applications) + E.then_ (applications :: E.SqlExpr (E.Value Int)) + ] + (E.else_ . E.castNum $ allocationUser E.^. AllocationUserTotalCourses) + let allocationPlacesRequested = sumOf (folded . _2) allocationUsers + userAllocations = ofoldr (\(uid, _cid) -> Map.insertWith (+) uid 1) Map.empty allocMatching + + allocationUsers' <- hoistMaybe $ + let (res, leftoverAllocs) = foldr (\user@(uid, _) (acc, allocCounts) + -> ( (user, Map.findWithDefault 0 uid allocCounts) : acc + , Map.delete uid allocCounts + )) + ([] , userAllocations) allocationUsers + in guardOn (null leftoverAllocs) res :: Maybe [((UserId, Int), Integer)] + + let unmatchedUsers = olength $ filter ((<= 0) . view _2) allocationUsers' + + allocationCourses <- fmap (map $ over _3 E.unValue) . lift . E.select . E.from $ \(allocationCourse `E.InnerJoin` course) -> do + E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId + E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId + let participants = E.subSelectCount . E.from $ \courseParticipant -> + E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId + return (allocationCourse, course, participants) + let allocationCapacity = sumOf (folded . _2 . _entityVal . _courseCapacity . _Just) allocationCourses + + let courseAllocations = ofoldr (\(_uid, cid) -> Map.insertWith (+) cid 1) Map.empty allocMatching + allocationCourses' <- hoistMaybe $ + let (res, leftoverAllocs) = foldr (\course@(_, Entity cid _, _) (acc, allocCounts) + -> ( (course, Map.findWithDefault 0 cid allocCounts) : acc + , Map.delete cid allocCounts + )) + ([] , courseAllocations) allocationCourses + in guardOn (null leftoverAllocs) res :: Maybe [((Entity AllocationCourse, Entity Course, Int), Integer)] + + let unmatchedCourses = olength $ filter ((<= 0) . view _2) allocationCourses' + + let validateMatches = + guardValidation MsgAllocationAcceptFormDoesNotMatchSession =<< State.get + + return . (set (mapped . mapped . _1 . mapped) allocRes) . validateForm validateMatches . identifyForm FIDAllocationAccept $ \csrf -> do + (prevAllocRes, prevAllocView) <- mreq hiddenField "" $ Just allocFp + let prevAllocMatches = (== allocFp) <$> prevAllocRes + + let + showTerms + | [_] <- nubOn (view $ _1 . _2 . _entityVal . _courseTerm) allocationCourses' + = False + | otherwise + = True + showSchools + | [_] <- nubOn (view $ _1 . _2 . _entityVal . _courseSchool) allocationCourses' + = False + | otherwise + = True + optimumAllocated = round . (* optimumProportion) . fromIntegral + where optimumProportion :: Rational + optimumProportion + | allocationCapacity == 0 = 0 + | otherwise = fromIntegral allocationPlacesRequested % fromIntegral allocationCapacity + allocHeat capN allocated + | optimumAllocated capN >= capN + = 2 - coHeat capN allocated * 2 + | otherwise + = 2 - dualHeat (optimumAllocated capN) capN allocated + + return (prevAllocMatches, $(widgetFile "allocation/accept")) + +getAAcceptR, postAAcceptR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html +getAAcceptR = postAAcceptR +postAAcceptR tid ssh ash = do + (((_, acceptView), acceptEnctype), didStore) <- runDB $ do + aId <- getKeyBy404 $ TermSchoolAllocationShort tid ssh ash + + acceptForm <- maybe (redirect $ AllocationR tid ssh ash AComputeR) return =<< allocationAcceptForm aId + + formRes@((acceptRes, _), _) <- liftHandler $ runFormPost acceptForm + + didStore <- formResultMaybe acceptRes $ \(now, allocFp, allocMatchings, allocLog) -> do + modifySessionJson SessionAllocationResults . fmap (assertM $ not . views _Wrapped onull) . over (mapped . _Wrapped :: Setter' (Maybe SessionDataAllocationResults) _) $ + Map.filterWithKey (\(tid', ssh', ash') (_, allocFp', _, _) -> + or [ tid' /= tid + , ssh' /= ssh + , ash' /= ash + , allocFp' /= allocFp + ]) + storeAllocationResult aId now (allocFp, allocMatchings, allocLog) + return $ Just () + + return (formRes, is _Just didStore) + + when didStore $ do + addMessageI Success MsgAllocationAccepted + redirect $ AllocationR tid ssh ash AUsersR + + siteLayoutMsg MsgMenuAllocationAccept $ do + setTitleI MsgMenuAllocationAccept + + wrapForm' BtnAllocationAccept acceptView def + { formEncoding = acceptEnctype + } diff --git a/src/Handler/Allocation/Compute.hs b/src/Handler/Allocation/Compute.hs new file mode 100644 index 000000000..b4b7041f2 --- /dev/null +++ b/src/Handler/Allocation/Compute.hs @@ -0,0 +1,130 @@ +module Handler.Allocation.Compute + ( getAComputeR + , postAComputeR + ) where + +import Import + +import Handler.Utils +import Handler.Utils.Allocation +import Handler.Allocation.Accept (SessionDataAllocationResults(..)) + +import qualified Data.Set as Set +import qualified Data.Map as Map + +import qualified Database.Esqueleto as E + +import qualified Control.Monad.State.Class as State + + +data AllocationComputeForm = AllocationComputeForm + { acfMissingPrioritiesOk :: Set UserId + , acfRestrictCourses :: Maybe (Set CourseId) + } + +data AllocationComputeButton + = BtnAllocationCompute + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + +nullaryPathPiece ''AllocationComputeButton $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''AllocationComputeButton id + +instance Button UniWorX AllocationComputeButton where + btnClasses BtnAllocationCompute = [BCIsButton, BCPrimary] + +missingPrioritiesUsers :: AllocationId -> DB (Map UserId User) +missingPrioritiesUsers aId = $cachedHereBinary aId $ do + usersWithoutPrio <- E.select . E.from $ \(user `E.InnerJoin` allocationUser) -> do + E.on $ user E.^. UserId E.==. allocationUser E.^. AllocationUserUser + E.&&. allocationUser E.^. AllocationUserAllocation E.==. E.val aId + + -- Ignore users without applications + E.where_ . E.exists . E.from $ \courseApplication -> do + E.where_ $ courseApplication E.^. CourseApplicationAllocation E.==. E.just (E.val aId) + E.where_ . E.exists . E.from $ \allocationCourse -> + E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. courseApplication E.^. CourseApplicationCourse + E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId + + E.where_ . E.isNothing $ allocationUser E.^. AllocationUserPriority + + return user + + return $ toMapOf (folded .> _entityVal) usersWithoutPrio + +missingPriorities :: AllocationId -> AForm DB (Set UserId) +missingPriorities aId = wFormToAForm $ do + usersWithoutPrio <- lift . lift $ missingPrioritiesUsers aId + + let missingPriosField = checkBoxField { fieldView = missingPriosFieldView } + where + missingPriosFieldView theId name attrs res isReq + = $(i18nWidgetFile "allocation-confirm-missing-prios") + where checkBoxFieldView = labeledCheckBoxView (i18n MsgAllocationUsersMissingPrioritiesOk) theId name attrs res isReq + + if + | null usersWithoutPrio + -> return $ pure Set.empty + | otherwise + -> fmap (bool Set.empty $ Map.keysSet usersWithoutPrio) <$> wpreq missingPriosField (fslI MsgAllocationUsersMissingPriorities & setTooltip MsgAllocationUsersMissingPrioritiesTip) (Just False) + + +restrictCourses :: (MonadHandler m, HandlerSite m ~ UniWorX) => AllocationId -> AForm m (Maybe (Set CourseId)) +restrictCourses aId = hoistAForm liftHandler $ + optionalActionA selectCourses (fslI MsgAllocationRestrictCourses & setTooltip MsgAllocationRestrictCoursesTip) (Just False) + where + selectCourses = courseSelectForm query coursePred miButtonAction' miIdent' fSettings fRequired mPrev + where + query = E.from $ \(course `E.InnerJoin` allocationCourse) -> do + E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse + E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId + return course + coursePred _ = return True + mPrev = Nothing + fRequired = True + fSettings = fslI MsgAllocationRestrictCoursesSelection & setTooltip MsgAllocationRestrictCoursesSelectionTip + miIdent' :: Text + miIdent' = "course-selection" + miButtonAction' _ = Nothing + +allocationComputeForm :: AllocationId -> AForm DB AllocationComputeForm +allocationComputeForm aId = wFormToAForm $ do + onlyComputeMsg <- messageI Info MsgAllocationOnlyCompute + + aFormToWForm $ AllocationComputeForm + <$ aformMessage onlyComputeMsg + <*> missingPriorities aId + <*> restrictCourses aId + +validateAllocationComputeForm :: AllocationId -> FormValidator AllocationComputeForm DB () +validateAllocationComputeForm aId = do + usersWithoutPrio <- lift $ missingPrioritiesUsers aId + + missingOk <- State.gets acfMissingPrioritiesOk + guardValidation MsgAllocationUsersMissingPrioritiesNotOk $ + Map.keysSet usersWithoutPrio `Set.isSubsetOf` missingOk + + +getAComputeR, postAComputeR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html +getAComputeR = postAComputeR +postAComputeR tid ssh ash = do + (_, ((_computeFormRes, computeFormView), computeFormEnctype)) <- runDB $ do + aEnt@(Entity aId _) <- getBy404 $ TermSchoolAllocationShort tid ssh ash + formRes@((computeFormRes, _), _) <- runFormPost . validateForm (validateAllocationComputeForm aId) . renderAForm FormStandard $ allocationComputeForm aId + + formResult computeFormRes $ \AllocationComputeForm{..} -> do + now <- liftIO getCurrentTime + (allocFp, allocMatching, allocLog) <- computeAllocation aId acfRestrictCourses + tellSessionJson SessionAllocationResults . SessionDataAllocationResults $ + Map.singleton (tid, ssh, ash) (now, allocFp, allocMatching, allocLog) + addMessageI Success MsgAllocationComputed + redirect $ AllocationR tid ssh ash AUsersR -- Redirect aborts transaction for safety + + return (aEnt, formRes) + + siteLayoutMsg MsgMenuAllocationCompute $ do + setTitleI MsgMenuAllocationCompute + + wrapForm' BtnAllocationCompute computeFormView def + { formEncoding = computeFormEnctype + } diff --git a/src/Handler/Allocation/Users.hs b/src/Handler/Allocation/Users.hs index 6f792d22e..567b2f7cb 100644 --- a/src/Handler/Allocation/Users.hs +++ b/src/Handler/Allocation/Users.hs @@ -6,6 +6,8 @@ module Handler.Allocation.Users import Import +import Handler.Allocation.Accept (allocationAcceptForm, AllocationAcceptButton(..)) + import Handler.Utils import Handler.Utils.Allocation @@ -103,7 +105,7 @@ instance CsvColumnsExplained AllocationUserTableCsv where getAUsersR, postAUsersR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html getAUsersR = postAUsersR postAUsersR tid ssh ash = do - usersTable <- runDB $ do + (usersTable, acceptForm) <- runDB $ do Entity aId _ <- getBy404 $ TermSchoolAllocationShort tid ssh ash now <- liftIO getCurrentTime resultsDone <- (<= NTop (Just now)) . NTop <$> allocationDone aId @@ -157,7 +159,7 @@ postAUsersR tid ssh ash = do (res ^. resultAppliedCourses) assigned = maxAssign - res ^. resultAssignedCourses in cellAttrs <>~ [ ("class", "heated") - , ("style", [st|--hotness: #{tshow (heat maxAssign assigned)}|]) + , ("style", [st|--hotness: #{tshow (coHeat maxAssign assigned)}|]) ] coursesModalApplied = coursesModal $ \res -> E.from $ \(course `E.InnerJoin` courseApplication) -> do E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse @@ -223,9 +225,20 @@ postAUsersR tid ssh ash = do & defaultSorting [SortAscBy "priority", SortAscBy "user-matriculation"] & defaultPagesize PagesizeAll - dbTableDB' allocationUsersDBTableValidator allocationUsersDBTable + usersTable <- dbTableDB' allocationUsersDBTableValidator allocationUsersDBTable + + acceptForm <- allocationAcceptForm aId + + return (usersTable, acceptForm) + + acceptView <- for acceptForm $ \acceptForm' -> do + (acceptWgt, acceptEnctype) <- generateFormPost acceptForm' + return $ wrapForm' BtnAllocationAccept acceptWgt def + { formAction = Just . SomeRoute $ AllocationR tid ssh ash AAcceptR + , formEncoding = acceptEnctype + } siteLayoutMsg MsgMenuAllocationUsers $ do setTitleI $ MsgAllocationUsersTitle tid ssh ash - usersTable + $(widgetFile "allocation/users") diff --git a/src/Handler/Participants.hs b/src/Handler/Participants.hs index 5cd14f224..89076bea1 100644 --- a/src/Handler/Participants.hs +++ b/src/Handler/Participants.hs @@ -21,8 +21,6 @@ import qualified Data.Csv as Csv import qualified Data.Conduit.List as C -import qualified Data.List as List - data ParticipantEntry = ParticipantEntry { peCourse :: CourseName @@ -87,37 +85,16 @@ getParticipantsIntersectR, postParticipantsIntersectR :: Handler Html getParticipantsIntersectR = postParticipantsIntersectR postParticipantsIntersectR = do let - miAdd' nudge btn csrf = do - let - courseOptions = optionsPersistCryptoId [] [Desc CourseTerm, Asc CourseSchool, Asc CourseName] (\Course{..} -> MsgParticipantsIntersectCourseOption courseTerm courseSchool courseName) >>= fmap (fmap entityKey) . filterCourseOptions - filterCourseOptions = fmap mkOptionList . filterCourseOptions' . olOptions - where - filterCourseOptions' opts = do - let termSchools = List.nub [ optionInternalValue ^. _entityVal . $(multifocusL 2) _courseTerm _courseSchool | Option{..} <- opts ] - termSchools' <- Set.fromList <$> filterM (\(tid, ssh) -> hasReadAccessTo $ ParticipantsR tid ssh) termSchools - return $ opts - & filter (\Option{ optionInternalValue = Entity _ Course{..} } -> (courseTerm, courseSchool) `Set.member` termSchools') - (courseRes, addView) <- mpopt (selectField courseOptions) (fslI MsgCourse & addName (nudge "course")) Nothing - let res = courseRes <&> \newCourse oldCourses -> pure (Set.toList $ Set.singleton newCourse `Set.difference` Set.fromList oldCourses) - return (res, $(widgetFile "widgets/massinput/participants-intersect/add")) - miCell' cid = do - Course{..} <- liftHandler . runDB $ get404 cid - $(widgetFile "widgets/massinput/participants-intersect/cell") - miButtonAction' _ = Nothing - miLayout' :: MassInputLayout ListLength CourseId () - miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/participants-intersect/layout") - miIdent' :: Text - miIdent' = "participants-intersect" - fSettings = fslI MsgParticipantsIntersectCourses - fRequired = False - mPrev = Nothing - ((coursesRes, coursesView), coursesEnc) <- runFormPost . renderAForm FormStandard $ massInputAccumA miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev + courseQuery = E.from return + termSchoolAccess (Entity _ Course{..}) = + hasReadAccessTo $ ParticipantsR courseTerm courseSchool + ((coursesRes, coursesView), coursesEnc) <- runFormPost . renderAForm FormStandard $ courseSelectForm courseQuery termSchoolAccess (\_ -> Nothing) ("participants-intersect" :: Text) (fslI MsgParticipantsIntersectCourses) False Nothing let formWidget = wrapForm coursesView def { formAction = Just . SomeRoute $ ParticipantsIntersectR :#: ("table" :: Text) , formEncoding = coursesEnc } - intersectionsRes <- formResultMaybe coursesRes . fmap (fmap Just) $ \(Set.fromList -> cids) -> runDB $ do + intersectionsRes <- formResultMaybe coursesRes . fmap (fmap Just) $ \cids -> runDB $ do let coursePairs = do cid <- Set.toList cids other <- Set.toList . snd $ Set.split cid cids diff --git a/src/Handler/Utils/Allocation.hs b/src/Handler/Utils/Allocation.hs index d756228f0..084cb4b56 100644 --- a/src/Handler/Utils/Allocation.hs +++ b/src/Handler/Utils/Allocation.hs @@ -3,7 +3,7 @@ module Handler.Utils.Allocation , ordinalPriorities , sinkAllocationPriorities , computeAllocation - , doAllocation + -- , doAllocation -- Use `storeAllocationResult` , ppMatchingLog , storeAllocationResult ) where @@ -118,6 +118,8 @@ computeAllocation allocId cRestr = do guard $ Map.member courseApplicationCourse capacities return ((courseApplicationUser, courseApplicationCourse), (courseApplicationAllocationPriority, courseApplicationRatingPoints)) + $logErrorS "computeAllocation" $ tshow preferences + gradeScale <- getsYesod $ view _appAllocationGradeScale gradeOrdinalProportion <- getsYesod $ view _appAllocationGradeOrdinalProportion let ordinalUsers = getSum . flip foldMap users'' $ \(_, prio) -> case prio of @@ -173,10 +175,10 @@ computeAllocation allocId cRestr = do doAllocation :: AllocationId + -> UTCTime -> Set (UserId, CourseId) -> DB () -doAllocation allocId regs = do - now <- liftIO getCurrentTime +doAllocation allocId now regs = forM_ regs $ \(uid, cid) -> do mField <- (courseApplicationField . entityVal =<<) . listToMaybe <$> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Just allocId] [] void . insertUnique $ CourseParticipant cid uid now mField (Just allocId) @@ -193,10 +195,10 @@ ppMatchingLog = unlines . map (tshow . pretty) . otoList . over (param @2) fromSqlKey storeAllocationResult :: AllocationId + -> UTCTime -> (AllocationFingerprint, Set (UserId, CourseId), Seq (MatchingLog UserId CourseId Natural)) -> DB () -storeAllocationResult allocId (allocFp, allocMatchings, ppMatchingLog -> allocLog) = do - now <- liftIO getCurrentTime +storeAllocationResult allocId now (allocFp, allocMatchings, ppMatchingLog -> allocLog) = do insert_ . AllocationMatching allocId allocFp <=< insert $ File "matchings.log" (Just $ encodeUtf8 allocLog) now - doAllocation allocId allocMatchings + doAllocation allocId now allocMatchings diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 8fd03620d..3b1325f7f 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -35,7 +35,7 @@ import qualified Database.Esqueleto.Utils as E import qualified Data.Set as Set -import Data.Map ((!)) +import Data.Map ((!), (!?)) import qualified Data.Map as Map import Control.Monad.Writer.Class @@ -1083,24 +1083,59 @@ optionsPersistCryptoId :: forall site backend a msg. , PersistQueryRead backend , HasCryptoUUID (Key a) (HandlerFor site) , KnownSymbol (CryptoIDNamespace UUID (Key a)) - , PathPiece (Key a) , RenderMessage site msg , YesodPersistBackend site ~ backend , PersistRecordBackend a backend + , PathPiece (Key a) ) => [Filter a] -> [SelectOpt a] -> (a -> msg) -> HandlerFor site (OptionList (Entity a)) -optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do - mr <- getMessageRender - pairs <- runDB $ selectList filts ords - cPairs <- forM pairs $ \e@(Entity key _) -> (,) <$> encrypt key <*> pure e - return $ map (\(cId, e@(Entity _key value)) -> Option - { optionDisplay = mr (toDisplay value) - , optionInternalValue = e - , optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a)) - }) cPairs +optionsPersistCryptoId filts ords toDisplay = do + ents <- runDB $ selectList filts ords + optionsCryptoIdF ents (return . entityKey) (return . toDisplay . entityVal) + +optionsCryptoIdE :: forall site backend a msg. + ( YesodPersist site + , PersistQueryRead backend, PersistUniqueRead backend + , HasCryptoUUID (Key a) (HandlerFor site) + , KnownSymbol (CryptoIDNamespace UUID (Key a)) + , RenderMessage site msg + , YesodPersistBackend site ~ backend + , PersistRecordBackend a backend + , BackendCompatible SqlBackend backend + , PathPiece (Key a) + ) + => E.SqlQuery (E.SqlExpr (Entity a)) + -> (a -> msg) + -> HandlerFor site (OptionList (Entity a)) +optionsCryptoIdE query toDisplay = do + ents <- runDB $ E.select query + optionsCryptoIdF ents (return . entityKey) (return . toDisplay . entityVal) + +optionsCryptoIdF :: forall m mono k msg. + ( HasCryptoUUID k m + , KnownSymbol (CryptoIDNamespace UUID k) + , RenderMessage (HandlerSite m) msg + , MonoFoldable mono + , MonadHandler m + , PathPiece k + ) + => mono + -> (Element mono -> m k) + -> (Element mono -> m msg) + -> m (OptionList (Element mono)) +optionsCryptoIdF (otoList -> iVals) toExtVal toMsg + = fmap mkOptionList . forM iVals $ \optionInternalValue -> do + cID <- encrypt =<< toExtVal optionInternalValue + optionDisplay <- getMessageRender <*> toMsg optionInternalValue + return Option + { optionDisplay + , optionExternalValue = toPathPiece (cID :: CryptoUUID k) + , optionInternalValue + } + examOccurrenceField :: ( MonadHandler m , HandlerSite m ~ UniWorX @@ -1523,3 +1558,44 @@ explainOptionList ol mkExplanation = do olOptions' <- forM olOptions $ \opt@Option{..} -> (opt, ) <$> runMaybeT (mkExplanation optionInternalValue) return (olOptions', olReadExternal) +courseSelectForm :: forall ident handler. + ( PathPiece ident + , MonadHandler handler, HandlerSite handler ~ UniWorX + , MonadThrow handler + ) + => E.SqlQuery (E.SqlExpr (Entity Course)) + -> (Entity Course -> Handler Bool) + -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) + -> ident + -> FieldSettings UniWorX + -> Bool + -> Maybe (Set CourseId) + -> AForm handler (Set CourseId) +courseSelectForm query coursePred miButtonAction' miIdent' fSettings fRequired mPrev + = fmap Set.fromList . massInputAccumA miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired $ Set.toList <$> mPrev + where + query' = do + course <- query + E.orderBy [ E.desc $ course E.^. CourseTerm + , E.asc $ course E.^. CourseSchool + , E.asc $ course E.^. CourseName + ] + return course + + miAdd' nudge btn csrf = do + let courseOptions = optionsCryptoIdE query' (\Course{..} -> MsgCourseOption courseTerm courseSchool courseName) >>= fmap (fmap entityKey . mkOptionList) . filterM (coursePred . optionInternalValue) . olOptions + + (courseRes, addView) <- mpopt (hoistField liftHandler $ selectField courseOptions) (fslI MsgCourse & addName (nudge "course")) Nothing + let res = courseRes <&> \newCourse oldCourses -> pure (Set.toList $ Set.singleton newCourse `Set.difference` Set.fromList oldCourses) + return (res, $(widgetFile "widgets/massinput/courses/add")) + miCell' cid = do + Course{..} <- liftHandler . runDB $ get404 cid + $(widgetFile "widgets/massinput/courses/cell") + miLayout' :: MassInputLayout ListLength CourseId () + miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/courses/layout") + +labeledCheckBoxView :: Widget + -> Text -> Text -> [(Text, Text)] -> Either Text Bool -> Bool -> Widget +labeledCheckBoxView label theId name attrs val isReq = $(widgetFile "widgets/fields/labeled-checkbox") + where + checkBoxView = fieldView (checkBoxField :: Field Handler Bool) theId name attrs val isReq diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index ef53aeb4d..e612b5fe7 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/src/Handler/Utils/Form/MassInput.hs @@ -118,13 +118,13 @@ newtype MapLiveliness l1 l2 = MapLiveliness { unMapLiveliness :: Map (BoxCoord l makeWrapped ''MapLiveliness -deriving instance (Ord (BoxCoord l1), Lattice l2) => Lattice (MapLiveliness l1 l2) -deriving instance (Ord (BoxCoord l1), BoundedJoinSemiLattice l2) => BoundedJoinSemiLattice (MapLiveliness l1 l2) -deriving instance (Ord (BoxCoord l1), Finite (BoxCoord l1), BoundedMeetSemiLattice l2) => BoundedMeetSemiLattice (MapLiveliness l1 l2) -deriving instance (Eq (BoxCoord l1), Eq l2) => Eq (MapLiveliness l1 l2) -deriving instance (Ord (BoxCoord l1), Ord l2) => Ord (MapLiveliness l1 l2) -deriving instance (Ord (BoxCoord l1), Read (BoxCoord l1), Read l2) => Read (MapLiveliness l1 l2) -deriving instance (Show (BoxCoord l1), Show l2) => Show (MapLiveliness l1 l2) +deriving newtype instance (Ord (BoxCoord l1), Lattice l2) => Lattice (MapLiveliness l1 l2) +deriving newtype instance (Ord (BoxCoord l1), BoundedJoinSemiLattice l2) => BoundedJoinSemiLattice (MapLiveliness l1 l2) +deriving newtype instance (Ord (BoxCoord l1), Finite (BoxCoord l1), BoundedMeetSemiLattice l2) => BoundedMeetSemiLattice (MapLiveliness l1 l2) +deriving newtype instance (Eq (BoxCoord l1), Eq l2) => Eq (MapLiveliness l1 l2) +deriving newtype instance (Ord (BoxCoord l1), Ord l2) => Ord (MapLiveliness l1 l2) +deriving newtype instance (Ord (BoxCoord l1), Read (BoxCoord l1), Read l2) => Read (MapLiveliness l1 l2) +deriving newtype instance (Show (BoxCoord l1), Show l2) => Show (MapLiveliness l1 l2) instance (Liveliness l1, Liveliness l2) => Liveliness (MapLiveliness l1 l2) where type BoxCoord (MapLiveliness l1 l2) = (BoxCoord l1, BoxCoord l2) diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index b9e5b5f95..e09b98142 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -95,9 +95,21 @@ editedByW fmt tm usr = do ft <- handlerToWidget $ formatTime fmt tm [whamlet|_{MsgEditedBy usr ft}|] -heat :: Integral a => a -> a -> Double -heat (toInteger -> full) (toInteger -> achieved) - = roundToDigits 3 $ cutOffPercent 0.3 (fromIntegral full^2) (fromIntegral achieved^2) +heat :: ( Real a, Real b ) + => a -> b -> Milli +heat (realToFrac -> full) (realToFrac -> achieved) + = fromRational $ cutOffCoPercent 0.3 (full^2) (achieved^2) -- + +coHeat :: ( Real a, Real b) + => a -> b -> Milli +coHeat (realToFrac -> full) (realToFrac -> achieved) + = fromRational $ cutOffPercent 0.3 (full^2) (achieved^2) + +dualHeat :: ( Real a, Real b, Real c ) + => a -> b -> c -> Milli +dualHeat (realToFrac -> optimal) (realToFrac -> full) (realToFrac -> achieved) + | achieved <= optimal = fromRational $ cutOffPercent 0.3 (optimal ^ 2) (achieved ^ 2) + | otherwise = fromRational $ 1 + cutOffPercent 0 ((full - optimal) ^ 2) ((achieved - optimal) ^ 2) i18n :: forall m msg. ( MonadWidget m diff --git a/src/Utils.hs b/src/Utils.hs index 5e2dc6069..eae6e88fa 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -276,18 +276,35 @@ roundDiv :: (Integral a, Integral b, RealFrac c) => Int -> a -> b -> c roundDiv digits numerator denominator = roundToDigits digits $ fromIntegral numerator / fromIntegral denominator --- | A value between 0 and 1, measuring how close `achieved` is to `full`; 0 meaning very and 1 meaning not at all --- `offset` specifies minimum result value, unless the goal is already achieved )i.e. full <= max(0,achieved) --- Useful for heat maps, with offset giving a visual step between completed and not yet completed -cutOffPercent :: Double -> Double -> Double -> Double -cutOffPercent offset full achieved +-- | @cutOffCoPercent offset full achieved@ returns a value between 0 and 1, measuring how close @achieved@ is to @full@; 0 meaning very and 1 meaning not at all +-- +-- @offset@ specifies minimum result value, unless the @full@ is equal to @achieved@ +-- +-- Useful for heat maps, with offset giving a visual step between completed and not yet completed +cutOffCoPercent :: Rational -> Rational -> Rational -> Rational +cutOffCoPercent (abs -> offset) (abs -> full) (abs -> achieved) + | 0 <= achieved, achieved < full + , full /= 0 + = offset + (1-offset) * (1 - percent) | full <= achieved = 0 - | full <= 0 = 0 - | otherwise = offset + (1-offset) * (1 - percent) + | otherwise = 1 + where + percent = achieved / full + +-- | @cutOffPercent offset full achieved@ returns a value between 0 and 1, measuring how close @achieved@ is to @full@@; 1 meaning very and 0 meaning not at all +-- +-- @offset@ specifies minimum result value, unless @achieved@ is zero +-- +-- Useful for heat maps, with offset giving a visual step between zero and nonzero +cutOffPercent :: Rational -> Rational -> Rational -> Rational +cutOffPercent (abs -> offset) (abs -> full) (abs -> achieved) + | 0 < achieved, achieved <= full + , full /= 0 + = offset + (1-offset) * percent + | achieved <= 0 = 0 + | otherwise = 1 where percent = achieved / full - - ------------ -- Monoid -- @@ -754,6 +771,7 @@ choice = foldr (<|>) empty data SessionKey = SessionActiveAuthTags | SessionInactiveAuthTags | SessionNewStudyTerms | SessionConflictingStudyTerms | SessionBearer + | SessionAllocationResults deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) instance Universe SessionKey instance Finite SessionKey @@ -769,8 +787,8 @@ lookupSessionJson (toPathPiece -> key) = (Aeson.decode' . LBS.fromStrict =<<) <$ modifySessionJson :: (PathPiece k, FromJSON v, ToJSON v, MonadHandler m) => k -> (Maybe v -> Maybe v) -> m () modifySessionJson (toPathPiece -> key) f = lookupSessionJson key >>= maybe (deleteSession key) (setSessionJson key) . f -tellSessionJson :: (PathPiece k, FromJSON v, ToJSON v, MonadHandler m, Monoid v) => k -> v -> m () -tellSessionJson key val = modifySessionJson key $ Just . (`mappend` val) . fromMaybe mempty +tellSessionJson :: (PathPiece k, FromJSON v, ToJSON v, MonadHandler m, Semigroup v) => k -> v -> m () +tellSessionJson key val = modifySessionJson key (`mappend` Just val) takeSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v) -- ^ `lookupSessionJson` followed by `deleteSession` diff --git a/src/Utils/Allocation.hs b/src/Utils/Allocation.hs index ffdd3684d..0fc994407 100644 --- a/src/Utils/Allocation.hs +++ b/src/Utils/Allocation.hs @@ -39,6 +39,11 @@ data MatchingLog student course cloneIndex deriving (Eq, Ord, Read, Show, Generic, Typeable) instance (NFData student, NFData course, NFData cloneIndex) => NFData (MatchingLog student course cloneIndex) +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + , fieldLabelModifier = camelToPathPiece' 1 + } ''MatchingLog + computeMatching :: forall randomGen student course cloneCount cloneIndex capacity studentRatingCourse courseRatingStudent courseRatingStudent'. ( RandomGen randomGen , Ord student, Ord course diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 61fbcad7b..9e5821172 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -226,6 +226,7 @@ data FormIdentifier | FIDAllUsersAction | FIDLanguage | FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm | FIDExamAutoOccurrenceNudge UUID + | FIDAllocationAccept deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where diff --git a/templates/allocation/accept.hamlet b/templates/allocation/accept.hamlet new file mode 100644 index 000000000..a684bc880 --- /dev/null +++ b/templates/allocation/accept.hamlet @@ -0,0 +1,86 @@ +$newline never +#{csrf} +^{fvInput prevAllocView} + +

+ _{MsgComputedAllocation} + +
+
+ _{MsgAllocationRequestedPlaces} +
+ #{allocationPlacesRequested} +
+ _{MsgAllocationOfferedPlaces} +
+ #{allocationCapacity} +
+ _{MsgAllocationTime} +
+ ^{formatTimeW SelFormatDateTime allocTime} +
+ _{MsgAllocationUnmatchedUsers} +
+ #{unmatchedUsers} +
+ _{MsgAllocationUnmatchedCourses} +
+ #{unmatchedCourses} + +
+ + + + $if showTerms + + $forall ((Entity _ AllocationCourse{allocationCourseMinCapacity}, Entity _ Course{courseTerm, courseSchool, courseName, courseCapacity, courseShorthand}, participants), allocated) <- allocationCourses' + + $if showTerms +
+ _{MsgTerm} + $if showSchools + + _{MsgSchool} + + _{MsgCourse} + + _{MsgCourseCapacity} + + _{MsgCourseAllocationMinCapacity} + + _{MsgCourseMembers} + + _{MsgAllocationMatchedUsers} +
+ + + +
+ $maybe capN <- courseCapacity + #{capN} +
+
+ $if allocationCourseMinCapacity > 1 + #{allocationCourseMinCapacity} +
+
+ #{participants} + $maybe capN <- courseCapacity +
+
+ #{allocated} + $nothing +
+
+ #{allocated} + diff --git a/templates/allocation/users.hamlet b/templates/allocation/users.hamlet new file mode 100644 index 000000000..6ca99d859 --- /dev/null +++ b/templates/allocation/users.hamlet @@ -0,0 +1,6 @@ +$newline never +$maybe acceptWgt <- acceptView +
+ ^{acceptWgt} +
+ ^{usersTable} diff --git a/templates/i18n/allocation-confirm-missing-prios/de-de-formal.hamlet b/templates/i18n/allocation-confirm-missing-prios/de-de-formal.hamlet new file mode 100644 index 000000000..16ed09324 --- /dev/null +++ b/templates/i18n/allocation-confirm-missing-prios/de-de-formal.hamlet @@ -0,0 +1,14 @@ +$newline never +

+ Die folgenden Benutzer nehmen nicht an der Zentralvergabe teil, da # + ihnen keine zentrale Dringlichkeit zugeordnet wurde: +

    + $forall User{userDisplayName, userSurname, userMatrikelnummer} <- usersWithoutPrio +
  • + ^{nameWidget userDisplayName userSurname} + $maybe matrikel <- userMatrikelnummer + \ (#{matrikel}) +^{checkBoxFieldView} +

    + Benutzern, die nicht an der Zentralvergabe teilnehmen, werden # + garantiert keine Plätze in Kursen zugeteilt. diff --git a/templates/widgets/fields/labeled-checkbox.hamlet b/templates/widgets/fields/labeled-checkbox.hamlet new file mode 100644 index 000000000..7ef3a3ac1 --- /dev/null +++ b/templates/widgets/fields/labeled-checkbox.hamlet @@ -0,0 +1,7 @@ +$newline never +

    +
    + ^{checkBoxView} +
    +