506 lines
23 KiB
Haskell
506 lines
23 KiB
Haskell
{-# 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
|
|
<span ##{toPathPiece cID}>
|
|
|]
|
|
|
|
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")
|