{-# OPTIONS_GHC -fno-warn-orphans #-} module Handler.Exam where import Import import Handler.Utils import Handler.Utils.Exam import Handler.Utils.Invitations import Handler.Utils.Table.Columns import Handler.Utils.Table.Cells import Jobs.Queue import Utils.Lens hiding (parts) import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH import Data.Map ((!), (!?)) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Aeson hiding (Result(..)) import Text.Hamlet (ihamlet) import Text.Blaze.Html.Renderer.String (renderHtml) import qualified Data.CaseInsensitive as CI import qualified Control.Monad.State.Class as State getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCExamListR tid ssh csh = do Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh now <- liftIO getCurrentTime mayCreate <- hasWriteAccessTo $ CourseR tid ssh csh CExamNewR let examDBTable = DBTable{..} where dbtSQLQuery exam = do E.where_ $ exam E.^. ExamCourse E.==. E.val cid return exam dbtRowKey = (E.^. ExamId) dbtProj x@DBRow{ dbrOutput = Entity _ Exam{..} } = do guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR return x dbtColonnade = dbColonnade . mconcat $ catMaybes [ Just . sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> anchorCell (CExamR tid ssh csh examName EShowR) $ toWidget examName , (<$ guard mayCreate) . sortable (Just "visible") (i18nCell MsgExamVisibleFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty (dateTimeCellVisible now) examVisibleFrom , Just . sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom , Just . sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo , Just . sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> cell $ do startT <- formatTime SelFormatDateTime examStart endT <- traverse (\examEnd' -> formatTime (bool SelFormatDateTime SelFormatTime $ ((==) `on` utctDay) examStart examEnd') examEnd') examEnd [whamlet| $newline never #{startT} $maybe endT' <- endT \ – #{endT'} |] ] dbtSorting = Map.fromList [ ("name", SortColumn $ \exam -> exam E.^. ExamName ) , ("time", SortColumn $ \exam -> exam E.^. ExamStart ) , ("register-from", SortColumn $ \exam -> exam E.^. ExamRegisterFrom ) , ("register-to", SortColumn $ \exam -> exam E.^. ExamRegisterTo ) , ("visible", SortColumn $ \exam -> exam E.^. ExamVisibleFrom ) ] dbtFilter = Map.empty dbtFilterUI = const mempty dbtStyle = def dbtParams = def dbtIdent :: Text dbtIdent = "exams" examDBTableValidator = def & defaultSorting [SortAscBy "time"] ((), examTable) <- runDB $ dbTable examDBTableValidator examDBTable siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamsHeading) $ do setTitleI $ prependCourseTitle tid ssh csh MsgExamsHeading $(widgetFile "exam-list") instance IsInvitableJunction ExamCorrector where type InvitationFor ExamCorrector = Exam data InvitableJunction ExamCorrector = JunctionExamCorrector deriving (Eq, Ord, Read, Show, Generic, Typeable) data InvitationDBData ExamCorrector = InvDBDataExamCorrector deriving (Eq, Ord, Read, Show, Generic, Typeable) data InvitationTokenData ExamCorrector = InvTokenDataExamCorrector deriving (Eq, Ord, Read, Show, Generic, Typeable) _InvitableJunction = iso (\ExamCorrector{..} -> (examCorrectorUser, examCorrectorExam, JunctionExamCorrector)) (\(examCorrectorUser, examCorrectorExam, JunctionExamCorrector) -> ExamCorrector{..}) instance ToJSON (InvitableJunction ExamCorrector) where toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } instance FromJSON (InvitableJunction ExamCorrector) where parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } instance ToJSON (InvitationDBData ExamCorrector) where toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } instance FromJSON (InvitationDBData ExamCorrector) where parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } instance ToJSON (InvitationTokenData ExamCorrector) where toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 } instance FromJSON (InvitationTokenData ExamCorrector) where parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } examCorrectorInvitationConfig :: InvitationConfig ExamCorrector examCorrectorInvitationConfig = InvitationConfig{..} where invitationRoute (Entity _ Exam{..}) _ = do Course{..} <- get404 examCourse return $ CExamR courseTerm courseSchool courseShorthand examName ECInviteR invitationResolveFor = do Just (CExamR tid csh ssh examn ECInviteR) <- getCurrentRoute fetchExamId tid csh ssh examn invitationSubject Exam{..} _ = do Course{..} <- get404 examCourse return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName invitationHeading Exam{..} _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|] invitationTokenConfig _ _ = do itAuthority <- liftHandlerT requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized invitationForm _ _ _ = pure JunctionExamCorrector invitationSuccessMsg Exam{..} _ = return . SomeMessage $ MsgExamCorrectorInvitationAccepted examName invitationUltDest Exam{..} _ = do Course{..} <- get404 examCourse return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CExamListR getECInviteR, postECInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getECInviteR = postECInviteR postECInviteR = invitationR examCorrectorInvitationConfig data ExamForm = ExamForm { efName :: ExamName , efDescription :: Maybe Html , efStart :: UTCTime , efEnd :: Maybe UTCTime , efVisibleFrom :: Maybe UTCTime , efRegisterFrom :: Maybe UTCTime , efRegisterTo :: Maybe UTCTime , efDeregisterUntil :: Maybe UTCTime , efPublishOccurrenceAssignments :: UTCTime , efFinished :: Maybe UTCTime , efClosed :: Maybe UTCTime , efOccurrences :: Set ExamOccurrenceForm , efShowGrades :: Bool , efPublicStatistics :: Bool , efGradingRule :: ExamGradingRule , efBonusRule :: ExamBonusRule , efOccurrenceRule :: ExamOccurrenceRule , efCorrectors :: Set (Either UserEmail UserId) , efExamParts :: Set ExamPartForm } data ExamOccurrenceForm = ExamOccurrenceForm { eofId :: Maybe CryptoUUIDExamOccurrence , eofRoom :: Text , eofCapacity :: Natural , eofStart :: UTCTime , eofEnd :: Maybe UTCTime , eofDescription :: Maybe Html } deriving (Read, Show, Eq, Ord, Generic, Typeable) data ExamPartForm = ExamPartForm { epfId :: Maybe CryptoUUIDExamPart , epfName :: ExamPartName , epfMaxPoints :: Maybe Points , epfWeight :: Rational } deriving (Read, Show, Eq, Ord, Generic, Typeable) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } ''ExamPartForm deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } ''ExamOccurrenceForm examForm :: Maybe ExamForm -> Form ExamForm examForm template html = do MsgRenderer mr <- getMsgRenderer flip (renderAForm FormStandard) html $ ExamForm <$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template) <*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslpI MsgExamDescription "Html") (efDescription <$> template)) <* aformSection MsgExamFormTimes <*> areq utcTimeField (fslpI MsgExamStart (mr MsgDate) & setTooltip MsgExamTimeTip) (efStart <$> template) <*> aopt utcTimeField (fslpI MsgExamEnd (mr MsgDate) & setTooltip MsgExamTimeTip) (efEnd <$> template) <*> aopt utcTimeField (fslpI MsgExamVisibleFrom (mr MsgDate) & setTooltip MsgExamVisibleFromTip) (efVisibleFrom <$> template) <*> aopt utcTimeField (fslpI MsgExamRegisterFrom (mr MsgDate) & setTooltip MsgExamRegisterFromTip) (efRegisterFrom <$> template) <*> aopt utcTimeField (fslpI MsgExamRegisterTo (mr MsgDate)) (efRegisterTo <$> template) <*> aopt utcTimeField (fslpI MsgExamDeregisterUntil (mr MsgDate)) (efDeregisterUntil <$> template) <*> areq utcTimeField (fslpI MsgExamPublishOccurrenceAssignments (mr MsgDate) & setTooltip MsgExamPublishOccurrenceAssignments) (efPublishOccurrenceAssignments <$> template) <*> aopt utcTimeField (fslpI MsgExamFinished (mr MsgDate) & setTooltip MsgExamFinishedTip) (efFinished <$> template) <*> aopt utcTimeField (fslpI MsgExamClosed (mr MsgDate) & setTooltip MsgExamClosedTip) (efClosed <$> template) <* aformSection MsgExamFormOccurrences <*> examOccurrenceForm (efOccurrences <$> template) <* aformSection MsgExamFormAutomaticFunctions <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamShowGrades & setTooltip MsgExamShowGradesTip) (Just . efShowGrades <$> template)) <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (Just . efPublicStatistics <$> template)) <*> examGradingRuleForm (efGradingRule <$> template) <*> bonusRuleForm (efBonusRule <$> template) <*> examOccurrenceRuleForm (efOccurrenceRule <$> template) <* aformSection MsgExamFormCorrection <*> examCorrectorsForm (efCorrectors <$> template) <* aformSection MsgExamFormParts <*> examPartsForm (efExamParts <$> template) examCorrectorsForm :: Maybe (Set (Either UserEmail UserId)) -> AForm Handler (Set (Either UserEmail UserId)) examCorrectorsForm mPrev = wFormToAForm $ do MsgRenderer mr <- getMsgRenderer Just currentRoute <- getCurrentRoute uid <- liftHandlerT requireAuthId let miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId]) miAdd' nudge submitView csrf = do (addRes, addView) <- mpreq (multiUserField False $ Just corrUserSuggestions) ("" & addName (nudge "email")) Nothing let addRes' | otherwise = addRes <&> \newDat oldDat -> if | existing <- newDat `Set.intersection` Set.fromList oldDat , not $ Set.null existing -> FormFailure [mr MsgExamCorrectorAlreadyAdded] | otherwise -> FormSuccess $ Set.toList newDat return (addRes', $(widgetFile "widgets/massinput/examCorrectors/add")) corrUserSuggestions :: E.SqlQuery (E.SqlExpr (Entity User)) corrUserSuggestions = E.from $ \(lecturer `E.InnerJoin` course `E.InnerJoin` exam `E.InnerJoin` corrector `E.InnerJoin` corrUser) -> do E.on $ corrUser E.^. UserId E.==. corrector E.^. ExamCorrectorUser E.on $ corrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid return corrUser miCell' :: Either UserEmail UserId -> Widget miCell' (Left email) = $(widgetFile "widgets/massinput/examCorrectors/cellInvitation") miCell' (Right userId) = do User{..} <- liftHandlerT . runDB $ get404 userId $(widgetFile "widgets/massinput/examCorrectors/cellKnown") miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) () miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examCorrectors/layout") fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' ("correctors" :: Text) (fslI MsgExamCorrectors & setTooltip MsgMassInputTip) True (Set.toList <$> mPrev) examOccurrenceForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm) examOccurrenceForm prev = wFormToAForm $ do Just currentRoute <- getCurrentRoute let miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamOccurrences & setTooltip MsgMassInputTip) True $ Set.toList <$> prev where examOccurrenceForm' nudge mPrev csrf = do (eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev) (eofRoomRes, eofRoomView) <- mpreq textField ("" & addName (nudge "name")) (eofRoom <$> mPrev) (eofCapacityRes, eofCapacityView) <- mpreq (natFieldI MsgExamRoomCapacityNegative) ("" & addName (nudge "capacity")) (eofCapacity <$> mPrev) (eofStartRes, eofStartView) <- mpreq utcTimeField ("" & addName (nudge "start")) (eofStart <$> mPrev) (eofEndRes, eofEndView) <- mopt utcTimeField ("" & addName (nudge "end")) (eofEnd <$> mPrev) (eofDescRes, eofDescView) <- mopt htmlFieldSmall ("" & addName (nudge "description")) (eofDescription <$> mPrev) return ( ExamOccurrenceForm <$> eofIdRes <*> eofRoomRes <*> eofCapacityRes <*> eofStartRes <*> eofEndRes <*> (assertM (not . null . renderHtml) <$> eofDescRes) , $(widgetFile "widgets/massinput/examRooms/form") ) miAdd' nudge submitView csrf = do MsgRenderer mr <- getMsgRenderer (res, formWidget) <- examOccurrenceForm' nudge Nothing csrf let addRes = res <&> \newDat (Set.fromList -> oldDat) -> if | newDat `Set.member` oldDat -> FormFailure [mr MsgExamRoomAlreadyExists] | otherwise -> FormSuccess $ pure newDat return (addRes, $(widgetFile "widgets/massinput/examRooms/add")) miCell' nudge dat = examOccurrenceForm' nudge (Just dat) miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examRooms/layout") miIdent' :: Text miIdent' = "exam-occurrences" examPartsForm :: Maybe (Set ExamPartForm) -> AForm Handler (Set ExamPartForm) examPartsForm prev = wFormToAForm $ do Just currentRoute <- getCurrentRoute let miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamParts & setTooltip MsgMassInputTip) True $ Set.toList <$> prev where examPartForm' nudge mPrev csrf = do (epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev) (epfNameRes, epfNameView) <- mpreq ciField ("" & addName (nudge "name")) (epfName <$> mPrev) (epfMaxPointsRes, epfMaxPointsView) <- mopt pointsField ("" & addName (nudge "max-points")) (epfMaxPoints <$> mPrev) (epfWeightRes, epfWeightView) <- mpreq (checkBool (>= 0) MsgExamPartWeightNegative rationalField) ("" & addName (nudge "weight")) (epfWeight <$> mPrev <|> Just 1) return ( ExamPartForm <$> epfIdRes <*> epfNameRes <*> epfMaxPointsRes <*> epfWeightRes , $(widgetFile "widgets/massinput/examParts/form") ) miAdd' nudge submitView csrf = do MsgRenderer mr <- getMsgRenderer (res, formWidget) <- examPartForm' nudge Nothing csrf let addRes = res <&> \newDat (Set.fromList -> oldDat) -> if | any (((==) `on` epfName) newDat) oldDat -> FormFailure [mr MsgExamPartAlreadyExists] | otherwise -> FormSuccess $ pure newDat return (addRes, $(widgetFile "widgets/massinput/examParts/add")) miCell' nudge dat = examPartForm' nudge (Just dat) miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examParts/layout") miIdent' :: Text miIdent' = "exam-parts" examFormTemplate :: Entity Exam -> DB ExamForm examFormTemplate (Entity eId Exam{..}) = do parts <- selectList [ ExamPartExam ==. eId ] [] occurrences <- selectList [ ExamOccurrenceExam ==. eId ] [] correctors <- selectList [ ExamCorrectorExam ==. eId ] [] invitations <- map (\(email, InvDBDataExamCorrector) -> email) <$> sourceInvitationsList eId parts' <- forM parts $ \(Entity pid part) -> (,) <$> encrypt pid <*> pure part occurrences' <- forM occurrences $ \(Entity oid occ) -> (,) <$> encrypt oid <*> pure occ return ExamForm { efName = examName , efGradingRule = examGradingRule , efBonusRule = examBonusRule , efOccurrenceRule = examOccurrenceRule , efVisibleFrom = examVisibleFrom , efRegisterFrom = examRegisterFrom , efRegisterTo = examRegisterTo , efDeregisterUntil = examDeregisterUntil , efPublishOccurrenceAssignments = examPublishOccurrenceAssignments , efStart = examStart , efEnd = examEnd , efFinished = examFinished , efClosed = examClosed , efShowGrades = examShowGrades , efPublicStatistics = examPublicStatistics , efDescription = examDescription , efOccurrences = Set.fromList $ do (Just -> eofId, ExamOccurrence{..}) <- occurrences' return ExamOccurrenceForm { eofId , eofRoom = examOccurrenceRoom , eofCapacity = examOccurrenceCapacity , eofStart = examOccurrenceStart , eofEnd = examOccurrenceEnd , eofDescription = examOccurrenceDescription } , efExamParts = Set.fromList $ do (Just -> epfId, ExamPart{..}) <- parts' return ExamPartForm { epfId , epfName = examPartName , epfMaxPoints = examPartMaxPoints , epfWeight = examPartWeight } , efCorrectors = Set.unions [ Set.fromList $ map Left invitations , Set.fromList . map Right $ do Entity _ ExamCorrector{..} <- correctors return examCorrectorUser ] } examTemplate :: CourseId -> DB (Maybe ExamForm) examTemplate cid = runMaybeT $ do newCourse <- MaybeT $ get cid [(Entity _ oldCourse, Entity _ oldExam)] <- lift . E.select . E.from $ \(course `E.InnerJoin` exam) -> do E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse E.where_ $ ( course E.^. CourseShorthand E.==. E.val (courseShorthand newCourse) E.||. course E.^. CourseName E.==. E.val (courseName newCourse) ) E.&&. course E.^. CourseSchool E.==. E.val (courseSchool newCourse) E.where_ . E.not_ . E.exists . E.from $ \exam' -> do E.where_ $ exam' E.^. ExamCourse E.==. E.val cid E.where_ $ exam E.^. ExamName E.==. exam' E.^. ExamName E.where_ . E.not_ . E.isNothing $ exam E.^. ExamVisibleFrom E.limit 1 E.orderBy [ E.desc $ course E.^. CourseTerm, E.asc $ exam E.^. ExamVisibleFrom ] return (course, exam) oldTerm <- MaybeT . get $ courseTerm oldCourse newTerm <- MaybeT . get $ courseTerm newCourse let dateOffset = over _utctDay . addDays $ (diffDays `on` termLectureEnd) newTerm oldTerm return ExamForm { efName = examName oldExam , efGradingRule = examGradingRule oldExam , efBonusRule = examBonusRule oldExam , efOccurrenceRule = examOccurrenceRule oldExam , efVisibleFrom = dateOffset <$> examVisibleFrom oldExam , efRegisterFrom = dateOffset <$> examRegisterFrom oldExam , efRegisterTo = dateOffset <$> examRegisterTo oldExam , efDeregisterUntil = dateOffset <$> examDeregisterUntil oldExam , efPublishOccurrenceAssignments = dateOffset $ examPublishOccurrenceAssignments oldExam , efStart = dateOffset $ examStart oldExam , efEnd = dateOffset <$> examEnd oldExam , efFinished = dateOffset <$> examFinished oldExam , efClosed = dateOffset <$> examClosed oldExam , efShowGrades = examShowGrades oldExam , efPublicStatistics = examPublicStatistics oldExam , efDescription = examDescription oldExam , efOccurrences = Set.empty , efExamParts = Set.empty , efCorrectors = Set.empty } validateExam :: (MonadHandler m, HandlerSite m ~ UniWorX) => FormValidator ExamForm m () validateExam = do ExamForm{..} <- State.get guardValidation MsgExamRegisterToMustBeAfterRegisterFrom $ NTop efRegisterTo >= NTop efRegisterFrom guardValidation MsgExamDeregisterUntilMustBeAfterRegisterFrom $ NTop efDeregisterUntil >= NTop efRegisterFrom guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments $ efStart >= efPublishOccurrenceAssignments guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop (Just efStart) guardValidation MsgExamFinishedMustBeAfterEnd . fromMaybe True $ (>=) <$> efFinished <*> efEnd guardValidation MsgExamFinishedMustBeAfterStart $ NTop efFinished >= NTop (Just efStart) guardValidation MsgExamClosedMustBeAfterFinished . fromMaybe True $ (>=) <$> efClosed <*> efFinished guardValidation MsgExamClosedMustBeAfterStart $ NTop efClosed >= NTop (Just efStart) guardValidation MsgExamClosedMustBeAfterEnd . fromMaybe True $ (>=) <$> efClosed <*> efEnd getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCExamNewR = postCExamNewR postCExamNewR tid ssh csh = do (cid, template) <- runDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh template <- examTemplate cid return (cid, template) ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm validateExam $ examForm template formResult newExamResult $ \ExamForm{..} -> do insertRes <- runDBJobs $ do insertRes <- insertUnique Exam { examName = efName , examCourse = cid , examGradingRule = efGradingRule , examBonusRule = efBonusRule , examOccurrenceRule = efOccurrenceRule , examVisibleFrom = efVisibleFrom , examRegisterFrom = efRegisterFrom , examRegisterTo = efRegisterTo , examDeregisterUntil = efDeregisterUntil , examPublishOccurrenceAssignments = efPublishOccurrenceAssignments , examStart = efStart , examEnd = efEnd , examFinished = efFinished , examClosed = efClosed , examShowGrades = efShowGrades , examPublicStatistics = efPublicStatistics , examDescription = efDescription } whenIsJust insertRes $ \examid -> do insertMany_ [ ExamPart{..} | ExamPartForm{..} <- Set.toList efExamParts , let examPartExam = examid examPartName = epfName examPartMaxPoints = epfMaxPoints examPartWeight = epfWeight ] insertMany_ [ ExamOccurrence{..} | ExamOccurrenceForm{..} <- Set.toList efOccurrences , let examOccurrenceExam = examid examOccurrenceRoom = eofRoom examOccurrenceCapacity = eofCapacity examOccurrenceStart = eofStart examOccurrenceEnd = eofEnd examOccurrenceDescription = eofDescription ] let (invites, adds) = partitionEithers $ Set.toList efCorrectors insertMany_ [ ExamCorrector{..} | examCorrectorUser <- adds , let examCorrectorExam = examid ] sinkInvitationsF examCorrectorInvitationConfig $ map (, examid, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites return insertRes case insertRes of Nothing -> addMessageI Error $ MsgExamNameTaken efName Just _ -> do addMessageI Success $ MsgExamCreated efName redirect $ CourseR tid ssh csh CExamListR let heading = prependCourseTitle tid ssh csh MsgExamNew siteLayoutMsg heading $ do setTitleI heading let newExamForm = wrapForm newExamWidget def { formMethod = POST , formAction = Just . SomeRoute $ CourseR tid ssh csh CExamNewR , formEncoding = newExamEnctype } $(widgetFile "exam-new") getEEditR, postEEditR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEEditR = postEEditR postEEditR tid ssh csh examn = do (cid, eId, template) <- runDB $ do (cid, exam@(Entity eId _)) <- fetchCourseIdExam tid ssh csh examn template <- examFormTemplate exam return (cid, eId, template) ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm validateExam . examForm $ Just template formResult editExamResult $ \ExamForm{..} -> do insertRes <- runDBJobs $ do insertRes <- myReplaceUnique eId Exam { examCourse = cid , examName = efName , examGradingRule = efGradingRule , examBonusRule = efBonusRule , examOccurrenceRule = efOccurrenceRule , examVisibleFrom = efVisibleFrom , examRegisterFrom = efRegisterFrom , examRegisterTo = efRegisterTo , examDeregisterUntil = efDeregisterUntil , examPublishOccurrenceAssignments = efPublishOccurrenceAssignments , examStart = efStart , examEnd = efEnd , examFinished = efFinished , examClosed = efClosed , examPublicStatistics = efPublicStatistics , examShowGrades = efShowGrades , examDescription = efDescription } when (is _Nothing insertRes) $ do occIds <- fmap catMaybes . forM (Set.toList efOccurrences) $ traverse decrypt . eofId deleteWhere [ ExamOccurrenceExam ==. eId, ExamOccurrenceId /<-. occIds ] forM_ (Set.toList efOccurrences) $ \case ExamOccurrenceForm{ eofId = Nothing, .. } -> insert_ ExamOccurrence { examOccurrenceExam = eId , examOccurrenceRoom = eofRoom , examOccurrenceCapacity = eofCapacity , examOccurrenceStart = eofStart , examOccurrenceEnd = eofEnd , examOccurrenceDescription = eofDescription } ExamOccurrenceForm{ .. } -> void . runMaybeT $ do cID <- hoistMaybe eofId eofId' <- decrypt cID oldOcc <- MaybeT $ get eofId' guard $ examOccurrenceExam oldOcc == eId lift $ replace eofId' ExamOccurrence { examOccurrenceExam = eId , examOccurrenceRoom = eofRoom , examOccurrenceCapacity = eofCapacity , examOccurrenceStart = eofStart , examOccurrenceEnd = eofEnd , examOccurrenceDescription = eofDescription } pIds <- fmap catMaybes . forM (Set.toList efExamParts) $ traverse decrypt . epfId deleteWhere [ ExamPartExam ==. eId, ExamPartId /<-. pIds ] forM_ (Set.toList efExamParts) $ \case ExamPartForm{ epfId = Nothing, .. } -> insert_ ExamPart { examPartExam = eId , examPartName = epfName , examPartMaxPoints = epfMaxPoints , examPartWeight = epfWeight } ExamPartForm{ .. } -> void . runMaybeT $ do cID <- hoistMaybe epfId epfId' <- decrypt cID oldPart <- MaybeT $ get epfId' guard $ examPartExam oldPart == eId lift $ replace epfId' ExamPart { examPartExam = eId , examPartName = epfName , examPartMaxPoints = epfMaxPoints , examPartWeight = epfWeight } let (invites, adds) = partitionEithers $ Set.toList efCorrectors deleteWhere [ ExamCorrectorExam ==. eId ] insertMany_ $ map (ExamCorrector eId) adds deleteWhere [ InvitationFor ==. invRef @ExamCorrector eId, InvitationEmail /<-. invites ] sinkInvitationsF examCorrectorInvitationConfig $ map (, eId, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites return insertRes case insertRes of Just _ -> addMessageI Error $ MsgExamNameTaken efName Nothing -> do addMessageI Success $ MsgExamEdited efName redirect $ CExamR tid ssh csh efName EShowR let heading = prependCourseTitle tid ssh csh . MsgExamEditHeading $ efName template siteLayoutMsg heading $ do setTitleI heading let editExamForm = wrapForm editExamWidget def { formMethod = POST , formAction = Just . SomeRoute $ CExamR tid ssh csh examn EEditR , formEncoding = editExamEnctype } $(widgetFile "exam-edit") getEShowR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEShowR tid ssh csh examn = do cTime <- liftIO getCurrentTime mUid <- maybeAuthId (Entity _ Exam{..}, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister)) <- runDB $ do exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn let examVisible = NTop (Just cTime) >= NTop examVisibleFrom let gradingVisible = NTop (Just cTime) >= NTop examFinished gradingShown <- or2M (return gradingVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR let occurrenceAssignmentsVisible = cTime >= examPublishOccurrenceAssignments occurrenceAssignmentsShown <- or2M (return occurrenceAssignmentsVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR parts <- selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ] resultsRaw <- for mUid $ \uid -> E.select . E.from $ \examPartResult -> do E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val uid E.&&. examPartResult E.^. ExamPartResultExamPart `E.in_` E.valList (map entityKey parts) return examPartResult let results = maybe Map.empty (\rs -> Map.fromList [ (examPartResultExamPart, res) | res@(Entity _ ExamPartResult{..}) <- rs ]) resultsRaw result <- fmap join . for mUid $ getBy . UniqueExamResult eId occurrencesRaw <- E.select . E.from $ \examOccurrence -> do E.where_ $ examOccurrence E.^. ExamOccurrenceExam E.==. E.val eId let registered | Just uid <- mUid = E.exists . E.from $ \examRegistration -> do E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eId E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid E.&&. examRegistration E.^. ExamRegistrationOccurrence E.==. E.just (examOccurrence E.^. ExamOccurrenceId) | otherwise = E.false E.orderBy [E.desc registered, E.asc $ examOccurrence E.^. ExamOccurrenceStart, E.asc $ examOccurrence E.^. ExamOccurrenceRoom] return (examOccurrence, registered) let occurrences = map (over _2 E.unValue) occurrencesRaw registered <- for mUid $ existsBy . UniqueExamRegistration eId mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True return (exam, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister)) let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences registerWidget | Just isRegistered <- registered , mayRegister = Just $ do (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered [whamlet|

$if isRegistered _{MsgExamRegistered} $else _{MsgExamNotRegistered} |] wrapForm examRegisterForm def { formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR , formEncoding = examRegisterEnctype , formSubmit = FormNoSubmit } | fromMaybe False registered = Just [whamlet|_{MsgExamRegistered}|] | otherwise = Nothing let heading = prependCourseTitle tid ssh csh $ CI.original examName siteLayoutMsg heading $ do setTitleI heading let gradingKeyW :: [Points] -> Widget gradingKeyW bounds = let boundWidgets :: [Widget] boundWidgets = toWidget . (pack :: String -> Text) . showFixed True <$> 0 : bounds grades :: [ExamGrade] grades = universeF in $(widgetFile "widgets/gradingKey") examBonusW :: ExamBonusRule -> Widget examBonusW bonusRule = $(widgetFile "widgets/bonusRule") $(widgetFile "exam-show") type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)))) type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms)) instance HasEntity ExamUserTableData User where hasEntity = _dbrOutput . _2 instance HasUser ExamUserTableData where hasUser = _dbrOutput . _2 . _entityVal _userTableOccurrence :: Lens' ExamUserTableData (Maybe (Entity ExamOccurrence)) _userTableOccurrence = _dbrOutput . _3 queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User) queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures)) queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3) queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration) queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree)) queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3) queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms)) queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3) resultStudyFeatures :: Traversal' ExamUserTableData (Entity StudyFeatures) resultStudyFeatures = _dbrOutput . _4 . _Just resultStudyDegree :: Traversal' ExamUserTableData (Entity StudyDegree) resultStudyDegree = _dbrOutput . _5 . _Just resultStudyField :: Traversal' ExamUserTableData (Entity StudyTerms) resultStudyField = _dbrOutput . _6 . _Just getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEUsersR = postEUsersR postEUsersR tid ssh csh examn = do Entity eid Exam{..} <- runDB $ fetchExam tid ssh csh examn let examUsersDBTable = DBTable{..} where dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField))) = do E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField) E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse) E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId) E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid) E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField) dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId) dbtProj = return dbtColonnade = dbColonnade $ mconcat [ colUserNameLink (CourseR tid ssh csh . CUserR) , colUserMatriclenr , colField resultStudyField , colDegreeShort resultStudyDegree , colFeaturesSemester resultStudyFeatures , sortable (Just "room") (i18nCell MsgExamRoom) (maybe mempty (cell . toWgt . examOccurrenceRoom . entityVal) . view _userTableOccurrence) ] dbtSorting = Map.fromList [ sortUserNameLink queryUser , sortUserSurname queryUser , sortUserDisplayName queryUser , sortUserMatriclenr queryUser , sortField queryStudyField , sortDegreeShort queryStudyDegree , sortFeaturesSemester queryStudyFeatures ] dbtFilter = Map.fromList [ fltrUserNameEmail queryUser , fltrUserMatriclenr queryUser , fltrField queryStudyField , fltrDegree queryStudyDegree , fltrFeaturesSemester queryStudyFeatures ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailUI mPrev , fltrUserMatriclenrUI mPrev , fltrFieldUI mPrev , fltrDegreeUI mPrev , fltrFeaturesSemesterUI mPrev ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def dbtIdent :: Text dbtIdent = "exam-users" examUsersDBTableValidator = def ((), examUsersTable) <- runDB $ dbTable examUsersDBTableValidator examUsersDBTable siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading $(widgetFile "exam-users") getEAddUserR, postEAddUserR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEAddUserR = postEAddUserR postEAddUserR = error "postEAddUserR" getEInviteR, postEInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEInviteR = postEInviteR postEInviteR = error "postEInviteR" postERegisterR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html postERegisterR tid ssh csh examn = do Entity uid User{..} <- requireAuth Entity eId Exam{..} <- runDB $ fetchExam tid ssh csh examn ((btnResult, _), _) <- runFormPost buttonForm formResult btnResult $ \case BtnRegister -> do runDB $ do now <- liftIO getCurrentTime insert_ $ ExamRegistration eId uid Nothing now audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent addMessageI Success $ MsgExamRegisteredSuccess examn redirect $ CExamR tid ssh csh examn EShowR BtnDeregister -> do runDB $ do deleteBy $ UniqueExamRegistration eId uid audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent addMessageI Success $ MsgExamDeregisteredSuccess examn redirect $ CExamR tid ssh csh examn EShowR invalidArgs ["Register/Deregister button required"]