feat(allocations): add courses to allocations

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

@@ -28,6 +28,10 @@ export class InteractiveFieldset {
       return false;
     }
 
+    if (this._element.querySelector('[uw-interactive-fieldset]')) {
+      return false;
+    }
+
     // param conditionalInput
     if (!this._element.dataset.conditionalInput) {
       throw new Error('Interactive Fieldset needs a selector for a conditional input!');

messages/uniworx/de.msg

@@ -142,6 +142,28 @@ CourseUserSendMail: Mitteilung verschicken
 TutorialUserDeregister: Vom Tutorium Abmelden
 TutorialUserSendMail: Mitteilung verschicken
 TutorialUsersDeregistered count@Int64: #{show count} Tutorium-Teilnehmer abgemeldet
+CourseAllocationParticipate: Teilnahme an Zentralanmeldung
+CourseAllocationParticipateTip: Wird an einer Zentralanmeldung teilgenommen, kann es sein, dass Sie bestimmte Rechte, die Sie normalerweise bzgl. Ihres Kurses hätten, nicht ausüben können (z.B. Studenten direkt zum Kurs anmelden, Studenten abmelden, ...).
+CourseAllocation: Zentralanmeldung
+CourseAllocationOption term@Text name@Text: #{name} (#{term})
+CourseAllocationMinCapacity: Minimale Teilnehmeranzahl
+CourseAllocationMinCapacityTip: Wenn der Veranstaltung bei der Zentralanmeldung weniger als diese Anzahl von Teilnehmern zugeteilt würden, werden diese stattdessen auf andere Kurse umverteilt
+CourseAllocationMinCapacityMustBeNonNegative: Minimale Teilnehmeranzahl darf nicht negativ sein
+CourseAllocationInstructions: Anweisungen zur Bewerbung
+CourseAllocationInstructionsTip: Wird den Studierenden angezeigt, wenn sie diese Veranstaltung in ihre Präferenzliste aufnehmen
+CourseAllocationApplicationTemplate: Bewerbungsvorlagen
+CourseAllocationApplicationText: Text-Bewerbungen
+CourseAllocationApplicationTextTip: Sollen die Studierenden Bewerbungen (ggf. zusätzlich zu abgegebenen Dateien) als unformatierten Text einreichen?
+CourseAllocationApplicationRatingsVisible: Feedback für Bewerbungen
+CourseAllocationApplicationRatingsVisibleTip: Sollen Bewertung und Kommentar der Bewerbungen den Studierenden nach Ende der Bewertungs-Phase angezeigt werden?
+
+
+CourseNoAllocationsAvailable: Es sind aktuell keine Zentralanmeldungen verfügbar
+AllocationStaffRegisterToExpired: Es dürfen keine Änderungen an der Eintragung des Kurses zur Zentralanmeldung mehr vorgenommen werden
+
+
+CourseFormSectionRegistration: Anmeldung
+CourseFormSectionAdministration: Verwaltung
 
 CourseLecturers: Kursverwalter
 CourseLecturer: Dozent

models/allocations

@@ -22,7 +22,7 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis
     registerByStaffFrom UTCTime Maybe   -- lecturers may directly enrol/disenrol students after a given date or prohibited
     registerByStaffTo   UTCTime Maybe
     registerByCourse    UTCTime Maybe   -- course registration dates are ignored until this day has passed or always prohibited
-    overrideDeregister  UTCTime Maybe   -- course deregistration enforced to be this date, i.e. students may disenrol from course before or never
+    overrideDeregister  UTCTime Maybe   -- course deregistration enforced to be this date, i.e. students may disenrol from course after or never
     -- overrideVisible not needed, since courses are always visible
     TermSchoolAllocationShort  term school shorthand    -- shorthand must be unique within school and semester
     TermSchoolAllocationName   term school name         -- name must be unique within school and semester
@@ -30,37 +30,42 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis
 AllocationCourse
     allocation          AllocationId
     course              CourseId
+    minCapacity         Int          -- if the course would get assigned fewer than this many applicants, restart the assignment process without the course
+    instructions        Html Maybe   -- instructions from the lecturer to applicants
     applicationText     Bool         -- lecturer will read application texts supplied by users
     applicationFiles    UploadMode   -- lecturer wants to receive course specific application files
     ratingsVisible      Bool         -- lecturer wants applicants to receive feedback on their application (Grade & comment)
-    UniqueAllocationCourse allocation course
+    UniqueAllocationCourse course
 
 AllocationCourseFile
-    allocation          AllocationId
+    allocationCourse    AllocationCourseId
-    course              CourseId
     file                FileId
+    UniqueAllocationCourseFile allocationCourse file
 
-AllocationUserCourse
+AllocationUser
     allocation          AllocationId
     user                UserId
-    course              CourseId
+    totalCourses        Natural          -- number of total allocated courses for this user must be <= than this number
+    UniqueAllocationUser allocation user
+
+AllocationApplication
+    allocationCourse    AllocationCourseId
+    allocationUser      AllocationUserId
     text                Text       Maybe -- free text entered by user
     priority            Natural          -- priority, higher number means higher priority
-    totalCourses        Natural          -- number of total allocated courses for this user must be <= than this number, if this course is part of that allocation
     ratingVeto          Bool
     ratingPoints        ExamGrade Maybe
     ratingComment       Text      Maybe
-    UniqueAllocationUserCourse allocation user course
+    UniqueAllocationApplication allocationCourse allocationUser
 
-AllocationUserFile -- supplemental file for application by a user for a certain course, not unique
+AllocationApplicationFile -- supplemental file for application by a user for a certain course
-    allocation          AllocationId
+    application          AllocationApplicationId
-    user                UserId
+    file                 FileId
-    course              CourseId
+    UniqueAllocationUserFile application file
-    file                FileId
 
 AllocationDeregister -- self-inflicted user-deregistrations from an allocated course
     user                UserId
-    allocation          AllocationId
+    allocation          AllocationId Maybe
-    course              CourseId
+    course              CourseId Maybe
     time                UTCTime
     reason              Text Maybe -- if this deregistration was done by proxy (e.g. the lecturer pressed the button)

src/CryptoID.hs

@@ -45,6 +45,7 @@ decCryptoIDs [ ''SubmissionId
              , ''StudyFeaturesId
              , ''ExamOccurrenceId
              , ''ExamPartId
+             , ''AllocationId
              ]
 
 instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where

src/Handler/Course/Edit.hs

@@ -18,32 +18,49 @@ import qualified Data.Set as Set
 import Data.Map ((!))
 import qualified Data.Map as Map
 
+import Control.Monad.Trans.Writer (execWriterT)
+
 import qualified Database.Esqueleto as E
 
 import Jobs.Queue
 
 import Handler.Course.LecturerInvite
 
+import Text.Blaze.Html.Renderer.Text (renderHtml)
+
+import qualified Data.Conduit.List as C
+
 
 data CourseForm = CourseForm
-        { cfCourseId   :: Maybe CourseId
+        { cfCourseId    :: Maybe CourseId
-        , cfName       :: CourseName
+        , cfName        :: CourseName
-        , cfDesc       :: Maybe Html
+        , cfShort       :: CourseShorthand
-        , cfLink       :: Maybe Text
+        , cfSchool      :: SchoolId
-        , cfShort      :: CourseShorthand
+        , cfTerm        :: TermId
-        , cfTerm       :: TermId
+        , cfDesc        :: Maybe Html
-        , cfSchool     :: SchoolId
+        , cfLink        :: Maybe Text
-        , cfCapacity   :: Maybe Int
+        , cfMatFree     :: Bool
-        , cfSecret     :: Maybe Text
+        , cfAllocation  :: Maybe AllocationCourseForm
-        , cfMatFree    :: Bool
+        , cfCapacity    :: Maybe Int
-        , cfRegFrom    :: Maybe UTCTime
+        , cfSecret      :: Maybe Text
-        , cfRegTo      :: Maybe UTCTime
+        , cfRegFrom     :: Maybe UTCTime
-        , cfDeRegUntil :: Maybe UTCTime
+        , cfRegTo       :: Maybe UTCTime
-        , cfLecturers  :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
+        , cfDeRegUntil  :: Maybe UTCTime
+        , cfLecturers   :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
         }
 
-courseToForm :: Entity Course -> [Lecturer] -> [(UserEmail, InvitationDBData Lecturer)] -> CourseForm
+data AllocationCourseForm = AllocationCourseForm
-courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm
+  { acfAllocation                :: AllocationId
+  , acfMinCapacity               :: Int
+  , acfInstructions              :: Maybe Html
+  , acfFiles                     :: Maybe (Source Handler (Either FileId File))
+  , acfApplicationText           :: Bool
+  , acfApplicationFiles          :: UploadMode
+  , acfApplicationRatingsVisible :: Bool
+  }
+
+courseToForm :: Entity Course -> [Lecturer] -> [(UserEmail, InvitationDBData Lecturer)] -> Maybe (Entity AllocationCourse) -> CourseForm
+courseToForm (Entity cid Course{..}) lecs lecInvites alloc = CourseForm
     { cfCourseId   = Just cid
     , cfName       = courseName
     , cfDesc       = courseDescription
@@ -57,10 +74,22 @@ courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm
     , cfRegFrom    = courseRegisterFrom
     , cfRegTo      = courseRegisterTo
     , cfDeRegUntil = courseDeregisterUntil
+    , cfAllocation = allocationCourseToForm <$> alloc
     , cfLecturers  = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs]
                   ++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- lecInvites ]
     }
 
