{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module Handler.ExamOffice.Exam ( getEGradesR, postEGradesR , examCloseWidget, examFinishWidget ) where import Import import Handler.Utils import Handler.Utils.Exam import Handler.Utils.Csv import qualified Handler.Utils.ExamOffice.Exam as Exam import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.Csv as Csv import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Conduit.List as C import qualified Colonnade import Handler.Utils.StudyFeatures data ButtonCloseExam = BtnCloseExam deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) instance Universe ButtonCloseExam instance Finite ButtonCloseExam nullaryPathPiece ''ButtonCloseExam $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''ButtonCloseExam id instance Button UniWorX ButtonCloseExam where btnClasses BtnCloseExam = [BCIsButton] examCloseWidget :: SomeRoute UniWorX -> ExamId -> Handler Widget examCloseWidget dest eId = do (Exam{..}, School{..}) <- runDB $ do exam@Exam{..} <- get404 eId Course{..} <- get404 examCourse school <- get404 courseSchool return (exam, school) let closeTime = case (examClosed, examFinished) of (mClose, Just finish) | isn't _ExamCloseSeparate schoolExamCloseMode -> Just $ maybe id min mClose finish (Just close, _) | is _ExamCloseSeparate schoolExamCloseMode -> Just close _other -> Nothing examClosedStr <- for closeTime $ formatTime SelFormatDateTime if | is _ExamCloseOnFinished' schoolExamCloseMode -> return $(widgetFile "widgets/exam-close-on-finished") | otherwise -> do ((closeRes, closeView'), closeEnc) <- runFormPost $ identifyForm BtnCloseExam buttonForm formResult closeRes $ \case BtnCloseExam -> do now <- liftIO getCurrentTime unless (is _Nothing examClosed) $ invalidArgs ["Exam is already closed"] runDB $ update eId [ ExamClosed =. Just now ] addMessageI Success MsgExamDidClose redirect dest let closeView = wrapForm closeView' def { formSubmit = FormNoSubmit , formAction = Just dest , formEncoding = closeEnc } return $(widgetFile "widgets/exam-close") data ButtonFinishExam = BtnFinishExam deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) instance Universe ButtonFinishExam instance Finite ButtonFinishExam nullaryPathPiece ''ButtonFinishExam $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''ButtonFinishExam id instance Button UniWorX ButtonFinishExam where btnClasses BtnFinishExam = [BCIsButton] examFinishWidget :: SomeRoute UniWorX -> ExamId -> Handler Widget examFinishWidget dest eId = do Exam{examFinished} <- runDB $ get404 eId examFinishedStr <- for examFinished $ formatTime SelFormatDateTime ((finishRes, finishView'), finishEnc) <- runFormPost $ identifyForm BtnFinishExam buttonForm formResult finishRes $ \case BtnFinishExam -> do now <- liftIO getCurrentTime unless (is _Nothing examFinished) $ invalidArgs ["Exam is already finished"] runDB $ update eId [ ExamFinished =. Just now ] addMessageI Success MsgExamDidFinish redirect dest let finishView = wrapForm finishView' def { formSubmit = FormNoSubmit , formAction = Just dest , formEncoding = finishEnc } return $(widgetFile "widgets/exam-finish") type ExamUserTableExpr = ( E.SqlExpr (Entity ExamResult) `E.InnerJoin` E.SqlExpr (Entity User) ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamRegistration)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseParticipant)) type ExamUserTableData = DBRow ( Entity ExamResult , Entity User , Maybe (Entity ExamOccurrence) , Maybe (Entity ExamRegistration) , Bool , [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)] , UserTableStudyFeatures ) queryExamRegistration :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity ExamRegistration))) queryExamRegistration = to $(E.sqlLOJproj 4 2) queryUser :: Getter ExamUserTableExpr (E.SqlExpr (Entity User)) queryUser = to $ $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 4 1) queryExamOccurrence :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity ExamOccurrence))) queryExamOccurrence = to $(E.sqlLOJproj 4 3) queryCourseParticipant :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity CourseParticipant))) queryCourseParticipant = to $(E.sqlLOJproj 4 4) queryExamResult :: Getter ExamUserTableExpr (E.SqlExpr (Entity ExamResult)) queryExamResult = to $ $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 4 1) -- resultExamRegistration :: Traversal' ExamUserTableData (Entity ExamRegistration) -- resultExamRegistration = _dbrOutput . _7 . _Just queryIsSynced :: E.SqlExpr (E.Value UserId) -> Getter ExamUserTableExpr (E.SqlExpr (E.Value Bool)) queryIsSynced authId = to $ Exam.resultIsSynced authId <$> view queryExamResult resultUser :: Lens' ExamUserTableData (Entity User) resultUser = _dbrOutput . _2 resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence) resultExamOccurrence = _dbrOutput . _3 . _Just resultExamResult :: Lens' ExamUserTableData (Entity ExamResult) resultExamResult = _dbrOutput . _1 resultIsSynced :: Lens' ExamUserTableData Bool resultIsSynced = _dbrOutput . _5 resultSynchronised :: Traversal' ExamUserTableData (UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand) resultSynchronised = _dbrOutput . _6 . traverse resultStudyFeatures :: Lens' ExamUserTableData UserTableStudyFeatures resultStudyFeatures = _dbrOutput . _7 data ExamUserTableCsv = ExamUserTableCsv { csvEUserSurname :: Text , csvEUserFirstName :: Text , csvEUserName :: Text , csvEUserMatriculation :: Maybe Text , csvEUserStudyFeatures :: UserTableStudyFeatures , csvEUserOccurrenceStart :: Maybe ZonedTime , csvEUserExamResult :: ExamResultPassedGrade } deriving (Generic) makeLenses_ ''ExamUserTableCsv examUserTableCsvOptions :: Csv.Options examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3 } instance ToNamedRecord ExamUserTableCsv where toNamedRecord = Csv.genericToNamedRecord examUserTableCsvOptions instance DefaultOrdered ExamUserTableCsv where headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions instance CsvColumnsExplained ExamUserTableCsv where csvColumnsExplanations = genericCsvColumnsExplanations examUserTableCsvOptions $ Map.fromList [ ('csvEUserSurname , MsgCsvColumnExamUserSurnameExamOffice ) , ('csvEUserFirstName , MsgCsvColumnExamUserFirstNameExamOffice ) , ('csvEUserName , MsgCsvColumnExamUserNameExamOffice ) , ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculationExamOffice ) , ('csvEUserStudyFeatures , MsgCsvColumnUserStudyFeaturesExamOffice ) , ('csvEUserOccurrenceStart , MsgCsvColumnExamOfficeExamUserOccurrenceStartExamOffice ) , ('csvEUserExamResult , MsgCsvColumnExamUserResultExamOffice ) ] data ExamUserAction = ExamUserMarkSynchronised deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) instance Universe ExamUserAction instance Finite ExamUserAction nullaryPathPiece ''ExamUserAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''ExamUserAction id data ExamUserActionData = ExamUserMarkSynchronisedData data ExamUserCsvExportData = ExamUserCsvExportData { csvEUserMarkSynchronised :: Bool , csvEUserSetLabel :: Bool } deriving (Eq, Ord, Read, Show, Generic, Typeable) -- | View a list of all users' grades that the current user has access to getEGradesR, postEGradesR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEGradesR = postEGradesR postEGradesR tid ssh csh examn = do Entity uid User{userCsvOptions=csvOpts} <- requireAuth now <- liftIO getCurrentTime ((usersResult, examUsersTable), Entity eId Exam{examFinished}) <- runDB $ do exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn Course{..} <- getJust examCourse isLecturer <- hasReadAccessTo $ CExamR tid ssh csh examn EUsersR isExamOffice <- hasReadAccessTo $ ExamOfficeR EOExamsR userFunctions <- selectList [ UserFunctionUser ==. uid, UserFunctionFunction ==. SchoolExamOffice ] [] userCsvExportLabel' <- E.select . E.from $ \examOfficeLabel -> do E.where_ $ maybe E.false (\expLbl -> examOfficeLabel E.^. ExamOfficeLabelName E.==. E.val expLbl) (csvExportLabel csvOpts) E.&&. examOfficeLabel E.^. ExamOfficeLabelUser E.==. E.val uid return examOfficeLabel let userCsvExportLabel = listToMaybe userCsvExportLabel' let participantLink :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (SomeRoute UniWorX) participantLink partId = liftHandler $ do cID <- encrypt partId return . SomeRoute . CourseR tid ssh csh $ CUserR cID participantAnchor :: ExamUserTableData -> DBCell _ _ -> DBCell _ _ participantAnchor x = cellContents . mapped <>~ partAnchor where partAnchor :: Widget partAnchor = do let partId = x ^. resultUser . _entityKey cID <- encrypt partId :: WidgetFor UniWorX CryptoUUIDUser [whamlet| $newline never |] markSynced :: ExamResultId -> DB () markSynced resId | null userFunctions = insert_ ExamOfficeResultSynced { examOfficeResultSyncedOffice = uid , examOfficeResultSyncedResult = resId , examOfficeResultSyncedTime = now , examOfficeResultSyncedSchool = Nothing } | otherwise = insertMany_ [ ExamOfficeResultSynced { examOfficeResultSyncedOffice = uid , examOfficeResultSyncedResult = resId , examOfficeResultSyncedTime = now , examOfficeResultSyncedSchool = Just userFunctionSchool } | Entity _ UserFunction{..} <- userFunctions ] examUsersDBTable = DBTable{..} where dbtSQLQuery = runReaderT $ do examResult <- view queryExamResult user <- view queryUser examRegistration <- view queryExamRegistration occurrence <- view queryExamOccurrence courseParticipant <- view queryCourseParticipant isSynced <- view . queryIsSynced $ E.val uid lift $ do E.on $ E.maybe E.true (\cCourse -> cCourse E.==. E.val examCourse ) (courseParticipant E.?. CourseParticipantCourse) E.&&. E.maybe E.true (\cUser -> cUser E.==. user E.^. UserId ) (courseParticipant E.?. CourseParticipantUser) E.&&. E.maybe E.true (\cState -> cState E.==. E.val CourseParticipantActive ) (courseParticipant E.?. CourseParticipantState) E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid) E.&&. occurrence E.?. ExamOccurrenceId E.==. E.joinV (examRegistration E.?. ExamRegistrationOccurrence) E.on $ examRegistration E.?. ExamRegistrationUser E.==. E.just (user E.^. UserId) E.&&. examRegistration E.?. ExamRegistrationExam E.==. E.just (E.val eid) E.on $ examResult E.^. ExamResultUser E.==. user E.^. UserId E.&&. examResult E.^. ExamResultExam E.==. E.val eid E.where_ $ examResult E.^. ExamResultExam E.==. E.val eid unless isLecturer $ E.where_ $ Exam.examOfficeExamResultAuth (E.val uid) examResult return (examResult, user, occurrence, examRegistration, isSynced) dbtRowKey = views queryExamResult (E.^. ExamResultId) dbtProj :: _ ExamUserTableData dbtProj = dbtProjSimple . runReaderT $ (,,,,,,) <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view (_5 . _Value) <*> getSynchronised <*> (lift . courseUserStudyFeatures examCourse =<< view (_2 . _entityKey)) where getSynchronised :: ReaderT _ DB [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)] getSynchronised = do resId <- view $ _1 . _entityKey syncs <- lift . E.select . E.from $ \(examOfficeResultSynced `E.InnerJoin` user) -> do E.on $ examOfficeResultSynced E.^. ExamOfficeResultSyncedOffice E.==. user E.^. UserId E.where_ $ examOfficeResultSynced E.^. ExamOfficeResultSyncedResult E.==. E.val resId return ( examOfficeResultSynced E.^. ExamOfficeResultSyncedOffice , ( user E.^. UserDisplayName , user E.^. UserSurname , examOfficeResultSynced E.^. ExamOfficeResultSyncedTime , examOfficeResultSynced E.^. ExamOfficeResultSyncedSchool ) ) let syncs' = Map.fromListWith (\(dn, sn, t, sshs) (_, _, _, sshs') -> (dn, sn, t, Set.union sshs sshs')) [ ((officeId, t), (dn, sn, t, maybe Set.empty Set.singleton ssh')) | (E.Value officeId, (E.Value dn, E.Value sn, E.Value t, fmap unSchoolKey . E.unValue -> ssh')) <- syncs ] return $ Map.elems syncs' colSynced = Colonnade.singleton (fromSortable . Sortable (Just "is-synced") $ i18nCell MsgExamUserSynchronised) $ \x -> cell . flip runReaderT x $ do syncs <- asks $ sortOn (Down . view _3) . toListOf resultSynchronised lastChange <- view $ resultExamResult . _entityVal . _examResultLastChanged User{..} <- view $ resultUser . _entityVal isSynced <- view resultIsSynced let hasSyncs = has folded syncs syncs' = [ Right sync | sync@(_, _, t, _) <- syncs, t > lastChange] ++ [ Left lastChange ] ++ [ Right sync | sync@(_, _, t, _) <- syncs, t <= lastChange] syncIcon :: Widget syncIcon | not isSynced , not hasSyncs = mempty | not isSynced = toWidget iconNotOK | otherwise = toWidget iconOK syncsModal :: Widget syncsModal = $(widgetFile "exam-office/exam-result-synced") lift $ bool id (flip modal $ Right syncsModal) hasSyncs syncIcon dbtColonnade :: Colonnade Sortable _ _ dbtColonnade = mconcat [ dbSelect (applying _2) id $ return . view (resultExamResult . _entityKey) , colSynced , imapColonnade participantAnchor . anchorColonnadeM (views (resultUser . _entityKey) participantLink) $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname) , colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer) , colStudyFeatures resultStudyFeatures , Colonnade.singleton (fromSortable . Sortable (Just "occurrence-start") $ i18nCell MsgTableExamTime) $ \x -> cell . flip runReaderT x $ do start <- preview $ resultExamOccurrence . _entityVal . _examOccurrenceStart <> like examStart . _Just end <- preview $ resultExamOccurrence . _entityVal . _examOccurrenceEnd . _Just <> like examEnd . _Just lift $ maybe mempty (flip (formatTimeRangeW SelFormatDateTime) end) start , colExamResult (resultExamResult . _entityVal . _examResultResult) ] dbtSorting = mconcat [ sortUserName' (queryUser . to ((,) <$> (E.^. UserDisplayName) <*> (E.^. UserSurname))) , sortUserMatriculation (queryUser . to (E.^. UserMatrikelnummer)) , sortOccurrenceStart (queryExamOccurrence . to (E.maybe (E.val examStart) E.just . (E.?. ExamOccurrenceStart))) , maybeOpticSortColumn sortExamResult (queryExamResult . to (E.^. ExamResultResult)) , singletonMap "is-synced" . SortColumn $ view (queryIsSynced $ E.val uid) ] dbtFilter = mconcat [ fltrUserName' (queryUser . to (E.^. UserDisplayName)) , fltrUserMatriculation (queryUser . to (E.^. UserMatrikelnummer)) , fltrExamResultPoints (queryExamResult . to (E.^. ExamResultResult) . to E.just) , singletonMap "is-synced" . FilterColumn $ E.mkExactFilter (view . queryIsSynced $ E.val uid) , fltrRelevantStudyFeaturesTerms (to $ \t -> ( E.val courseTerm , views queryUser (E.^. UserId) t )) , fltrRelevantStudyFeaturesDegree (to $ \t -> ( E.val courseTerm , views queryUser (E.^. UserId) t )) , fltrRelevantStudyFeaturesSemester (to $ \t -> ( E.val courseTerm , views queryUser (E.^. UserId) t )) ] dbtFilterUI = mconcat [ fltrUserNameUI' , fltrUserMatriculationUI , fltrExamResultPointsUI , \mPrev -> prismAForm (singletonFilter "is-synced" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgExamUserSynchronised) , fltrRelevantStudyFeaturesTermsUI , fltrRelevantStudyFeaturesDegreeUI , fltrRelevantStudyFeaturesSemesterUI ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Just . SomeRoute $ CExamR tid ssh csh examn EGradesR , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional = \csrf -> do let actionMap :: Map ExamUserAction (AForm Handler ExamUserActionData) actionMap = Map.fromList [ ( ExamUserMarkSynchronised , pure ExamUserMarkSynchronisedData ) ] (res, formWgt) <- multiActionM actionMap (fslI MsgTableAction) Nothing csrf let formRes = (, mempty) . First . Just <$> res return (formRes, formWgt) , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def } dbtIdent :: Text dbtIdent = "exam-results" dbtCsvName = MsgExamUserCsvName tid ssh csh examn dbtCsvSheetName = MsgExamUserCsvSheetName tid ssh csh examn dbtCsvEncode = Just DBTCsvEncode { dbtCsvExportForm = ExamUserCsvExportData <$> apopt checkBoxField (fslI MsgExamOfficeExamUserMarkSynchronisedCsv & setTooltip MsgExamOfficeExamUserMarkSynchronisedCsvTip) (Just False) <*> bool ( pure False ) ( maybe (aforced checkBoxField (fslI MsgExamOfficeLabelSetLabelOnExport & setTooltip MsgExamOfficeLabelSetLabelOnExportForcedTip) False) (\expLbl -> apopt checkBoxField (fslI MsgExamOfficeLabelSetLabelOnExport & setTooltip (MsgExamOfficeLabelSetLabelOnExportTip expLbl)) (Just True)) (examOfficeLabelName . entityVal <$> userCsvExportLabel) ) isExamOffice , dbtCsvDoEncode = \ExamUserCsvExportData{..} -> C.mapM $ \(E.Value k, row) -> do when csvEUserMarkSynchronised $ markSynced k when csvEUserSetLabel $ maybe (return ()) (\lbl -> void $ upsert (ExamOfficeExamLabel eid lbl) [ExamOfficeExamLabelLabel =. lbl]) (entityKey <$> userCsvExportLabel) return $ ExamUserTableCsv (row ^. resultUser . _entityVal . _userSurname) (row ^. resultUser . _entityVal . _userFirstName) (row ^. resultUser . _entityVal . _userDisplayName) (row ^. resultUser . _entityVal . _userMatrikelnummer) (row ^. resultStudyFeatures) (row ^? (resultExamOccurrence . _entityVal . _examOccurrenceStart <> like examStart . _Just) . to utcToZonedTime) (row ^. resultExamResult . _entityVal . _examResultResult) , dbtCsvName, dbtCsvSheetName , dbtCsvNoExportData = Nothing , dbtCsvHeader = const . return $ Csv.headerOrder (error "headerOrder" :: ExamUserTableCsv) , dbtCsvExampleData = Nothing } dbtCsvDecode = Nothing dbtExtraReps = [] examUsersDBTableValidator = def & defaultSorting [SortAscBy "is-synced", SortAscBy "user-name"] & defaultPagesize PagesizeAll postprocess :: FormResult (First ExamUserActionData, DBFormResult ExamResultId Bool ExamUserTableData) -> FormResult (ExamUserActionData, Set ExamResultId) postprocess inp = do (First (Just act), regMap) <- inp let regSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) regMap return (act, regSet) (usersResult, examUsersTable) <- over _1 postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable usersResult' <- formResultMaybe usersResult $ \case (ExamUserMarkSynchronisedData, selectedResults) -> do forM_ selectedResults markSynced return . Just $ do addMessageI Success $ MsgExamUserMarkedSynchronised (length selectedResults) redirect $ CExamR tid ssh csh examn EGradesR return ((usersResult', examUsersTable), exam) whenIsJust usersResult join closeWgt <- examCloseWidget (SomeRoute $ CExamR tid ssh csh examn EGradesR) eId finishWgt <- examFinishWidget (SomeRoute $ CExamR tid ssh csh examn EGradesR) eId hasUsers <- hasReadAccessTo $ CExamR tid ssh csh examn EUsersR siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamOfficeExamUsersHeading) $ do setTitleI $ prependCourseTitle tid ssh csh MsgExamOfficeExamUsersHeading let examGradesExplanation = notificationWidget NotificationBroad Info $(i18nWidgetFile "exam-office/exam-grades-explanation") $(widgetFile "exam-office/exam-results")