feat(allocations): ui for adding applicants

frontend/src/app.sass

@@ -776,6 +776,9 @@ section
 .allocation__courses
   margin: 20px 0 0 40px
 
+  .form-group__input > &
+    margin: 0
+
 .allocation-course
   display: grid
   grid-template-columns: minmax(105px, 1fr) 9fr

messages/uniworx/de-de-formal.msg

@@ -1375,6 +1375,7 @@ MenuAllocationUsers: Bewerber
 MenuAllocationPriorities: Zentrale Dringlichkeiten
 MenuAllocationCompute: Platzvergabe berechnen
 MenuAllocationAccept: Platzvergabe akzeptieren
+MenuAllocationAddUser: Bewerber hinzufügen
 MenuFaq: FAQ
 MenuSheetPersonalisedFiles: Personalisierte Dateien herunterladen
 MenuCourseSheetPersonalisedFiles: Vorlage für personalisierte Übungsblatt-Dateien herunterladen
@@ -1449,6 +1450,7 @@ BreadcrumbAllocationUsers: Bewerber
 BreadcrumbAllocationPriorities: Zentrale Dringlichkeiten
 BreadcrumbAllocationCompute: Platzvergabe berechnen
 BreadcrumbAllocationAccept: Platzvergabe akzeptieren
+BreadcrumbAllocationAddUser: Bewerber hinzufügen
 BreadcrumbMessageHide: Verstecken
 BreadcrumbFaq: FAQ
 BreadcrumbSheetPersonalisedFiles: Personalisierte Dateien herunterladen
@@ -2707,12 +2709,34 @@ AllocationUsersCsvName tid@TermId ssh@SchoolId ash@AllocationShorthand: #{foldCa
 AllocationPrioritiesMode: Modus
 AllocationPrioritiesNumeric: Numerische Dringlichkeiten
 AllocationPrioritiesOrdinal: Dringlichkeiten durch Sortierung
+AllocationPriorityNumeric': Numerisch
+AllocationPriorityOrdinal': Nach Sortierung
+AllocationPriorityNumericValues: Numerische Werte
+AllocationPriorityNumericValuesTip: Komma-separierte ganze Zahlen
+AllocationPriorityNumericNoValues: Es wurden keine numerischen Werte angegeben
+AllocationPriorityNumericNoParse val@Text: Ganze Zahl konnte nicht geparst werden: „#{val}“
+AllocationPriorityOrdinalValueNegative: Sortier-Index darf nicht negativ sein
+AllocationPriorityOrdinalValue: Sortier-Index
+AllocationPriorityOrdinalValueTip: Null entspricht dem ersten Eintrag der Liste, höhere Indizes entsprechen später in der sortierten Liste vorkommenden Bewerbern und damit einer höheren Dringlichkeit
 AllocationPrioritiesTitle tid@TermId ssh@SchoolId ash@AllocationShorthand: #{tid}-#{ssh}-#{ash}: Zentrale Dringlichkeiten
 AllocationPrioritiesFile: CSV-Datei
 AllocationPrioritiesSunk num@Int64: Zentrale Prioritäten für #{num} Bewerber erfolgreich hinterlegt
 AllocationPrioritiesMissing num@Int64: Für #{num} Bewerber ist keine zentrale Priorität hinterlegt, da in der hochgeladenen CSV-Datei die #{pluralDE num "entsprechende Matrikelnummer" "entsprechenden Matrikelnummern"} nicht gefunden #{pluralDE num "wurde" "wurden"}
 AllocationMissingPrioritiesIgnored: Bewerber, für die keine zentrale Priorität angegeben wird, werden bei der Vergabe ignoriert!
 
+AllocationAddUserUserNotFound: E-Mail Adresse konnte keinem Benutzer zugeordnet werden
+AllocationAddUserUser: Benutzer
+AllocationAddUserUserPlaceholder: E-Mail
+AllocationAddUserTotalCoursesLessThanOne: Anzahl angefragter Plätze muss größer null sein
+AllocationAddUserTotalCourses: Angefragte Plätze
+AllocationAddUserSetPriority: Zentrale Dringlichkeit eintragen?
+AllocationAddUserPriority: Zentrale Dringlichkeit
+AllocationAddUserApplications: Bewerbungen/Bewertungen
+AllocationAddUserTitle termText@Text ssh'@SchoolShorthand allocation@AllocationName: #{termText} - #{ssh'} - #{allocation}: Bewerber hinzufügen
+AllocationAddUserShortTitle tid@TermId ssh@SchoolId ash@AllocationShorthand: #{tid}-#{ssh}-#{ash}: Bewerber hinzufügen
+AllocationAddUserUserAdded: Bewerber erfolgreich zur Zentralanmeldung hinzugefügt
+AllocationAddUserUserExists: Der angegebene Benutzer ist bereits ein Bewerber zur Zentralanmeldung
+
 ExampleUser1FirstName: Max ZweiterName
 ExampleUser1Surname: Mustermann
 ExampleUser1DisplayName: Max Mustermann