+allocationCourseToForm :: Entity AllocationCourse -> AllocationCourseForm
+allocationCourseToForm (Entity _ AllocationCourse{..}) = AllocationCourseForm
+  { acfAllocation = allocationCourseAllocation
+  , acfMinCapacity = allocationCourseMinCapacity
+  , acfInstructions = allocationCourseInstructions
+  , acfFiles = Nothing
+  , acfApplicationText = allocationCourseApplicationText
+  , acfApplicationFiles = allocationCourseApplicationFiles
+  , acfApplicationRatingsVisible = allocationCourseRatingsVisible
+  }
+
 makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm
 makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
     -- TODO: Refactor to avoid the four repeated calls to liftHandlerT and three runDBs
@@ -159,29 +188,76 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
                    , (Just . beforeMidnight . termEnd   . entityVal) <$> mbLastTerm
                    , (Just . beforeMidnight . termEnd   . entityVal) <$> mbLastTerm )
 
+    let
+      allocationForm :: AForm Handler (Maybe AllocationCourseForm)
+      allocationForm = wFormToAForm $ do
+        availableAllocations' <- liftHandlerT . runDB . E.select . E.from $ \(allocation `E.InnerJoin` term) -> do
+          E.on $ allocation E.^. AllocationTerm E.==. term E.^. TermId
+          E.where_ $ term E.^. TermActive
+          return allocation
+
+        now <- liftIO getCurrentTime
+        let
+          allocationEnabled :: Entity Allocation -> Bool
+          allocationEnabled (Entity _ Allocation{..}) = NTop allocationStaffRegisterFrom <= NTop (Just now)
+                                                     && NTop (Just now) <= NTop allocationStaffRegisterTo
+          availableAllocations = filter allocationEnabled availableAllocations'
+
+          mkAllocationOption :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Allocation -> m (Option AllocationId)
+          mkAllocationOption (Entity aId Allocation{..}) = liftHandlerT $ do
+            cID <- encrypt aId :: Handler CryptoUUIDAllocation
+            return . Option (mr . MsgCourseAllocationOption (mr . ShortTermIdentifier $ unTermKey allocationTerm) $ CI.original allocationName) aId $ toPathPiece cID
+
+        case availableAllocations of
+          [] -> wforced (convertField (const Nothing) (const False) checkBoxField) (fslI MsgCourseAllocationParticipate & setTooltip MsgCourseNoAllocationsAvailable) Nothing
+          _  -> do
+            allocationOptions <- mkOptionList <$> mapM mkAllocationOption availableAllocations
+
+            oldFileIds <- for ((,) <$> (fmap acfAllocation $ template >>= cfAllocation) <*> (template >>= cfCourseId)) $ \(allId, cId) -> fmap (Set.fromList . map E.unValue) . liftHandlerT . runDB . E.select . E.from $ \(allocationCourseFile `E.InnerJoin` allocationCourse) -> do
+              E.on $ allocationCourseFile E.^. AllocationCourseFileAllocationCourse E.==. allocationCourse E.^. AllocationCourseId
+              E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. E.val cId
+                   E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val allId
+              return $ allocationCourseFile E.^. AllocationCourseFileFile
+              
+
+            let
+              allocationForm' = AllocationCourseForm
+                <$> apreq (selectField' Nothing $ return allocationOptions) (fslI MsgCourseAllocation) (fmap acfAllocation $ template >>= cfAllocation)
+                <*> apreq (natFieldI MsgCourseAllocationMinCapacityMustBeNonNegative) (fslI MsgCourseAllocationMinCapacity & setTooltip MsgCourseAllocationMinCapacityTip) (fmap acfMinCapacity $ template >>= cfAllocation)
+                <*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslI MsgCourseAllocationInstructions & setTooltip MsgCourseAllocationInstructionsTip) (fmap acfInstructions $ template >>= cfAllocation))
+                <*> aopt (multiFileField . return $ fromMaybe Set.empty oldFileIds) (fslI MsgCourseAllocationApplicationTemplate) (fmap acfFiles $ template >>= cfAllocation)
+                <*> apopt checkBoxField (fslI MsgCourseAllocationApplicationText & setTooltip MsgCourseAllocationApplicationTextTip) (fmap acfApplicationText $ template >>= cfAllocation)
+                <*> uploadModeForm (fmap acfApplicationFiles $ template >>= cfAllocation)
+                <*> apopt checkBoxField (fslI MsgCourseAllocationApplicationRatingsVisible & setTooltip MsgCourseAllocationApplicationRatingsVisibleTip) (fmap acfApplicationRatingsVisible $ template >>= cfAllocation)
+            
+            optionalActionW allocationForm' (fslI MsgCourseAllocationParticipate & setTooltip MsgCourseAllocationParticipateTip) (is _Just . cfAllocation <$> template)
+
     (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
       <$> pure (cfCourseId =<< template)
       <*> areq ciField (fslI MsgCourseName)                             (cfName       <$> template)
+      <*> areq ciField (fslI MsgCourseShorthand
+            -- & addAttr "disabled" "disabled"
+            & setTooltip MsgCourseShorthandUnique)                      (cfShort      <$> template)
+      <*> areq (schoolFieldFor userSchools)   (fslI MsgCourseSchool)    (cfSchool     <$> template)
+      <*> areq termsField                     (fslI MsgCourseSemester)  (cfTerm       <$> template)
       <*> aopt htmlField (fslpI MsgCourseDescription "Bitte mindestens die Modulbeschreibung angeben"
                          & setTooltip MsgCourseDescriptionTip)          (cfDesc       <$> template)
       <*> aopt urlField  (fslpI MsgCourseHomepageExternal "Optionale externe URL")
                                                                         (cfLink       <$> template)
-      <*> areq ciField (fslI MsgCourseShorthand
+      <*> apopt checkBoxField  (fslI  MsgMaterialFree)                   (cfMatFree    <$> template)
-            -- & addAttr "disabled" "disabled"
+      <*  aformSection MsgCourseFormSectionRegistration
-            & setTooltip MsgCourseShorthandUnique)                      (cfShort      <$> template)
+      <*> allocationForm
-      <*> areq termsField                     (fslI MsgCourseSemester)  (cfTerm       <$> template)
-      <*> areq (schoolFieldFor userSchools)   (fslI MsgCourseSchool)    (cfSchool     <$> template)
       <*> aopt (natFieldI MsgCourseCapacity)  (fslI MsgCourseCapacity
             & setTooltip MsgCourseCapacityTip)                          (cfCapacity   <$> template)
       <*> aopt textField      (fslpI MsgCourseSecret (mr MsgCourseSecretFormat)
             & setTooltip MsgCourseSecretTip)                            (cfSecret     <$> template)
-      <*> areq checkBoxField  (fslI  MsgMaterialFree)                   (cfMatFree    <$> template)
       <*> aopt utcTimeField   (fslpI MsgRegisterFrom (mr MsgDate)
             & setTooltip MsgCourseRegisterFromTip)                      (deepAlt (cfRegFrom    <$> template) newRegFrom)
       <*> aopt utcTimeField   (fslpI MsgRegisterTo   (mr MsgDate)
             & setTooltip MsgCourseRegisterToTip)                        (deepAlt (cfRegTo      <$> template) newRegTo)
       <*> aopt utcTimeField   (fslpI MsgDeRegUntil   (mr MsgDate)
             & setTooltip MsgCourseDeregisterUntilTip)                   (deepAlt (cfDeRegUntil <$> template) newDeRegUntil)
+      <*  aformSection MsgCourseFormSectionAdministration
       <*> lecturerForm
     errorMsgs' <- traverse validateCourse result
     return $ case errorMsgs' of
@@ -269,7 +345,7 @@ getCourseNewR = do
           return course
       template <- case listToMaybe oldCourses of
         (Just oldTemplate) ->
-            let newTemplate = courseToForm oldTemplate [] [] in
+            let newTemplate = courseToForm oldTemplate [] [] Nothing in
             return $ Just $ newTemplate
                 { cfCourseId   = Nothing
                 , cfTerm       = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
@@ -302,10 +378,11 @@ pgCEditR tid ssh csh = do
       mbCourse     <- getBy (TermSchoolCourseShort tid ssh csh)
       mbLecs       <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
       mbLecInvites <- for mbCourse $ sourceInvitationsList . entityKey
-      return $ (,,) <$> mbCourse <*> mbLecs <*> mbLecInvites
+      mbAllocation <- for mbCourse $ \course -> getBy . UniqueAllocationCourse $ entityKey course
+      return $ (,,,) <$> mbCourse <*> mbLecs <*> mbLecInvites <*> mbAllocation
   -- IMPORTANT: both GET and POST Handler must use the same template,
   --    since an Edit is identified via CourseID, which is not embedded in the received form data for security reasons.
-  courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 3) courseToForm <$> courseData
+  courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 4) courseToForm <$> courseData
 
 
 -- | Course Creation and Editing
