From 14a9a4567491253cb220c51a458e029e6d75e00a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 5 Aug 2019 11:34:00 +0200 Subject: [PATCH] feat(allocations): add courses to allocations --- .../src/utils/form/interactive-fieldset.js | 4 + messages/uniworx/de.msg | 22 +++ models/allocations | 35 ++-- src/CryptoID.hs | 1 + src/Handler/Course/Edit.hs | 179 +++++++++++++++--- src/Handler/Course/ParticipantInvite.hs | 8 +- src/Handler/Course/Register.hs | 2 +- src/Handler/Course/User.hs | 2 +- src/Handler/Exam/AddUser.hs | 1 + src/Handler/Exam/RegistrationInvite.hs | 4 +- src/Handler/Exam/Users.hs | 1 + src/Handler/Utils/Form.hs | 27 ++- src/Model/Types/Exam.hs | 12 +- src/Utils/Form.hs | 44 +++++ .../multi-action/optional-action.hamlet | 4 + test/Database.hs | 4 +- test/Model/TypesSpec.hs | 55 +++++- test/Test/QuickCheck/Classes/Csv.hs | 20 ++ test/TestImport.hs | 1 + 19 files changed, 374 insertions(+), 52 deletions(-) create mode 100644 templates/widgets/multi-action/optional-action.hamlet create mode 100644 test/Test/QuickCheck/Classes/Csv.hs diff --git a/frontend/src/utils/form/interactive-fieldset.js b/frontend/src/utils/form/interactive-fieldset.js index 916c01aa3..5d24ee9c2 100644 --- a/frontend/src/utils/form/interactive-fieldset.js +++ b/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!'); diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index ea133aa73..6cadf5d76 100644 --- a/messages/uniworx/de.msg +++ b/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 diff --git a/models/allocations b/models/allocations index fb318b668..71341e876 100644 --- a/models/allocations +++ b/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 - course CourseId + allocationCourse AllocationCourseId 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 - allocation AllocationId - user UserId - course CourseId - file FileId +AllocationApplicationFile -- supplemental file for application by a user for a certain course + application AllocationApplicationId + file FileId + UniqueAllocationUserFile application file AllocationDeregister -- self-inflicted user-deregistrations from an allocated course user UserId - allocation AllocationId - course CourseId + allocation AllocationId Maybe + course CourseId Maybe time UTCTime reason Text Maybe -- if this deregistration was done by proxy (e.g. the lecturer pressed the button) diff --git a/src/CryptoID.hs b/src/CryptoID.hs index f170302a0..4259cb2fd 100644 --- a/src/CryptoID.hs +++ b/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 diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 49d4675ba..4a9a843c8 100644 --- a/src/Handler/Course/Edit.hs +++ b/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 - , cfName :: CourseName - , cfDesc :: Maybe Html - , cfLink :: Maybe Text - , cfShort :: CourseShorthand - , cfTerm :: TermId - , cfSchool :: SchoolId - , cfCapacity :: Maybe Int - , cfSecret :: Maybe Text - , cfMatFree :: Bool - , cfRegFrom :: Maybe UTCTime - , cfRegTo :: Maybe UTCTime - , cfDeRegUntil :: Maybe UTCTime - , cfLecturers :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)] + { cfCourseId :: Maybe CourseId + , cfName :: CourseName + , cfShort :: CourseShorthand + , cfSchool :: SchoolId + , cfTerm :: TermId + , cfDesc :: Maybe Html + , cfLink :: Maybe Text + , cfMatFree :: Bool + , cfAllocation :: Maybe AllocationCourseForm + , cfCapacity :: Maybe Int + , cfSecret :: Maybe Text + , cfRegFrom :: Maybe UTCTime + , cfRegTo :: Maybe UTCTime + , cfDeRegUntil :: Maybe UTCTime + , cfLecturers :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)] } -courseToForm :: Entity Course -> [Lecturer] -> [(UserEmail, InvitationDBData Lecturer)] -> CourseForm -courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm +data AllocationCourseForm = AllocationCourseForm + { 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 - -- & addAttr "disabled" "disabled" - & setTooltip MsgCourseShorthandUnique) (cfShort <$> template) - <*> areq termsField (fslI MsgCourseSemester) (cfTerm <$> template) - <*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool) (cfSchool <$> template) + <*> apopt checkBoxField (fslI MsgMaterialFree) (cfMatFree <$> template) + <* aformSection MsgCourseFormSectionRegistration + <*> allocationForm <*> 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 () diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 24e95743c..529f64fc6 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/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)) - (\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField) -> CourseParticipant{..}) + (\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated)) + (\(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 , .. } diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index c69c8c681..542e617d2 100644 --- a/src/Handler/Course/Register.hs +++ b/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 diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 4a2edbeb6..0fa340a08 100644 --- a/src/Handler/Course/User.hs +++ b/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 diff --git a/src/Handler/Exam/AddUser.hs b/src/Handler/Exam/AddUser.hs index f100a8d38..f9a19d5c9 100644 --- a/src/Handler/Exam/AddUser.hs +++ b/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 diff --git a/src/Handler/Exam/RegistrationInvite.hs b/src/Handler/Exam/RegistrationInvite.hs index b17fae8a5..c7ac4c7b4 100644 --- a/src/Handler/Exam/RegistrationInvite.hs +++ b/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 $ - insert_ . CourseParticipant examCourse examRegistrationUser examRegistrationTime + whenIsJust mField $ \cpField -> + insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField False Course{..} <- get404 examCourse User{..} <- get404 examRegistrationUser diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 20966b7da..bc3cb2dcf 100644 --- a/src/Handler/Exam/Users.hs +++ b/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 diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index d6c80900c..ab7af713d 100644 --- a/src/Handler/Utils/Form.hs +++ b/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])) diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index db46371e7..29928f876 100644 --- a/src/Model/Types/Exam.hs +++ b/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"] diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 7431ff251..b98c9fd2c 100644 --- a/src/Utils/Form.hs +++ b/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 +