messages/uniworx/en-eu.msg

@@ -1375,6 +1375,7 @@ MenuAllocationUsers: Applicants
 MenuAllocationPriorities: Central priorities
 MenuAllocationCompute: Compute allocation
 MenuAllocationAccept: Accept allocation
+MenuAllocationAddUser: Add applicant
 MenuFaq: FAQ
 MenuSheetPersonalisedFiles: Download personalised sheet files
 MenuCourseSheetPersonalisedFiles: Download template for personalised sheet files
@@ -1449,6 +1450,7 @@ BreadcrumbAllocationUsers: Applicants
 BreadcrumbAllocationPriorities: Central priorities
 BreadcrumbAllocationCompute: Compute allocation
 BreadcrumbAllocationAccept: Accept allocation
+BreadcrumbAllocationAddUser: Add applicant
 BreadcrumbMessageHide: Hide
 BreadcrumbFaq: FAQ
 BreadcrumbSheetPersonalisedFiles: Download personalised sheet files
@@ -2707,12 +2709,34 @@ AllocationUsersCsvName tid ssh ash: #{foldCase (termToText (unTermKey tid))}-#{f
 AllocationPrioritiesMode: Mode
 AllocationPrioritiesNumeric: Numeric priorities
 AllocationPrioritiesOrdinal: Priorities based on sorted list
+AllocationPriorityNumeric': Numerical
+AllocationPriorityOrdinal': Based on sorted list
+AllocationPriorityNumericValues: Numerical values
+AllocationPriorityNumericValuesTip: Comma separated whole numbers
+AllocationPriorityNumericNoValues: No numerical values were provided
+AllocationPriorityNumericNoParse val: Whole number could not be parsed: “#{val}”
+AllocationPriorityOrdinalValueNegative: Sorting index may not be negative
+AllocationPriorityOrdinalValue: Sorting index
+AllocationPriorityOrdinalValueTip: Zero corresponds to the first entry in the list; higher indices correspond to applicants occurring later in the sorted list and thus to higher central priorities
 AllocationPrioritiesTitle tid ssh ash: #{tid}-#{ssh}-#{ash}: Central priorities
 AllocationPrioritiesFile: CSV file
 AllocationPrioritiesSunk num: Successfully registered central priorities for #{num} #{pluralEN num "applicant" "applicants"}
 AllocationPrioritiesMissing num: Could not register central priorities for #{num} #{pluralEN num "applicant" "applicants"} because their matriculation was not found in the uploaded CSV file
 AllocationMissingPrioritiesIgnored: Applicants for whom no central priority has been registered will be ignored during assignment!
 
+AllocationAddUserUserNotFound: Email could not be resolved to an user
+AllocationAddUserUser: User
+AllocationAddUserUserPlaceholder: Email
+AllocationAddUserTotalCoursesLessThanOne: Number of requested courses needs to be greater than zero
+AllocationAddUserTotalCourses: Requested courses
+AllocationAddUserSetPriority: Set central priority?
+AllocationAddUserPriority: Central priority
+AllocationAddUserApplications: Applications/Ratings
+AllocationAddUserTitle termText ssh' allocation: #{termText} - #{ssh'} - #{allocation}: Add applicant
+AllocationAddUserShortTitle tid@TermId ssh@SchoolId ash@AllocationShorthand: #{tid}-#{ssh}-#{ash}: Add applicant
+AllocationAddUserUserAdded: Successfully added applicant to central allocation
+AllocationAddUserUserExists: The specified user is already an applicant for the central allocation
+
 ExampleUser1FirstName: Max SecondName
 ExampleUser1Surname: Mustermann
 ExampleUser1DisplayName: Max Mustermann

routes