@@ -343,6 +420,7 @@ courseEditHandler miButtonAction mbCourseForm = do
               insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
               sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
               insert_ $ CourseEdit aid now cid
+              upsertAllocationCourse cid $ cfAllocation res
             return insertOkay
           case insertOkay of
             Just _ -> do
@@ -388,6 +466,7 @@ courseEditHandler miButtonAction mbCourseForm = do
                     sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
 
                     insert_ $ CourseEdit aid now cid
+                    upsertAllocationCourse cid $ cfAllocation res
                     addMessageI Success $ MsgCourseEditOk tid ssh csh
                     return True
           when success $ redirect $ CourseR tid ssh csh CShowR
@@ -398,3 +477,53 @@ courseEditHandler miButtonAction mbCourseForm = do
         { formAction = Just $ SomeRoute actionUrl
         , formEncoding = formEnctype
         }
+
+upsertAllocationCourse :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m ()
+upsertAllocationCourse cid cfAllocation = do
+  now <- liftIO getCurrentTime
+  prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
+  prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
+
+  if -- TODO: loophole for admins
+    | Just Allocation{allocationStaffRegisterTo} <- prevAllocation
+    , NTop allocationStaffRegisterTo <= NTop (Just now)
+      -> permissionDeniedI MsgAllocationStaffRegisterToExpired
+    | otherwise
+      -> return ()
+  
+  case cfAllocation of
+    Just AllocationCourseForm{..} -> do
+      Entity acId _ <- upsert AllocationCourse
+        { allocationCourseAllocation       = acfAllocation
+        , allocationCourseCourse           = cid
+        , allocationCourseMinCapacity      = acfMinCapacity
+        , allocationCourseInstructions     = acfInstructions
+        , allocationCourseApplicationText  = acfApplicationText
+        , allocationCourseApplicationFiles = acfApplicationFiles
+        , allocationCourseRatingsVisible   = acfApplicationRatingsVisible
+        }
+        [ AllocationCourseAllocation       =. acfAllocation
+        , AllocationCourseCourse           =. cid
+        , AllocationCourseMinCapacity      =. acfMinCapacity
+        , AllocationCourseInstructions     =. acfInstructions
+        , AllocationCourseApplicationText  =. acfApplicationText
+        , AllocationCourseApplicationFiles =. acfApplicationFiles
+        , AllocationCourseRatingsVisible   =. acfApplicationRatingsVisible
+        ]
+
+      let
+        finsert val = do
+          fId <- lift $ either return insert val
+          tell $ Set.singleton fId
+          lift $
+            void . insertUnique $ AllocationCourseFile acId fId
+      keep <- execWriterT . runConduit $ transPipe liftHandlerT (traverse_ id acfFiles) .| C.mapM_ finsert
+      acfs <- selectList [ AllocationCourseFileAllocationCourse ==. acId, AllocationCourseFileFile /<-. Set.toList keep ] []
+      mapM_ deleteCascade $ map (allocationCourseFileFile . entityVal) acfs
+    Nothing
+      | Just (Entity prevId _) <- prevAllocationCourse
+        -> do
+          acfs <- selectList [ AllocationCourseFileAllocationCourse ==. prevId ] []
+          mapM_ deleteCascade $ map (allocationCourseFileFile . entityVal) acfs
+          delete prevId
+    _other -> return ()

