444 lines
21 KiB
Haskell
444 lines
21 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
|
|
|
module Handler.ExamOffice.Exam
|
|
( getEGradesR, postEGradesR
|
|
, examCloseWidget
|
|
) 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 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
|
|
|
|
|
|
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{..} <- runDB $ get404 eId
|
|
|
|
((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
|
|
}
|
|
|
|
examClosed' <- for examClosed $ formatTime SelFormatDateTime
|
|
|
|
return $(widgetFile "widgets/exam-close")
|
|
|
|
|
|
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))
|
|
`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 ExamResult
|
|
, Entity User
|
|
, Maybe (Entity ExamOccurrence)
|
|
, Maybe (Entity StudyFeatures)
|
|
, Maybe (Entity StudyDegree)
|
|
, Maybe (Entity StudyTerms)
|
|
, Maybe (Entity ExamRegistration)
|
|
, Bool
|
|
, [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
|
|
)
|
|
|
|
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 2 1) . $(E.sqlLOJproj 4 4)
|
|
|
|
queryStudyFeatures :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity StudyFeatures)))
|
|
queryStudyFeatures = to $ $(E.sqlIJproj 3 1) . $(E.sqlLOJproj 2 2) . $(E.sqlLOJproj 4 4)
|
|
|
|
queryStudyDegree :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity StudyDegree)))
|
|
queryStudyDegree = to $ $(E.sqlIJproj 3 2) . $(E.sqlLOJproj 2 2) . $(E.sqlLOJproj 4 4)
|
|
|
|
queryStudyField :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity StudyTerms)))
|
|
queryStudyField = to $ $(E.sqlIJproj 3 3) . $(E.sqlLOJproj 2 2) . $(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
|
|
|
|
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
|
|
|
|
resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence)
|
|
resultExamOccurrence = _dbrOutput . _3 . _Just
|
|
|
|
resultExamResult :: Lens' ExamUserTableData (Entity ExamResult)
|
|
resultExamResult = _dbrOutput . _1
|
|
|
|
resultIsSynced :: Lens' ExamUserTableData Bool
|
|
resultIsSynced = _dbrOutput . _8
|
|
|
|
resultSynchronised :: Traversal' ExamUserTableData (UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)
|
|
resultSynchronised = _dbrOutput . _9 . traverse
|
|
|
|
data ExamUserTableCsv = ExamUserTableCsv
|
|
{ csvEUserSurname :: Text
|
|
, csvEUserFirstName :: Text
|
|
, csvEUserName :: Text
|
|
, csvEUserMatriculation :: Maybe Text
|
|
, csvEUserField :: Maybe Text
|
|
, csvEUserDegree :: Maybe Text
|
|
, csvEUserSemester :: Maybe Int
|
|
, 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 , MsgCsvColumnExamUserSurname )
|
|
, ('csvEUserFirstName , MsgCsvColumnExamUserFirstName )
|
|
, ('csvEUserName , MsgCsvColumnExamUserName )
|
|
, ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculation )
|
|
, ('csvEUserField , MsgCsvColumnExamUserField )
|
|
, ('csvEUserDegree , MsgCsvColumnExamUserDegree )
|
|
, ('csvEUserSemester , MsgCsvColumnExamUserSemester )
|
|
, ('csvEUserOccurrenceStart , MsgCsvColumnExamOfficeExamUserOccurrenceStart )
|
|
, ('csvEUserExamResult , MsgCsvColumnExamUserResult )
|
|
]
|
|
|
|
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
|
|
|
|
newtype ExamUserCsvExportData = ExamUserCsvExportData
|
|
{ csvEUserMarkSynchronised :: 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
|
|
uid <- requireAuthId
|
|
now <- liftIO getCurrentTime
|
|
((usersResult, examUsersTable), Entity eId _) <- runDB $ do
|
|
exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn
|
|
|
|
csvName <- getMessageRender <*> pure (MsgExamUserCsvName tid ssh csh examn)
|
|
isLecturer <- hasReadAccessTo $ CExamR tid ssh csh examn EUsersR
|
|
userFunctions <- selectList [ UserFunctionUser ==. uid, UserFunctionFunction ==. SchoolExamOffice ] []
|
|
|
|
let
|
|
participantLink :: MonadCrypto m => UserId -> m (SomeRoute UniWorX)
|
|
participantLink partId = 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
|
|
studyFeatures <- view queryStudyFeatures
|
|
studyDegree <- view queryStudyDegree
|
|
studyField <- view queryStudyField
|
|
|
|
isSynced <- view . queryIsSynced $ E.val uid
|
|
|
|
lift $ 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.==. 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, studyFeatures, studyDegree, studyField, examRegistration, isSynced)
|
|
dbtRowKey = views queryExamResult (E.^. ExamResultId)
|
|
|
|
dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) ExamUserTableData
|
|
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
|
|
(,,,,,,,,)
|
|
<$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5 <*> view _6 <*> view _7 <*> view (_8 . _Value)
|
|
<*> getSynchronised
|
|
where
|
|
getSynchronised :: ReaderT _ (MaybeT (YesodDB UniWorX)) [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
|
|
getSynchronised = do
|
|
resId <- view $ _1 . _entityKey
|
|
syncs <- lift . 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)
|
|
, emptyOpticColonnade (resultStudyField . _entityVal) colStudyTerms
|
|
, emptyOpticColonnade (resultStudyDegree . _entityVal) colStudyDegree
|
|
, emptyOpticColonnade (resultStudyFeatures . _entityVal . _studyFeaturesSemester) colStudyFeaturesSemester
|
|
, Colonnade.singleton (fromSortable . Sortable (Just "occurrence-start") $ i18nCell MsgExamTime) $ \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 examShowGrades (resultExamResult . _entityVal . _examResultResult)
|
|
]
|
|
dbtSorting = mconcat
|
|
[ sortUserName' (queryUser . to ((,) <$> (E.^. UserDisplayName) <*> (E.^. UserSurname)))
|
|
, sortUserMatriculation (queryUser . to (E.^. UserMatrikelnummer))
|
|
, sortStudyTerms queryStudyField
|
|
, sortStudyDegree queryStudyDegree
|
|
, sortStudyFeaturesSemester (queryStudyFeatures . to (E.?. StudyFeaturesSemester))
|
|
, sortOccurrenceStart (queryExamOccurrence . to (E.maybe (E.val examStart) E.just . (E.?. ExamOccurrenceStart)))
|
|
, maybeOpticSortColumn (sortExamResult examShowGrades) (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))
|
|
, fltrStudyTerms queryStudyField
|
|
, fltrStudyDegree queryStudyDegree
|
|
, fltrStudyFeaturesSemester (queryStudyFeatures . to (E.?. StudyFeaturesSemester))
|
|
, fltrExamResultPoints examShowGrades (queryExamResult . to (E.^. ExamResultResult))
|
|
, singletonMap "is-synced" . FilterColumn $ E.mkExactFilter (view . queryIsSynced $ E.val uid)
|
|
]
|
|
dbtFilterUI = mconcat
|
|
[ fltrUserNameUI'
|
|
, fltrUserMatriculationUI
|
|
, fltrStudyTermsUI
|
|
, fltrStudyDegreeUI
|
|
, fltrStudyFeaturesSemesterUI
|
|
, fltrExamResultPointsUI examShowGrades
|
|
, \mPrev -> prismAForm (singletonFilter "is-synced" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgExamUserSynchronised)
|
|
]
|
|
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 MsgAction) Nothing csrf
|
|
let formRes = (, mempty) . First . Just <$> res
|
|
return (formRes, formWgt)
|
|
, dbParamsFormEvaluate = liftHandler . runFormPost
|
|
, dbParamsFormResult = id
|
|
, dbParamsFormIdent = def
|
|
}
|
|
dbtIdent :: Text
|
|
dbtIdent = "exam-results"
|
|
dbtCsvEncode = Just DBTCsvEncode
|
|
{ dbtCsvExportForm = ExamUserCsvExportData
|
|
<$> apopt checkBoxField (fslI MsgExamUserMarkSynchronisedCsv) (Just True)
|
|
, dbtCsvDoEncode = \ExamUserCsvExportData{..} -> C.mapM $ \(E.Value k, row) -> do
|
|
when csvEUserMarkSynchronised $ markSynced k
|
|
return $ ExamUserTableCsv
|
|
(row ^. resultUser . _entityVal . _userSurname)
|
|
(row ^. resultUser . _entityVal . _userFirstName)
|
|
(row ^. resultUser . _entityVal . _userDisplayName)
|
|
(row ^. resultUser . _entityVal . _userMatrikelnummer)
|
|
(row ^? resultStudyField . _entityVal . to (\StudyTerms{..} -> fromMaybe (tshow studyTermsKey) $ studyTermsName <|> studyTermsShorthand))
|
|
(row ^? resultStudyDegree . _entityVal . to (\StudyDegree{..} -> fromMaybe (tshow studyDegreeKey) $ studyDegreeName <|> studyDegreeShorthand))
|
|
(row ^? resultStudyFeatures . _entityVal . _studyFeaturesSemester)
|
|
(row ^? (resultExamOccurrence . _entityVal . _examOccurrenceStart <> like examStart . _Just) . to utcToZonedTime)
|
|
(row ^. resultExamResult . _entityVal . _examResultResult . to (fmap $ bool (Left . view passingGrade) Right examShowGrades))
|
|
, dbtCsvName = unpack csvName
|
|
, dbtCsvNoExportData = Nothing
|
|
, dbtCsvHeader = const . return $ Csv.headerOrder (error "headerOrder" :: ExamUserTableCsv)
|
|
}
|
|
dbtCsvDecode = Nothing
|
|
|
|
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
|
|
|
|
siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamOfficeExamUsersHeading) $ do
|
|
setTitleI $ prependCourseTitle tid ssh csh MsgExamOfficeExamUsersHeading
|
|
$(widgetFile "exam-office/exam-results")
|