feat(allocations): compute & accept allocations

2020-03-10 22:36:33 +01:00 · 2020-03-10 22:36:33 +01:00 · 20ef95c142
commit 20ef95c142
parent 936c3666fc
26 changed files with 674 additions and 79 deletions
--- 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
--- 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
+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}
--- 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
+ExampleUser3DisplayName: Example
+
+CourseOption tid ssh coursen: #{tid} - #{ssh} - #{coursen}
--- a/package.yaml
+++ b/package.yaml
@ -185,8 +185,10 @@ default-extensions:
  - DeriveFunctor
  - DeriveFoldable
  - DeriveTraversable
+  - DeriveAnyClass
  - DerivingStrategies
  - DerivingVia
+  - GeneralizedNewtypeDeriving
  - DataKinds
  - BinaryLiterals
  - PolyKinds
--- a/2
+++ b/2
@ -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
--- 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
--- 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
--- 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
--- a/src/Handler/Allocation/Accept.hs
+++ 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
+      }
--- a/src/Handler/Allocation/Compute.hs
+++ 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
+      }
--- 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")
--- 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
--- 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
--- 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
--- 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)
--- 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
--- 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`
--- 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
--- 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
--- a/templates/allocation/accept.hamlet
+++ b/templates/allocation/accept.hamlet
@ -0,0 +1,86 @@
+$newline never
+#{csrf}
+^{fvInput prevAllocView}
+
+<h2>
+  _{MsgComputedAllocation}
+  
+<dl .deflist>
+  <dt .deflist__dt>
+    _{MsgAllocationRequestedPlaces}
+  <dd .deflist__dd>
+    #{allocationPlacesRequested}
+  <dt .deflist__dt>
+    _{MsgAllocationOfferedPlaces}
+  <dd .deflist__dd>
+    #{allocationCapacity}
+  <dt .deflist__dt>
+    _{MsgAllocationTime}
+  <dd .deflist__dd>
+    ^{formatTimeW SelFormatDateTime allocTime}
+  <dt .deflist__dt>
+    _{MsgAllocationUnmatchedUsers}
+  <dd .deflist__dd>
+    #{unmatchedUsers}
+  <dt .deflist__dt>
+    _{MsgAllocationUnmatchedCourses}
+  <dd .deflist__dd>
+    #{unmatchedCourses}
+  
+<div .scrolltable .scrolltable--bordered>
+  <table .table .table--striped .table--hover>
+    <thead>
+      <tr .table__row .table__row--head>
+        $if showTerms
+          <th .table__th>
+            _{MsgTerm}
+        $if showSchools
+          <th .table__th>
+            _{MsgSchool}
+        <th .table__th>
+          _{MsgCourse}
+        <th .table__th>
+          _{MsgCourseCapacity}
+        <th .table__th>
+          _{MsgCourseAllocationMinCapacity}
+        <th .table__th>
+          _{MsgCourseMembers}
+        <th .table__th>
+          _{MsgAllocationMatchedUsers}
+    <tbody>
+      $forall ((Entity _ AllocationCourse{allocationCourseMinCapacity}, Entity _ Course{courseTerm, courseSchool, courseName, courseCapacity, courseShorthand}, participants), allocated) <- allocationCourses'
+        <tr .table__row>
+          $if showTerms
+            <td .table__td>
+              <div .table__td-content>
+                <a href=@{TermCourseListR courseTerm}>
+                  _{ShortTermIdentifier (unTermKey courseTerm)}
+          $if showSchools
+            <td .table__td>
+              <div .table__td-content>
+                <a href=@{TermSchoolCourseListR courseTerm courseSchool}>
+                  #{courseSchool}
+          <td .table__td>
+            <div .table__td-content>
+              <a href=@{CourseR courseTerm courseSchool courseShorthand CShowR}>
+                #{courseName}
+          <td .table__td>
+            <div .table__td-content>
+              $maybe capN <- courseCapacity
+                #{capN}
+          <td .table__td>
+            <div .table__td-content>
+              $if allocationCourseMinCapacity > 1
+                #{allocationCourseMinCapacity}
+          <td .table__td>
+            <div .table__td-content>
+              #{participants}
+          $maybe capN <- courseCapacity
+            <td .table__td .dual-heated style="--hotness: #{allocHeat capN allocated}">
+              <div .table__td-content>
+                #{allocated}
+          $nothing
+            <td .table__td>
+              <div .table__td-content>
+                #{allocated}
+            
--- a/templates/allocation/users.hamlet
+++ b/templates/allocation/users.hamlet
@ -0,0 +1,6 @@
+$newline never
+$maybe acceptWgt <- acceptView
+  <section>
+    ^{acceptWgt}
+<section>
+  ^{usersTable}
--- a/templates/i18n/allocation-confirm-missing-prios/de-de-formal.hamlet
+++ b/templates/i18n/allocation-confirm-missing-prios/de-de-formal.hamlet
@ -0,0 +1,14 @@
+$newline never
+<p>
+  Die folgenden Benutzer nehmen nicht an der Zentralvergabe teil, da #
+  ihnen keine zentrale Dringlichkeit zugeordnet wurde:
+<ul>
+  $forall User{userDisplayName, userSurname, userMatrikelnummer} <- usersWithoutPrio
+    <li>
+      ^{nameWidget userDisplayName userSurname}
+      $maybe matrikel <- userMatrikelnummer
+        \ (#{matrikel})
+^{checkBoxFieldView}
+<p>
+  Benutzern, die nicht an der Zentralvergabe teilnehmen, werden #
+  garantiert keine Plätze in Kursen zugeteilt.
--- a/templates/widgets/fields/labeled-checkbox.hamlet
+++ b/templates/widgets/fields/labeled-checkbox.hamlet
@ -0,0 +1,7 @@
+$newline never
+<div .labeled-checkbox .div-p>
+  <div .labeled-checkbox__checkbox>
+    ^{checkBoxView}
+  <div .labeled-checkbox__label>
+    <label for=#{theId}>
+      ^{label}
--- a/templates/widgets/massinput/participants-intersect/add.hamlet
+++ b/templates/widgets/massinput/participants-intersect/add.hamlet
--- a/templates/widgets/massinput/participants-intersect/cell.hamlet
+++ b/templates/widgets/massinput/participants-intersect/cell.hamlet
--- a/templates/widgets/massinput/participants-intersect/layout.hamlet
+++ b/templates/widgets/massinput/participants-intersect/layout.hamlet