src/Handler/Course/ParticipantInvite.hs

@@ -36,6 +36,7 @@ instance IsInvitableJunction CourseParticipant where
   data InvitableJunction CourseParticipant = JunctionParticipant
     { jParticipantRegistration :: UTCTime
     , jParticipantField        :: Maybe StudyFeaturesId
+    , jParticipantAllocated    :: Bool
     } deriving (Eq, Ord, Read, Show, Generic, Typeable)
   data InvitationDBData CourseParticipant = InvDBDataParticipant
     -- no data needed in DB to manage participant invitation
@@ -44,8 +45,8 @@ instance IsInvitableJunction CourseParticipant where
     deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
   _InvitableJunction = iso
-    (\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField))
+    (\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated))
-    (\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField) -> CourseParticipant{..})
+    (\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated) -> CourseParticipant{..})
 
 instance ToJSON (InvitableJunction CourseParticipant) where
   toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
@@ -83,7 +84,7 @@ participantInvitationConfig = InvitationConfig{..}
       now <- liftIO getCurrentTime
       studyFeatures <- wreq (studyFeaturesPrimaryFieldFor False [] $ Just uid)
           (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTooltip) Nothing
-      return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures
+      return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure False
     invitationInsertHook _ _ _ _ = id
     invitationSuccessMsg (Entity _ Course{..}) _ =
       return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName)