@@ -113,6 +113,7 @@
   /register                                      ARegisterR         POST        !time
   /course/#CryptoUUIDCourse/apply                AApplyR            POST        !timeANDallocation-registered
   /users                                         AUsersR        GET POST        !allocation-admin
+  /users/add                                     AAddUserR      GET POST        !allocation-admin
   /priorities                                    APriosR        GET POST        !allocation-admin
   /compute                                       AComputeR      GET POST        !allocation-admin
   /accept                                        AAcceptR       GET POST        !allocation-admin

src/Foundation/Navigation.hs

@@ -159,6 +159,7 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where
     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
+    AAddUserR   -> i18nCrumb MsgBreadcrumbAllocationAddUser . Just $ AllocationR tid ssh ash AUsersR
 
   breadcrumb ParticipantsListR      = i18nCrumb MsgBreadcrumbParticipantsList $ Just CourseListR
   breadcrumb (ParticipantsR _ _)    = i18nCrumb MsgBreadcrumbParticipants     $ Just ParticipantsListR
@@ -1332,6 +1333,17 @@ pageActions (AllocationR tid ssh ash AUsersR) = return
       }
     , navChildren = []
     }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuAllocationAddUser
+      , navRoute       = AllocationR tid ssh ash AAddUserR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
   ]
 pageActions CourseListR = do
   participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR

src/Handler/Allocation.hs

@@ -8,6 +8,7 @@ import Handler.Allocation.Application as Handler.Allocation
 import Handler.Allocation.Register as Handler.Allocation
 import Handler.Allocation.List as Handler.Allocation
 import Handler.Allocation.Users as Handler.Allocation
+import Handler.Allocation.AddUser as Handler.Allocation
 import Handler.Allocation.Prios as Handler.Allocation
 import Handler.Allocation.Compute as Handler.Allocation
 import Handler.Allocation.Accept as Handler.Allocation

src/Handler/Allocation/AddUser.hs

