From c5b18fcfcf3b970039d2d72eab6d6f7e646d72ef Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 13 Aug 2019 17:51:12 +0200 Subject: [PATCH] feat(allocations): add registration form --- .../src/utils/form/interactive-fieldset.js | 15 ++++- .../src/utils/form/interactive-fieldset.md | 2 + messages/uniworx/de.msg | 26 +++++++ routes | 7 +- src/Foundation.hs | 7 ++ src/Handler/Allocation.hs | 1 + src/Handler/Allocation/Register.hs | 60 +++++++++++++++++ src/Handler/Allocation/Show.hs | 67 +++++++++++++++++-- src/Model/Types/Security.hs | 1 + src/Utils.hs | 6 +- templates/allocation/show.hamlet | 61 +++++++++++++++++ templates/allocation/show/course.hamlet | 19 ++++++ 12 files changed, 260 insertions(+), 12 deletions(-) create mode 100644 src/Handler/Allocation/Register.hs create mode 100644 templates/allocation/show.hamlet create mode 100644 templates/allocation/show/course.hamlet diff --git a/frontend/src/utils/form/interactive-fieldset.js b/frontend/src/utils/form/interactive-fieldset.js index 5d24ee9c2..4155a81c9 100644 --- a/frontend/src/utils/form/interactive-fieldset.js +++ b/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() { diff --git a/frontend/src/utils/form/interactive-fieldset.md b/frontend/src/utils/form/interactive-fieldset.md index 323c26e55..f98fdb0f4 100644 --- a/frontend/src/utils/form/interactive-fieldset.md +++ b/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 diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index d58321527..871c909ca 100644 --- a/messages/uniworx/de.msg +++ b/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 \ No newline at end of file diff --git a/routes b/routes index d8cbe8260..ac009ecc1 100644 --- a/routes +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 3cfa94442..78b3c0e8b 100644 --- a/src/Foundation.hs +++ b/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 diff --git a/src/Handler/Allocation.hs b/src/Handler/Allocation.hs index bed822b0d..5f97daec5 100644 --- a/src/Handler/Allocation.hs +++ b/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 diff --git a/src/Handler/Allocation/Register.hs b/src/Handler/Allocation/Register.hs new file mode 100644 index 000000000..0c19a866d --- /dev/null +++ b/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) diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index 71f1f3967..f1eba5304 100644 --- a/src/Handler/Allocation/Show.hs +++ b/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| - 
-        #{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")
diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs
index 5503f9877..fe1739fd0 100644
--- a/src/Model/Types/Security.hs
+++ b/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
diff --git a/src/Utils.hs b/src/Utils.hs
index 795787841..db521a099 100644
--- a/src/Utils.hs
+++ b/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 --
 ----------
diff --git a/templates/allocation/show.hamlet b/templates/allocation/show.hamlet
new file mode 100644
index 000000000..74711e783
--- /dev/null
+++ b/templates/allocation/show.hamlet
@@ -0,0 +1,61 @@
+$newline never
+

+  $# 

+  $#   _{MsgAllocationData}
+  

+    $maybe desc <- allocationDescription
+      

+        _{MsgAllocationDescription}
+      

+        #{desc}
+    $maybe fromT <- allocationStaffRegisterFrom
+      

+        $maybe _ <- allocationStaffRegisterTo
+          _{MsgAllocationStaffRegister}
+        $nothing
+          _{MsgAllocationStaffRegisterFrom}
+      

+        ^{formatTimeRangeW SelFormatDateTime fromT allocationStaffRegisterTo}
+    $maybe fromT <- allocationRegisterFrom
+      

+        $maybe _ <- allocationRegisterTo
+          _{MsgAllocationRegister}
+        $nothing
+          _{MsgAllocationRegisterFrom}
+      

+        ^{formatTimeRangeW SelFormatDateTime fromT allocationRegisterTo}
+    $if staffInformation
+      $maybe fromT <- allocationStaffAllocationFrom
+        

+          $maybe _ <- allocationStaffAllocationTo
+            _{MsgAllocationStaffAllocation}
+          $nothing
+            _{MsgAllocationStaffAllocationFrom}
+        

+          ^{formatTimeRangeW SelFormatDateTime fromT allocationStaffAllocationTo}
+
+$if mayRegister || is _Just registration
+  

+    

+      _{MsgAllocationParticipation}
+    $if mayRegister
+      ^{registerForm'}
+    $else
+      $maybe Entity _ AllocationUser{allocationUserTotalCourses} <- registration
+        

+          

+            _{MsgAllocationTotalCourses}
+          

+            #{allocationUserTotalCourses}
+
+$if not (null courseWidgets)
+  

+    

+      _{MsgAllocationCourses}
+    

+      
_{MsgAllocationPriorityTip}
+      
_{MsgAllocationPriorityRelative}
+    

+      _{MsgAllocationPriority}
+    $forall courseWgt <- courseWidgets
+      ^{courseWgt}
diff --git a/templates/allocation/show/course.hamlet b/templates/allocation/show/course.hamlet
new file mode 100644
index 000000000..4714f18b5
--- /dev/null
+++ b/templates/allocation/show/course.hamlet
@@ -0,0 +1,19 @@
+