@@ -161,6 +162,7 @@ postCAddUserR tid ssh csh = do
       void . lift . lift . insert $ CourseParticipant
         { courseParticipantCourse = cid
         , courseParticipantUser = uid
+        , courseParticipantAllocated = False
         , ..
         }
 

src/Handler/Course/Register.hs

@@ -89,7 +89,7 @@ postCRegisterR tid ssh csh = do
           addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk
       | codeOk -> do
           actTime <- liftIO getCurrentTime
-          regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime mbSfId
+          regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime mbSfId False
           when (isJust regOk) $ addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
       | otherwise -> addMessageI Warning MsgCourseSecretWrong
   -- addMessage Info $ toHtml $ show regResult -- For debugging only

src/Handler/Course/User.hs

@@ -145,7 +145,7 @@ postCUserR tid ssh csh uCId = do
             = Just featId
             | otherwise
             = Nothing
-      pId <- runDB . insertUnique $ CourseParticipant cid uid now primaryField
+      pId <- runDB . insertUnique $ CourseParticipant cid uid now primaryField False
       case pId of
         Just _  -> do
           addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk

src/Handler/Exam/AddUser.hs

@@ -144,6 +144,7 @@ postEAddUserR tid ssh csh examn = do
         { courseParticipantCourse = cid
         , courseParticipantUser = uid
         , courseParticipantRegistration = now
+        , courseParticipantAllocated = False
         , ..
         }
       lift $ lift examRegister