@@ -0,0 +1,162 @@
+module Handler.Allocation.AddUser
+  ( getAAddUserR, postAAddUserR
+  ) where
+
+import Import
+import Handler.Allocation.Application
+
+import Handler.Utils
+
+import qualified Data.Map as Map
+
+import qualified Data.Conduit.Combinators as C
+
+import qualified Database.Esqueleto as E
+
+
+data AllocationAddUserForm = AllocationAddUserForm
+  { aauUser :: UserId
+  , aauTotalCourses :: Natural
+  , aauPriority :: Maybe AllocationPriority
+  , aauApplications :: Map CourseId ApplicationForm
+  }
+  
+
+getAAddUserR, postAAddUserR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
+getAAddUserR = postAAddUserR
+postAAddUserR tid ssh ash = do
+  (Entity _ Allocation{..}, (addUserAct, addUserForm, addUserEnctype)) <- runDB $ do
+    alloc@(Entity aId _) <- getBy404 $ TermSchoolAllocationShort tid ssh ash
+    allocCourses <- E.select . E.from $ \(course `E.InnerJoin` allocationCourse) -> do
+      E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
+      E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId
+      return ( course
+             , E.exists . E.from $ \courseAppInstructionFile ->
+                 E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. course E.^. CourseId
+             )
+
+    MsgRenderer mr <- getMsgRenderer
+    ((addUserRes, addUserForm), addUserEnctype) <- liftHandler . runFormPost . renderAForm FormStandard $ AllocationAddUserForm
+      <$> areq (checkMap (first $ const MsgAllocationAddUserUserNotFound) Right $ userField False Nothing) (fslpI MsgAllocationAddUserUser (mr MsgAllocationAddUserUserPlaceholder)) Nothing
+      <*> areq (posIntFieldI MsgAllocationAddUserTotalCoursesLessThanOne) (fslI MsgAllocationAddUserTotalCourses) (Just 1)
+      <*> optionalActionA (allocationPriorityForm (fslI MsgAllocationAddUserPriority) Nothing) (fslI MsgAllocationAddUserSetPriority) (Just True)
+      <*> allocationApplicationsForm aId (Map.fromList [ (cId, (course, hasTemplate)) | (Entity cId course, E.Value hasTemplate) <- allocCourses ]) (fslI MsgAllocationAddUserApplications) False
+
+    addUserAct <- formResultMaybe addUserRes $ \AllocationAddUserForm{..} -> Just <$> do
+      now <- liftIO getCurrentTime
+      
+      didInsert <- is _Just <$> insertUnique AllocationUser
+        { allocationUserAllocation = aId
+        , allocationUserUser = aauUser
+        , allocationUserTotalCourses = aauTotalCourses
+        , allocationUserPriority = aauPriority
+        }
+
+      if
+        | didInsert -> do
+            oldApps <- selectList [CourseApplicationUser ==. aauUser, CourseApplicationAllocation ==. Just aId] []
+            forM_ oldApps $ \(Entity appId CourseApplication{..}) -> do
+              delete appId
+              unless (courseApplicationCourse `Map.member` aauApplications) $ 
+                audit $ TransactionCourseApplicationDeleted courseApplicationCourse courseApplicationUser appId
+
+            iforM_ aauApplications $ \cId ApplicationForm{..} -> maybeT (return ()) $ do
+              prio <- hoistMaybe afPriority
+              let rated = afRatingVeto || is _Just afRatingPoints
+              appId <- lift $ insert CourseApplication
+                { courseApplicationCourse = cId
+                , courseApplicationUser = aauUser
+                , courseApplicationText = afText
+                , courseApplicationRatingVeto = afRatingVeto
+                , courseApplicationRatingPoints = afRatingPoints
+                , courseApplicationRatingComment = afRatingComment
+                , courseApplicationAllocation = Just aId
+                , courseApplicationAllocationPriority = Just prio
+                , courseApplicationTime = now
+                , courseApplicationRatingTime = guardOn rated now
+                }
+              lift . runConduit $ transPipe liftHandler (sequence_ afFiles) .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId))
+              lift . audit $ TransactionCourseApplicationEdit cId aauUser appId
+
+            return $ do
+              addMessageI Success MsgAllocationAddUserUserAdded
+              redirect $ AllocationR tid ssh ash AAddUserR
+        | otherwise -> return $ addMessageI Error MsgAllocationAddUserUserExists
+  
+    return (alloc, (addUserAct, addUserForm, addUserEnctype))
+
+  sequence_ addUserAct
+
+  MsgRenderer mr <- getMsgRenderer
+  let title = MsgAllocationAddUserTitle (mr . ShortTermIdentifier $ unTermKey allocationTerm) (unSchoolKey allocationSchool) allocationName
+      shortTitle = MsgAllocationAddUserShortTitle allocationTerm allocationSchool allocationShorthand
+
+  siteLayoutMsg title $ do
+    setTitleI shortTitle
+    wrapForm addUserForm FormSettings
+      { formMethod = POST
+      , formAction = Just . SomeRoute $ AllocationR tid ssh ash AAddUserR
+      , formEncoding = addUserEnctype
+      , formAttrs = []
+      , formSubmit = FormSubmit
+      , formAnchor = Nothing :: Maybe Text
+      }
+
+allocationApplicationsForm :: AllocationId
+                           -> Map CourseId (Course, Bool)
+                           -> FieldSettings UniWorX
+                           -> Bool
+                           -> AForm Handler (Map CourseId ApplicationForm)
+allocationApplicationsForm aId courses FieldSettings{..} fvRequired = formToAForm $ do
+  let afmApplicant = True
+      afmApplicantEdit = True
+      afmLecturer = True
+
+  appsRes' <- iforM courses $ \cId (course, hasApplicationTemplate) -> over _2 (course, hasApplicationTemplate, ) <$> applicationForm (Just aId) cId Nothing ApplicationFormMode{..} Nothing
+  let appsRes = sequenceA $ view _1 <$> appsRes'
+      appsViews = view _2 <$> appsRes'
+  
+  let fvInput =
+        [whamlet|
+          $newline never
+          <div .allocation__courses>
+            $forall (Course{courseTerm, courseSchool, courseShorthand, courseName, courseApplicationsInstructions}, hasApplicationTemplate, ApplicationFormView{afvPriority, afvForm}) <- Map.elems appsViews
+              <div .allocation-course>
+                <div .allocation-course__priority-label .allocation__label>
+                  _{MsgAllocationPriority}
+                <div .allocation-course__priority>
+                  $maybe prioView <- afvPriority
+                    ^{fvWidget prioView}
+                <a .allocation-course__name href=@{CourseR courseTerm courseSchool courseShorthand CShowR} target="_blank">
+                  #{courseName}
+                $if hasApplicationTemplate || is _Just courseApplicationsInstructions
+                  <div .allocation-course__instructions-label .allocation__label>
+                    _{MsgCourseApplicationInstructionsApplication}
+                  <div .allocation-course__instructions>
+                    $maybe aInst <- courseApplicationsInstructions
+                      <p>
+                        #{aInst}
+                    $if hasApplicationTemplate
+                      <p>
+                        <a href=@{CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR}>
+                          #{iconRegisterTemplate} _{MsgCourseApplicationTemplateApplication}
+                <div .allocation-course__application-label .interactive-fieldset__target .allocation__label uw-interactive-fieldset data-conditional-input=#{maybe "" fvId afvPriority} data-conditional-value="" data-conditional-negated>
+                  _{MsgCourseApplication}
+                <div .allocation-course__application .interactive-fieldset__target uw-interactive-fieldset data-conditional-input=#{maybe "" fvId afvPriority} data-conditional-value="" data-conditional-negated>
+                  ^{renderFieldViews FormStandard afvForm}
+        |]
+  MsgRenderer mr <- getMsgRenderer
+  let fvLabel = toHtml $ mr fsLabel
+      fvTooltip = toHtml . mr <$> fsTooltip
+      fvErrors = case appsRes of
+        FormFailure errs -> Just
+          [shamlet|
+            $newline never
+            <ul>
+              $forall err <- errs
+                <li>#{err}
+          |]
+        _other -> Nothing
+  fvId <- maybe newIdent return fsId
+  
+  return (appsRes, pure FieldView{..})

