feat(allocations): add registration form

frontend/src/utils/form/interactive-fieldset.js

@@ -16,6 +16,7 @@ export class InteractiveFieldset {
   conditionalValue;
   target;
   childInputs;
+  negated;
 
   constructor(element) {
     if (!element) {
@@ -48,6 +49,8 @@ export class InteractiveFieldset {
     }
     this.conditionalValue = this._element.dataset.conditionalValue;
 
+    this.negated = 'conditionalNegated' in this._element.dataset;
+
     this.target = this._element.closest(INTERACTIVE_FIELDSET_UTIL_TARGET_SELECTOR);
     if (!this.target || this._element.matches(INTERACTIVE_FIELDSET_UTIL_TARGET_SELECTOR)) {
       this.target = this._element;
@@ -88,11 +91,19 @@ export class InteractiveFieldset {
   }
 
   _matchesConditionalValue() {
+    var matches;
+
     if (this._isCheckbox()) {
-      return this.conditionalInput.checked === true;
+      matches = this.conditionalInput.checked === true;
+    } else {
+      matches = this.conditionalInput.value === this.conditionalValue;
     }
 
-    return this.conditionalInput.value === this.conditionalValue;
+    if (this.negated) {
+      return !matches;
+    } else {
+      return matches;
+    }
   }
 
   _isCheckbox() {

frontend/src/utils/form/interactive-fieldset.md

@@ -8,6 +8,8 @@ Shows/hides inputs based on value of particular input
   Selector for the input that this fieldset watches for changes
 - `data-conditional-value: string`\
   The value the conditional input needs to be set to for this fieldset to be shown. Can be omitted if conditionalInput is a checkbox
+- `data-conditional-negated`\
+  If present, negates the match on `data-conditional-value`
 
 ## Example usage:
 ### example with text input

messages/uniworx/de.msg

@@ -350,6 +350,7 @@ UnauthorizedCorrector: Sie sind nicht als Korrektor für diese Veranstaltung ein
 UnauthorizedSheetCorrector: Sie sind nicht als Korrektor für dieses Übungsblatt eingetragen.
 UnauthorizedCorrectorAny: Sie sind nicht als Korrektor für eine Veranstaltung eingetragen.
 UnauthorizedRegistered: Sie sind nicht als Teilnehmer für diese Veranstaltung registriert.
+UnauthorizedAllocationRegistered: Sie sind nicht als Teilnehmer für diese Zentralanmeldung registriert.
 UnauthorizedExamResult: Sie haben keine Ergebnisse in dieser Prüfung.
 UnauthorizedParticipant: Angegebener Benutzer ist nicht als Teilnehmer dieser Veranstaltung registriert.
 UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen.
@@ -1019,6 +1020,7 @@ AuthTagTime: Zeitliche Einschränkungen sind erfüllt
 AuthTagStaffTime: Zeitliche Einschränkungen für Lehrbeteiligte sind erfüllt
 AuthTagAllocationTime: Zeitliche Einschränkungen durch Zentralanmeldung sind erfüllt
 AuthTagCourseRegistered: Nutzer ist Kursteilnehmer
+AuthTagAllocationRegistered: Nutzer nimmt an der Zentralanmeldung teil
 AuthTagTutorialRegistered: Nutzer ist Tutoriumsteilnehmer
 AuthTagExamRegistered: Nutzer ist Prüfungsteilnehmer
 AuthTagExamResult: Nutzer hat Prüfungsergebnisse
@@ -1448,3 +1450,27 @@ MailSubjectSchoolLecturerInvitation school@SchoolName: Einladung zum Dozent für
 MailSchoolLecturerInviteHeading school@SchoolName: Einladung zum Dozent für „#{school}“
 SchoolLecturerInviteExplanation: Sie wurden eingeladen, Dozent für ein Institut zu sein. Sie können, nachdem Sie die Einladung annehmen, eigenständig neue Kurse anlegen.
 SchoolLecturerInvitationAccepted school@SchoolName: Einladung zum Dozent für „#{school}“ angenommen
+
+AllocationTitle termText@Text ssh'@SchoolShorthand allocation@AllocationName: #{termText} - #{ssh'}: #{allocation}
+AllocationShortTitle termText@Text ssh'@SchoolShorthand ash@AllocationShorthand: #{termText} - #{ssh'} - #{ash}
+AllocationDescription: Beschreibung
+AllocationStaffRegisterFrom: Eintragung der Kurse ab
+AllocationStaffRegister: Eintragung der Kurse
+AllocationRegisterFrom: Bewerbung ab
+AllocationRegister: Bewerbung
+AllocationStaffAllocationFrom: Bewertung der Bewerbungen ab
+AllocationStaffAllocation: Bewertung der Bewerbungen
+AllocationNoApplication: Keine Bewerbung
+AllocationPriority: Priorität
+AllocationPriorityTip: Kurse, denen Sie eine höhere Priorität zuteilen, werden bei der Platzvergabe präferiert.
+AllocationPriorityRelative: Die absoluten Prioritäts-Werte sind bedeutungslos, es wird nur jeweils betrachtet ob ein Kurs höhere Priorität hat als ein anderer.
+AllocationTotalCoursesNegative: Gewünschte Kursanzahl muss größer null sein
+AllocationTotalCourses: Gewünschte Anzahl von Kursen
+AllocationTotalCoursesTip: Sie werden im Laufe dieser Zentralanmeldung maximal so vielen Kursen zugeteilt, wie Sie hier angeben
+AllocationRegistered: Teilnahme an der Zentralanmeldung erfolgreich registriert
+AllocationRegistrationEdited: Einstellungen zur Teilnahme an der Zentralanmeldung erfolgreich angepasst
+BtnAllocationRegister: Teilnahme registrieren
+BtnAllocationRegistrationEdit: Teilnahme anpassen
+AllocationParticipation: Teilnahme an der Zentralanmeldung
+AllocationCourses: Kurse
+AllocationData: Organisatorisches

routes

@@ -81,9 +81,10 @@
 /school/#SchoolId          SchoolShowR         GET             !development
 
 /allocation/#TermId/#SchoolId/#AllocationShorthand AllocationR:
-  /                                              AShowR   GET             !free
-  /course/#CryptoUUIDCourse/apply                AApplyR      POST        !time
-  /application/#CryptoFileNameCourseApplication  AEditR   GET POST        !timeANDself !lecturerANDstaff-time
+  /                                              AShowR     GET             !free
+  /register                                      ARegisterR     POST        !time
+  /course/#CryptoUUIDCourse/apply                AApplyR        POST        !timeANDallocation-registered
+  /application/#CryptoFileNameCourseApplication  AEditR     GET POST        !timeANDself !lecturerANDstaff-time
 
 
 -- For Pattern Synonyms see Foundation

src/Foundation.hs

@@ -1024,6 +1024,13 @@ tagAccessPredicate AuthExamResult = APDB $ \mAuthId route _ -> case route of
     guardMExceptT hasResult (unauthorizedI MsgUnauthorizedExamResult)
     return Authorized
   r -> $unsupportedAuthPredicate AuthExamRegistered r
+tagAccessPredicate AuthAllocationRegistered = APDB $ \mAuthId route _ -> case route of
+  AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegistered) $ do
+    uid <- hoistMaybe mAuthId
+    aId <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getKeyBy $ TermSchoolAllocationShort tid ssh ash
+    void . MaybeT . $cachedHereBinary (uid, aId) . getKeyBy $ UniqueAllocationUser aId uid
+    return Authorized
+  r -> $unsupportedAuthPredicate AuthAllocationRegistered r
 tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
   CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do
     let authorizedIfExists f = do

src/Handler/Allocation.hs

@@ -4,3 +4,4 @@ module Handler.Allocation
 
 import Handler.Allocation.Show as Handler.Allocation
 import Handler.Allocation.Edit as Handler.Allocation
+import Handler.Allocation.Register as Handler.Allocation

src/Handler/Allocation/Register.hs

@@ -0,0 +1,60 @@
+module Handler.Allocation.Register
+  ( AllocationRegisterForm(..)
+  , AllocationRegisterButton(..)
+  , allocationRegisterForm
+  , allocationUserToForm
+  , postARegisterR
+  ) where
+
+import Import
+
+import Utils.Lens
+
+import Handler.Utils.Form
+
+
+data AllocationRegisterForm = AllocationRegisterForm
+  { arfTotalCourses :: Natural
+  }
+
+allocationRegisterForm :: Maybe AllocationRegisterForm -> AForm Handler AllocationRegisterForm
+allocationRegisterForm template
+  = AllocationRegisterForm
+    <$> areq (posIntFieldI MsgAllocationTotalCoursesNegative) (fslI MsgAllocationTotalCourses & setTooltip MsgAllocationTotalCoursesTip) (arfTotalCourses <$> template <|> Just 1)
+
+allocationUserToForm :: AllocationUser -> AllocationRegisterForm
+allocationUserToForm AllocationUser{..} = AllocationRegisterForm
+  { arfTotalCourses = allocationUserTotalCourses
+  }
+
+data AllocationRegisterButton = BtnAllocationRegister | BtnAllocationRegistrationEdit
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+instance Universe AllocationRegisterButton
+instance Finite AllocationRegisterButton
+
+nullaryPathPiece ''AllocationRegisterButton $ camelToPathPiece' 1
+embedRenderMessage ''UniWorX ''AllocationRegisterButton id
+
+instance Button UniWorX AllocationRegisterButton where
+  btnClasses _ = [BCIsButton, BCPrimary]
+
+postARegisterR :: TermId -> SchoolId -> AllocationShorthand -> Handler Void
+postARegisterR tid ssh ash = do
+  uid <- requireAuthId
+
+  ((registerRes, _), _) <- runFormPost . renderAForm FormStandard $ allocationRegisterForm Nothing
+  formResult registerRes $ \AllocationRegisterForm{..} -> runDB $ do
+    aId <- getKeyBy404 $ TermSchoolAllocationShort tid ssh ash
+    isRegistered <- existsBy $ UniqueAllocationUser aId uid
+    void $ upsert AllocationUser 
+      { allocationUserAllocation = aId
+      , allocationUserUser = uid
+      , allocationUserTotalCourses = arfTotalCourses
+      }
+      [ AllocationUserTotalCourses =. arfTotalCourses
+      ]
+    if
+      | isRegistered -> addMessageI Success MsgAllocationRegistrationEdited
+      | otherwise -> addMessageI Success MsgAllocationRegistered
+  
+  redirect $ AllocationR tid ssh ash AShowR :#: ("allocation-participation" :: Text)

src/Handler/Allocation/Show.hs

@@ -3,13 +3,68 @@ module Handler.Allocation.Show
   ) where
 
 import Import
+import Handler.Utils
+import Utils.Lens
+
+import Handler.Allocation.Register
+
+import qualified Database.Esqueleto as E
+  
 
 getAShowR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
 getAShowR tid ssh ash = do
-  Entity _ alloc <- runDB . getBy404 $ TermSchoolAllocationShort tid ssh ash
+  muid <- maybeAuthId
 
-  defaultLayout $ -- TODO
-    [whamlet|
-      <pre>
-        #{tshow alloc}
-    |]
+  let
+    resultCourse :: Lens' (Entity Course, _, _) (Entity Course)
+    resultCourse = _1
+    -- resultCourseApplication = _2
+    resultHasTemplate = _3 . _Value
+
+  (Entity _ Allocation{..}, courses, registration) <- runDB $ do
+    alloc@(Entity aId _) <- getBy404 $ TermSchoolAllocationShort tid ssh ash
+
+    courses <- E.select . E.from $ \((allocationCourse `E.InnerJoin` course) `E.LeftOuterJoin` courseApplication) -> do
+      E.on $ courseApplication E.?. CourseApplicationCourse E.==. E.just (course E.^. CourseId)
+       E.&&. courseApplication E.?. CourseApplicationUser E.==. E.val muid
+       E.&&. courseApplication E.?. CourseApplicationAllocation E.==. E.just (E.just $ E.val aId)
+      E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
+      E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId
+      let hasTemplate = E.exists . E.from $ \courseAppInstructionFile ->
+            E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. course E.^. CourseId
+      return (course, courseApplication, hasTemplate)
+
+    registration <- fmap join . for muid $ getBy . UniqueAllocationUser aId
+
+    return (alloc, nubOn (view $ resultCourse . _entityKey) courses, registration)
+
+  MsgRenderer mr <- getMsgRenderer
+  let title = MsgAllocationTitle (mr . ShortTermIdentifier $ unTermKey allocationTerm) (unSchoolKey allocationSchool) allocationName
+      shortTitle = MsgAllocationShortTitle (mr . ShortTermIdentifier $ unTermKey allocationTerm) (unSchoolKey allocationSchool) allocationShorthand
+
+  staffInformation <- anyM courses $ \(view $ resultCourse . _entityVal -> Course{..}) ->
+    hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CApplicationsR
+  mayRegister <- hasWriteAccessTo $ AllocationR tid ssh ash ARegisterR
+  (registerForm, registerEnctype) <- generateFormPost . renderAForm FormStandard . allocationRegisterForm $ allocationUserToForm . entityVal <$> registration
+  let
+    registerBtn = bool BtnAllocationRegister BtnAllocationRegistrationEdit $ is _Just registration
+    registerForm' = wrapForm' registerBtn registerForm FormSettings
+      { formMethod = POST
+      , formAction = Just . SomeRoute $ AllocationR tid ssh ash ARegisterR
+      , formEncoding = registerEnctype
+      , formAttrs = []
+      , formSubmit = FormSubmit
+      , formAnchor = Nothing :: Maybe Text
+      }
+
+  siteLayoutMsg title $ do
+    setTitleI shortTitle
+
+    let courseWidgets = flip map courses $ \cEntry -> do
+          let Entity cid Course{..}  = cEntry ^. resultCourse
+              hasApplicationTemplate = cEntry ^. resultHasTemplate
+          cID <- encrypt cid :: WidgetT UniWorX IO CryptoUUIDCourse
+          mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID
+          $(widgetFile "allocation/show/course")
+  
+    $(widgetFile "allocation/show")

src/Model/Types/Security.hs

@@ -42,6 +42,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
   | AuthLecturer
   | AuthCorrector
   | AuthTutor
+  | AuthAllocationRegistered
   | AuthCourseRegistered
   | AuthTutorialRegistered
   | AuthExamRegistered

src/Utils.hs

@@ -1,5 +1,6 @@
 module Utils
   ( module Utils
+  , List.nub, List.nubBy
   ) where
 
 import ClassyPrelude.Yesod hiding (foldlM, Proxy)
@@ -39,7 +40,7 @@ import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Map (Map)
 import qualified Data.Map as Map
--- import qualified Data.List as List
+import qualified Data.List as List
 
 import Control.Lens
 import Control.Lens as Utils (none)
@@ -376,6 +377,9 @@ partitionWith f (x:xs) = case f x of
 nonEmpty' :: Alternative f => [a] -> f (NonEmpty a)
 nonEmpty' = maybe empty pure . nonEmpty
 
+nubOn :: Eq b => (a -> b) -> [a] -> [a]
+nubOn = List.nubBy . ((==) `on`)
+
 ----------
 -- Sets --
 ----------

templates/allocation/show.hamlet

@@ -0,0 +1,61 @@
+$newline never
+<section>
+  $# <h2>
+  $#   _{MsgAllocationData}
+  <dl .deflist>
+    $maybe desc <- allocationDescription
+      <dt .deflist__dt>
+        _{MsgAllocationDescription}
+      <dd .deflist__dd>
+        #{desc}
+    $maybe fromT <- allocationStaffRegisterFrom
+      <dt .deflist__dt>
+        $maybe _ <- allocationStaffRegisterTo
+          _{MsgAllocationStaffRegister}
+        $nothing
+          _{MsgAllocationStaffRegisterFrom}
+      <dd .deflist__dd>
+        ^{formatTimeRangeW SelFormatDateTime fromT allocationStaffRegisterTo}
+    $maybe fromT <- allocationRegisterFrom
+      <dt .deflist__dt>
+        $maybe _ <- allocationRegisterTo
+          _{MsgAllocationRegister}
+        $nothing
+          _{MsgAllocationRegisterFrom}
+      <dd .deflist__dd>
+        ^{formatTimeRangeW SelFormatDateTime fromT allocationRegisterTo}
+    $if staffInformation
+      $maybe fromT <- allocationStaffAllocationFrom
+        <dt .deflist__dt>
+          $maybe _ <- allocationStaffAllocationTo
+            _{MsgAllocationStaffAllocation}
+          $nothing
+            _{MsgAllocationStaffAllocationFrom}
+        <dd .deflist__dd>
+          ^{formatTimeRangeW SelFormatDateTime fromT allocationStaffAllocationTo}
+
+$if mayRegister || is _Just registration
+  <section id=allocation-participation>
+    <h2>
+      _{MsgAllocationParticipation}
+    $if mayRegister
+      ^{registerForm'}
+    $else
+      $maybe Entity _ AllocationUser{allocationUserTotalCourses} <- registration
+        <dl .deflist>
+          <dt .deflist__dt>
+            _{MsgAllocationTotalCourses}
+          <dd .deflist__dd>
+            #{allocationUserTotalCourses}
+
+$if not (null courseWidgets)
+  <section .allocation>
+    <h2>
+      _{MsgAllocationCourses}
+    <div .allocation__explanation>
+      <p>_{MsgAllocationPriorityTip}
+      <p>_{MsgAllocationPriorityRelative}
+    <div .allocation__priority-label>
+      _{MsgAllocationPriority}
+    $forall courseWgt <- courseWidgets
+      ^{courseWgt}

templates/allocation/show/course.hamlet

@@ -0,0 +1,19 @@
+<div .allocation-course id=#{toPathPiece cID}>
+  <div .allocation-course__priority>
+    $if mayApply
+      Prio $# TODO
+    $else
+      _{MsgAllocationNoApplication}
+  <a .allocation-course__name href=@{CourseR courseTerm courseSchool courseShorthand CShowR}>
+    #{courseName}
+  $maybe aInst <- courseApplicationsInstructions
+    <div .allocation-course__instructions>
+      <p>
+        #{aInst}
+      $if hasApplicationTemplate
+        <p>
+          <a href=@{CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR}>
+            #{iconRegisterTemplate} _{MsgCourseApplicationTemplateApplication}
+  $if mayApply
+    <div .allocation-course__application uw-interactive-fieldset data-conditional-input="" data-conditional-value="" data-conditional-negated>
+