src/Handler/Exam/RegistrationInvite.hs

@@ -94,8 +94,8 @@ examRegistrationInvitationConfig = InvitationConfig{..}
           return $ (JunctionExamRegistration invDBExamRegistrationOccurrence now, ) . Just <$> fieldRes
         (True , _    ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing) 
     invitationInsertHook (Entity _ Exam{..}) _ ExamRegistration{..} mField act = do
-      whenIsJust mField $
+      whenIsJust mField $ \cpField -> 
-        insert_ . CourseParticipant examCourse examRegistrationUser examRegistrationTime
+        insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField False
       
       Course{..} <- get404 examCourse
       User{..} <- get404 examRegistrationUser

src/Handler/Exam/Users.hs

@@ -441,6 +441,7 @@ postEUsersR tid ssh csh examn = do
                       , courseParticipantUser = examUserCsvActUser
                       , courseParticipantRegistration = now
                       , courseParticipantField = examUserCsvActCourseField
+                      , courseParticipantAllocated = False
                       }
                     User{userIdent} <- getJust examUserCsvActUser
                     audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent

src/Handler/Utils/Form.hs

@@ -169,9 +169,34 @@ linkButton defWdgt lbl cls url = do
 -- Interactive fieldset --
 --------------------------
 
+optionalAction :: AForm Handler a
+               -> FieldSettings UniWorX
+               -> Maybe Bool
+               -> (Html -> MForm Handler (FormResult (Maybe a), [FieldView UniWorX]))
+optionalAction justAct fs@FieldSettings{..} defActive csrf = do
+  (doRes, doView) <- mpopt checkBoxField fs defActive
+  (actionRes, actionViews') <- over _2 ($ []) <$> aFormToForm justAct
+
+  let actionViews = over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/optional-action")) actionViews'
+
+  return (doRes >>= bool (pure Nothing) (Just <$> actionRes), over _fvInput (mappend $ toWidget csrf) doView : actionViews)
+  
+optionalActionA :: AForm Handler a
+                -> FieldSettings UniWorX
+                -> Maybe Bool
+                -> AForm Handler (Maybe a)
+optionalActionA justAct fs defActive = formToAForm $ optionalAction justAct fs defActive mempty
+
+optionalActionW :: AForm Handler a
+                -> FieldSettings UniWorX
+                -> Maybe Bool
+                -> WForm Handler (FormResult (Maybe a))
+optionalActionW justAct fs defAction = aFormToWForm $ optionalActionA justAct fs defAction
+
+
 multiAction :: forall action a.
                ( RenderMessage UniWorX action, PathPiece action, Ord action, Eq action )
-            => Map action (AForm (HandlerT UniWorX IO) a)
+            => Map action (AForm Handler a)
             -> FieldSettings UniWorX
             -> Maybe action
             -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))

src/Model/Types/Exam.hs

@@ -18,6 +18,8 @@ import Control.Lens hiding (universe)
 import Utils.Lens.TH
 
 import qualified Data.Csv as Csv
+
+import Database.Persist.Sql
   
 
 data ExamResult' res = ExamAttended { examResult :: res }
@@ -170,6 +172,14 @@ instance Csv.FromField ExamGrade where
   parseField x = (parse =<< Csv.parseField x) <|> (parse . Text.replace "," "." =<< Csv.parseField x) -- Ugh.
     where parse = maybe (fail "Could not decode PathPiece") return . fromPathPiece
 
+instance PersistField ExamGrade where
+  toPersistValue = PersistRational . review numberGrade
+  fromPersistValue = maybe (Left "Could not decode Rational to ExamGrade") Right . preview numberGrade <=< fromPersistValue
+
+instance PersistFieldSql ExamGrade where
+  sqlType _ = SqlNumeric 2 1
+
+
 data ExamGradingRule
   = ExamGradingManual
   | ExamGradingKey