src/Handler/Allocation/Application.hs

@@ -71,16 +71,17 @@ instance Exception ApplicationFormException
 
 applicationForm :: Maybe AllocationId
                 -> CourseId
-                -> UserId
+                -> Maybe UserId
                 -> ApplicationFormMode -- ^ Which parts of the shared form to display
-                -> Html -> MForm Handler (FormResult ApplicationForm, ApplicationFormView)
+                -> Maybe Html -- ^ If @Just@ also include action buttons for usage as standalone form
-applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf = do
+                -> MForm Handler (FormResult ApplicationForm, ApplicationFormView)
+applicationForm maId@(is _Just -> isAlloc) cid muid ApplicationFormMode{..} mcsrf = do
 
   (mApp, coursesNum, Course{..}, maxPrio) <- liftHandler . runDB $ do
-    mApplication <- listToMaybe <$> selectList [CourseApplicationAllocation ==. maId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1]
+    mApplication <- fmap join . for muid $ \uid -> listToMaybe <$> selectList [CourseApplicationAllocation ==. maId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1]
     coursesNum <- fromIntegral . fromMaybe 1 <$> for maId (\aId -> count [AllocationCourseAllocation ==. aId])
     course <- getJust cid
-    (fromMaybe 0 -> maxPrio) <- fmap (E.unValue <=< listToMaybe) . E.select . E.from $ \courseApplication -> do
+    (fromMaybe 0 -> maxPrio) <- fmap join . for muid $ \uid -> fmap (E.unValue <=< listToMaybe) . E.select . E.from $ \courseApplication -> do
       E.where_ $ courseApplication E.^. CourseApplicationUser       E.==. E.val uid
            E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.val maId
            E.&&. E.not_ (E.isNothing $ courseApplication E.^. CourseApplicationAllocationPriority)
@@ -202,7 +203,9 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
       , guardOn (    afmApplicantEdit && is _Nothing mApp               ) BtnAllocationApply
       , guardOn (    afmApplicantEdit && is _Just    mApp               ) BtnAllocationApplicationRetract
       ]
-  (actionRes, buttonsView) <- buttonForm' buttons csrf
+  (actionRes, buttonsView) <- case mcsrf of
+    Just csrf -> buttonForm' buttons csrf
+    Nothing   -> return (pure BtnAllocationApplicationEdit, mempty)
 
   ratingSection <- if
     | afmLecturer
@@ -251,7 +254,7 @@ editApplicationR :: Maybe AllocationId
 editApplicationR maId uid cid mAppId afMode allowAction postAction = do
   Course{..} <- runDB $ get404 cid
 
-  ((appRes, appView), appEnc) <- runFormPost $ applicationForm maId cid uid afMode
+  ((appRes, appView), appEnc) <- runFormPost $ applicationForm maId cid (Just uid) afMode . Just
 
   formResult appRes $ \ApplicationForm{..} -> do
     if

src/Handler/Allocation/Show.hs