@@ -186,7 +196,7 @@ derivePersistFieldJSON ''ExamGradingRule
 
 newtype ExamPassed = ExamPassed { examPassed :: Bool }
   deriving (Read, Show, Generic, Typeable)
-  deriving newtype (Eq, Ord, Enum, Bounded)
+  deriving newtype (Eq, Ord, Enum, Bounded, PersistField, PersistFieldSql)
 
 deriveFinite ''ExamPassed
 finitePathPiece ''ExamPassed ["failed", "passed"]

src/Utils/Form.hs

@@ -621,6 +621,46 @@ checkMap :: (Monad m, RenderMessage (HandlerSite m) msg) => (a -> Either msg b)
 checkMap f = checkMMap (return . f)
 
 
+selectField' :: ( Eq a
+                , RenderMessage (HandlerSite m) FormMessage
+                , MonadHandler m
+                )
+             => Maybe (SomeMessage (HandlerSite m)) -- ^ Caption used for @Nothing@-Option, if Field is optional and whether to show such an option
+             -> HandlerT (HandlerSite m) IO (OptionList a)
+             -> Field m a
+-- ^ Like @selectField@, but with more control over the @Nothing@-Option, if Field is optional
+selectField' optMsg mkOpts = Field{..}
+  where
+    fieldEnctype = UrlEncoded
+    
+    fieldParse []    _ = return $ Right Nothing
+    fieldParse (s:_) _
+      | s == ""     = return $ Right Nothing
+      | otherwise = do
+          OptionList{olReadExternal} <- liftHandlerT mkOpts
+          return . maybe (Left . SomeMessage $ MsgInvalidEntry s) (Right . Just) $ olReadExternal s
+
+    fieldView theId name attrs val isReq = do
+      OptionList{olOptions} <- liftHandlerT mkOpts
+      let
+        rendered = case val of
+          Left  _ -> ""
+          Right a -> maybe "" optionExternalValue . listToMaybe $ filter ((== a) . optionInternalValue) olOptions
+        
+        isSel Nothing    = not $ rendered `elem` map optionExternalValue olOptions
+        isSel (Just opt) = rendered == optionExternalValue opt
+      [whamlet|
+        $newline never
+        <select ##{theId} name=#{name} *{attrs} :isReq:required>
+          $maybe optMsg' <- assertM (const $ not isReq) optMsg
+            <option value="" :isSel Nothing:selected>
+              _{optMsg'}
+          $forall opt <- olOptions
+            <option value=#{optionExternalValue opt} :isSel (Just opt):selected>
+              #{optionDisplay opt}
+      |]
+
+
 -----------
 -- Forms --
 -----------
@@ -951,6 +991,10 @@ aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m
         => Field m a -> FieldSettings site -> a -> AForm m a
 aforced field settings val = formToAForm $ over _2 pure <$> mforced field settings val
 
+wforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+        => Field m a -> FieldSettings site -> a -> WForm m (FormResult a)
+wforced field settings val = mFormToWForm $ mforced field settings val
+
 mpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
       => Field m a -> FieldSettings site -> Maybe a -> MForm m (FormResult a, FieldView site)
 -- ^ Pseudo required

templates/widgets/multi-action/optional-action.hamlet

@@ -0,0 +1,4 @@
+<fieldset uw-interactive-fieldset data-conditional-input=#{fvId doView}>
+  <legend>
+    _{fsLabel}
+  ^{w}

test/Database.hs

@@ -432,7 +432,7 @@ fillDb = do
   insert_ $ SheetEdit gkleen now feste
   keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ UploadAny True Nothing) False
   insert_ $ SheetEdit gkleen now keine
-  void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf)
+  void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf False)
     [(fhamann   , Nothing)
     ,(maxMuster , Just sfMMs)
     ,(tinaTester, Just sfTTc)
@@ -510,7 +510,7 @@ fillDb = do
   insert_ $ CourseEdit jost now pmo
   void . insert $ DegreeCourse pmo sdBsc sdInf
   void . insert $ Lecturer jost pmo CourseAssistant
-  void . insertMany $ map (\(u,sf) -> CourseParticipant pmo u now sf)
+  void . insertMany $ map (\(u,sf) -> CourseParticipant pmo u now sf False)
     [(fhamann   , Nothing)
     ,(maxMuster , Just sfMMp)
     ,(tinaTester, Just sfTTb)

test/Model/TypesSpec.hs

@@ -25,6 +25,8 @@ import Time.Types (WeekDay(..))
 
 import qualified Net.IP as IP
 
+import Web.PathPieces
+
 
 instance (Arbitrary a, MonoFoldable a) => Arbitrary (NonNull a) where
   arbitrary = arbitrary `suchThatMap` fromNullable
@@ -215,6 +217,35 @@ instance Arbitrary Occurrences where
   arbitrary = genericArbitrary
   shrink = genericShrink
 
+instance Arbitrary res => Arbitrary (ExamResult' res) where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
+instance Arbitrary ExamBonusRule where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
+instance Arbitrary ExamOccurrenceRule where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
+instance Arbitrary ExamGrade where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
+instance Arbitrary ExamGradingRule where
+  arbitrary = oneof
+    [ pure ExamGradingManual
+    , ExamGradingKey . reverse . fromOffsets . map getNonNegative <$> replicateM 11 arbitrary
+    ]
+    where
+      fromOffsets [] = []
+      fromOffsets (x:xs) = x + sum xs : fromOffsets xs
+
+instance Arbitrary ExamPassed where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
 
 spec :: Spec
 spec = do
@@ -265,6 +296,8 @@ spec = do
       [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
     lawsCheckHspec (Proxy @Value)
       [ persistFieldLaws ]
+    lawsCheckHspec (Proxy @Points)
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws, csvFieldLaws ]
     lawsCheckHspec (Proxy @NotificationTrigger)
       [ eqLaws, ordLaws, showReadLaws, jsonLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, jsonKeyLaws ]
     lawsCheckHspec (Proxy @NotificationSettings)
@@ -278,7 +311,23 @@ spec = do
     lawsCheckHspec (Proxy @LecturerType)
       [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws ]
     lawsCheckHspec (Proxy @IP)
-      [ eqLaws, ordLaws, showReadLaws, jsonLaws ]
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @ExamResultPoints)
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws, csvFieldLaws ]
+    lawsCheckHspec (Proxy @ExamResultGrade)
+      [ eqLaws, ordLaws, showReadLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws, csvFieldLaws ]
+    lawsCheckHspec (Proxy @ExamResultPassed)
+      [ eqLaws, ordLaws, showReadLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws, csvFieldLaws ]
+    lawsCheckHspec (Proxy @ExamBonusRule)
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @ExamOccurrenceRule)
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @ExamGrade)
+      [ eqLaws, ordLaws, showReadLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws, csvFieldLaws ]
+    lawsCheckHspec (Proxy @ExamGradingRule)
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @ExamPassed)
+      [ eqLaws, ordLaws, showReadLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws, csvFieldLaws ]
 
   describe "TermIdentifier" $ do
     it "has compatible encoding/decoding to/from Text" . property $
@@ -297,6 +346,10 @@ spec = do
       \pseudonym -> preview _PseudonymText (review _PseudonymText pseudonym) == Just pseudonym
     it "encodes to Text injectively" . property $
       \p1 p2 -> p1 /= p2 ==> ((/=) `on` review _PseudonymText) p1 p2
+  describe "ExamPassed" $
+    it "encodes to PathPiece as expected" . example $ do
+      toPathPiece (ExamPassed False) `shouldBe` pack "failed"
+      toPathPiece (ExamPassed True) `shouldBe` pack "passed"
 
 termExample :: (TermIdentifier, Text) -> Expectation
 termExample (term, encoded) = example $ do

test/Test/QuickCheck/Classes/Csv.hs

@@ -0,0 +1,20 @@
+module Test.QuickCheck.Classes.Csv
+  ( csvRecordLaws
+  , csvFieldLaws
+  ) where
+
+import ClassyPrelude
+import Test.QuickCheck
+import Test.QuickCheck.Classes
+import qualified Data.Csv as Csv
+import Data.Proxy
+
+csvRecordLaws :: forall a. (Arbitrary a, Csv.ToNamedRecord a, Csv.FromNamedRecord a, Eq a, Show a) => Proxy a -> Laws
+csvRecordLaws _ = Laws "Csv.NamedRecord"
+  [ ("Partial Isomorphism", property $ \(a :: a) -> Csv.runParser (Csv.parseNamedRecord $ Csv.toNamedRecord a) == Right a)
+  ]
+
+csvFieldLaws :: forall a. (Arbitrary a, Csv.ToField a, Csv.FromField a, Eq a, Show a) => Proxy a -> Laws
+csvFieldLaws _ = Laws "Csv.Field"
+  [ ("Partial Isomorphism", property $ \(a :: a) -> Csv.runParser (Csv.parseField $ Csv.toField a) == Right a)
+  ]

test/TestImport.hs

@@ -28,6 +28,7 @@ import Test.QuickCheck.Classes.JSON as X
 import Test.QuickCheck.Classes.HttpApiData as X
 import Test.QuickCheck.Classes.Universe as X
 import Test.QuickCheck.Classes.Binary as X
+import Test.QuickCheck.Classes.Csv as X
 import Data.Proxy as X
 import Data.UUID as X (UUID)
 import System.IO as X (hPrint, hPutStrLn, stderr)