@@ -150,7 +150,7 @@ postAShowR tid ssh ash = do
           mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID
           mayEdit <- hasWriteAccessTo $ CourseR tid ssh courseShorthand CEditR
           isLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
-          mApplyFormView <- liftHandler . for muid $ \uid -> generateFormPost . applicationForm (Just aId) cid uid $ ApplicationFormMode True mayApply isLecturer
+          mApplyFormView <- liftHandler . for muid $ \uid -> generateFormPost $ applicationForm (Just aId) cid (Just uid) (ApplicationFormMode True mayApply isLecturer) . Just
           tRoute <- case mApp of
             Nothing -> return . AllocationR tid ssh ash $ AApplyR cID
             Just (Entity appId _) -> CApplicationR courseTerm courseSchool courseShorthand <$> encrypt appId <*> pure CAEditR

src/Handler/Utils/Form.hs

@@ -44,6 +44,8 @@ import qualified Data.Set as Set
 import Data.Map ((!), (!?))
 import qualified Data.Map as Map
 
+import qualified Data.Vector as Vector
+
 import qualified Data.HashMap.Lazy as HashMap
 
 import Control.Monad.Writer.Class
@@ -488,7 +490,7 @@ termsAllowedField = selectField $ do
   optionsPersistKey termFilter [Desc TermStart] termName
 
 termField :: Field Handler TermId
-termField = selectField $ optionsPersistKey [] [Asc TermName] termName
+termField = selectField $ optionsPersistKey [] [Desc TermStart] termName
 
 termsSetField :: [TermId] -> Field Handler TermId
 termsSetField tids = selectField $ optionsPersistKey [TermName <-. (unTermKey <$> tids)] [Desc TermStart] termName
@@ -1608,6 +1610,96 @@ multiUserField onlySuggested suggestions = Field{..}
                    )
       Nothing -> E.true
 
+userField :: forall m.
+             ( MonadHandler m
+             , HandlerSite m ~ UniWorX
+             )
+          => Bool -- ^ Only resolve suggested users?
+          -> Maybe (E.SqlQuery (E.SqlExpr (Entity User))) -- ^ Suggested users
+          -> Field m (Either UserEmail UserId)
+userField onlySuggested suggestions = Field{..}
+  where
+    lookupExpr
+      | onlySuggested = suggestions
+      | otherwise     = Just $ E.from return
+
+    fieldEnctype = UrlEncoded
+    fieldView theId name attrs val isReq = do
+      val' <- case val of
+        Left t -> return t
+        Right v -> case v of
+          Right uid -> case lookupExpr of
+            Nothing -> return mempty
+            Just lookupExpr' -> do
+              dbRes <- liftHandler . runDB . E.select $ do
+                user <- lookupExpr'
+                E.where_ $ user E.^. UserId E.==. E.val uid
+                return $ user E.^. UserEmail
+              case dbRes of
+                [E.Value email] -> return $ CI.original email
+                _other -> return mempty
+          Left email -> return $ CI.original email
+
+      datalistId <- maybe (return $ error "Not to be used") (const newIdent) suggestions
+
+      [whamlet|
+        $newline never
+        <input id="#{theId}" name="#{name}" *{attrs} type="email" :isReq:required="" value="#{val'}" :isJust suggestions:list=#{datalistId}>
+      |]
+
+      whenIsJust suggestions $ \suggestions' -> do
+        suggestedEmails <- fmap (Map.assocs . Map.fromListWith min . map (over _2 E.unValue . over _1 E.unValue)) . liftHandler . runDB . E.select $ do
+          user <- suggestions'
+          return ( E.case_
+                       [ E.when_ (unique UserDisplayEmail user)
+                         E.then_ (user E.^. UserDisplayEmail)
+                       , E.when_ (unique UserEmail user)
+                         E.then_ (user E.^. UserEmail)
+                       ]
+                       ( E.else_ $ user E.^. UserIdent)
+                   , user E.^. UserDisplayName
+                   )
+        [whamlet|
+          $newline never
+          <datalist id=#{datalistId}>
+            $forall (email, dName) <- suggestedEmails
+              <option value=#{email}>
+                #{email} (#{dName})
+        |]
+    fieldParse (filter (not . Text.null) -> t : _) _ = runExceptT . fmap Just $ do
+      email <- either (\errStr -> throwE . SomeMessage $ MsgInvalidEmail [st|#{t} (#{errStr})|]) (return . CI.mk . decodeUtf8 . Email.toByteString) $ Email.validate (encodeUtf8 t)
+      case lookupExpr of
+        Nothing -> return $ Left email
+        Just lookupExpr' -> do
+            dbRes <- fmap (setOf $ folded . _Value). liftHandler . runDB . E.select $ do
+              user <- lookupExpr'
+              E.where_ $ user E.^. UserIdent `E.ciEq` E.val email
+                   E.||. (       user E.^. UserDisplayEmail `E.ciEq` E.val email
+                           E.&&. unique UserDisplayEmail user
+                         )
+                   E.||. (       user E.^. UserEmail `E.ciEq` E.val email
+                           E.&&. unique UserEmail user
+                         )
+              return $ user E.^. UserId
+            if | Set.null dbRes
+                 -> return $ Left email
+               | [uid] <- Set.toList dbRes
+                 -> return $ Right uid
+               | otherwise
+                 -> throwE $ SomeMessage MsgAmbiguousEmail
+    fieldParse _ _ = return $ Right Nothing
+
+    unique field user = case lookupExpr of
+      Just lookupExpr' -> E.not_ . E.exists $ do
+        user' <- lookupExpr'
+        E.where_ $ user' E.^. UserId E.!=. user E.^. UserId
+             E.&&. (       user' E.^. UserIdent        `E.ciEq` user E.^. field
+                     E.||. user' E.^. UserEmail        `E.ciEq` user E.^. field
+                     E.||. user' E.^. UserDisplayEmail `E.ciEq` user E.^. field
+                   )
+      Nothing -> E.true
+
+
 examResultField :: forall m res.
                    ( MonadHandler m
                    , HandlerSite m ~ UniWorX
@@ -2032,3 +2124,30 @@ examModeForm mPrev = examMode
             examRequiredEquipmentToEither (ExamRequiredEquipmentCustom c) = Left  c
             examRequiredEquipmentFromEither (Right p) = ExamRequiredEquipmentPreset p
             examRequiredEquipmentFromEither (Left  c) = ExamRequiredEquipmentCustom c
+
+
+data AllocationPriority' = AllocationPriorityNumeric' | AllocationPriorityOrdinal'
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
+nullaryPathPiece ''AllocationPriority' $ camelToPathPiece' 2 . dropSuffix "'"
+embedRenderMessage ''UniWorX ''AllocationPriority' id
+
+classifyAllocationPriority :: AllocationPriority -> AllocationPriority'
+classifyAllocationPriority = \case
+  AllocationPriorityNumeric{} -> AllocationPriorityNumeric'
+  AllocationPriorityOrdinal{} -> AllocationPriorityOrdinal'
+
+allocationPriorityForm :: FieldSettings UniWorX
+                       -> Maybe AllocationPriority
+                       -> AForm Handler AllocationPriority
+allocationPriorityForm fs mPrev = multiActionA opts fs $ classifyAllocationPriority <$> mPrev
+  where
+    opts = flip Map.fromSet (Set.fromList universeF) $ \case
+      AllocationPriorityNumeric' -> AllocationPriorityNumeric <$> apreq (checkMap toInts fromInts textField) (fslI MsgAllocationPriorityNumericValues & setTooltip MsgAllocationPriorityNumericValuesTip) (mPrev ^? _Just . _AllocationPriorityNumeric)
+      AllocationPriorityOrdinal' -> AllocationPriorityOrdinal <$> apreq (natFieldI MsgAllocationPriorityOrdinalValueNegative) (fslI MsgAllocationPriorityOrdinalValue & setTooltip MsgAllocationPriorityOrdinalValueTip) (mPrev ^? _Just . _AllocationPriorityOrdinal)
+
+    toInts t = fmap Vector.fromList . runExcept $ do
+      let ts = filter (not . Text.null) . map Text.strip $ Text.splitOn "," t
+      whenExceptT (null ts) MsgAllocationPriorityNumericNoValues
+      forM ts $ \t' -> maybeExceptT (MsgAllocationPriorityNumericNoParse t') . return $ readMay t'
+    fromInts = Text.intercalate ", " . map tshow . Vector.toList

src/Utils/Lens.hs

@@ -233,6 +233,8 @@ makeLenses_ ''Rating'
 
 makeLenses_ ''FallbackPersonalisedSheetFilesKey
 
+makePrisms ''AllocationPriority
+
 -- makeClassy_ ''Load
 
 --------------------------