427 lines
22 KiB
Haskell
427 lines
22 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
||
|
||
module Handler.ExamOffice.Exams
|
||
( getEOExamsR, postEOExamsR
|
||
) where
|
||
|
||
import Import
|
||
|
||
import Handler.Utils
|
||
import qualified Handler.Utils.ExamOffice.Exam as Exam
|
||
import qualified Handler.Utils.ExamOffice.ExternalExam as ExternalExam
|
||
|
||
import qualified Database.Esqueleto.Legacy as E
|
||
import qualified Database.Esqueleto.Utils as E
|
||
|
||
import qualified Colonnade
|
||
|
||
import qualified Data.Conduit.Combinators as C
|
||
import qualified Data.Map as Map
|
||
import qualified Data.Set as Set
|
||
|
||
|
||
data ExamAction = ExamSetLabel | ExamRemoveLabel
|
||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||
deriving anyclass (Universe, Finite)
|
||
|
||
nullaryPathPiece ''ExamAction $ camelToPathPiece' 1
|
||
embedRenderMessage ''UniWorX ''ExamAction id
|
||
|
||
data ExamActionData = ExamSetLabelData
|
||
{ easlNewLabel :: ExamOfficeLabelId
|
||
}
|
||
| ExamRemoveLabelData
|
||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||
|
||
|
||
data ExamsTableFilterProj = ExamsTableFilterProj
|
||
{ etProjFilterMayAccess :: Maybe Bool
|
||
, etProjFilterHasResults :: Maybe Bool
|
||
, etProjFilterLabel :: Maybe (Either ExamOfficeExternalExamLabelId ExamOfficeExamLabelId)
|
||
, etProjFilterIsSynced :: Maybe Bool
|
||
}
|
||
|
||
instance Default ExamsTableFilterProj where
|
||
def = ExamsTableFilterProj
|
||
{ etProjFilterMayAccess = Nothing
|
||
, etProjFilterHasResults = Nothing
|
||
, etProjFilterLabel = Nothing
|
||
, etProjFilterIsSynced = Nothing
|
||
}
|
||
|
||
makeLenses_ ''ExamsTableFilterProj
|
||
|
||
|
||
type ExamsTableExpr = ( ( E.SqlExpr (Maybe (Entity Exam ))
|
||
`E.InnerJoin` E.SqlExpr (Maybe (Entity Course))
|
||
`E.InnerJoin` E.SqlExpr (Maybe (Entity School))
|
||
)
|
||
`E.LeftOuterJoin`
|
||
( E.SqlExpr (Maybe (Entity ExamOfficeExamLabel))
|
||
`E.InnerJoin` E.SqlExpr (Maybe (Entity ExamOfficeLabel))
|
||
)
|
||
)
|
||
`E.FullOuterJoin` ( E.SqlExpr (Maybe (Entity ExternalExam))
|
||
`E.LeftOuterJoin`
|
||
( E.SqlExpr (Maybe (Entity ExamOfficeExternalExamLabel))
|
||
`E.InnerJoin` E.SqlExpr (Maybe (Entity ExamOfficeLabel))
|
||
)
|
||
)
|
||
|
||
type ExamsTableData = DBRow ( Either
|
||
( Entity ExternalExam
|
||
, Maybe (Entity ExamOfficeLabel)
|
||
)
|
||
( Entity Exam
|
||
, Entity Course
|
||
, Entity School
|
||
, Maybe (Entity ExamOfficeLabel)
|
||
)
|
||
, Maybe Natural
|
||
, Maybe Natural
|
||
)
|
||
|
||
queryExam :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity Exam)))
|
||
queryExam = to $ $(E.sqlIJproj 3 1) . $(E.sqlLOJproj 2 1) . $(E.sqlFOJproj 2 1)
|
||
|
||
queryCourse :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity Course)))
|
||
queryCourse = to $ $(E.sqlIJproj 3 2) . $(E.sqlLOJproj 2 1) . $(E.sqlFOJproj 2 1)
|
||
|
||
querySchool :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity School)))
|
||
querySchool = to $ $(E.sqlIJproj 3 3) . $(E.sqlLOJproj 2 1) . $(E.sqlFOJproj 2 1)
|
||
|
||
queryExamLabel :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity ExamOfficeExamLabel)))
|
||
queryExamLabel = to $ $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 2 2) . $(E.sqlFOJproj 2 1)
|
||
|
||
queryLabelExam :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity ExamOfficeLabel)))
|
||
queryLabelExam = to $ $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 2 2) . $(E.sqlFOJproj 2 1)
|
||
|
||
queryExternalExam :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity ExternalExam)))
|
||
queryExternalExam = to $ $(E.sqlLOJproj 2 1) . $(E.sqlFOJproj 2 2)
|
||
|
||
queryExternalExamLabel :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity ExamOfficeExternalExamLabel)))
|
||
queryExternalExamLabel = to $ $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 2 2) . $(E.sqlFOJproj 2 2)
|
||
|
||
queryLabelExternalExam :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity ExamOfficeLabel)))
|
||
queryLabelExternalExam = to $ $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 2 2) . $(E.sqlFOJproj 2 2)
|
||
|
||
resultExam :: Traversal' ExamsTableData (Entity Exam)
|
||
resultExam = _dbrOutput . _1 . _Right . _1
|
||
|
||
resultCourse :: Traversal' ExamsTableData (Entity Course)
|
||
resultCourse = _dbrOutput . _1 . _Right . _2
|
||
|
||
resultSchool :: Traversal' ExamsTableData (Entity School)
|
||
resultSchool = _dbrOutput . _1 . _Right . _3
|
||
|
||
resultExternalExam :: Traversal' ExamsTableData (Entity ExternalExam)
|
||
resultExternalExam = _dbrOutput . _1 . _Left . _1
|
||
|
||
resultLabel :: Traversal' ExamsTableData (Maybe (Entity ExamOfficeLabel))
|
||
resultLabel = _dbrOutput . _1 . choosing _2 _4
|
||
|
||
resultSynchronised, resultResults :: Lens' ExamsTableData (Maybe Natural)
|
||
resultSynchronised = _dbrOutput . _2
|
||
resultResults = _dbrOutput . _3
|
||
|
||
resultIsSynced :: Getter ExamsTableData Bool
|
||
resultIsSynced = to $ (>=) <$> view resultSynchronised <*> view resultResults
|
||
|
||
|
||
-- | List of all exams where the current user may (in their function as exam-office) access users grades
|
||
getEOExamsR, postEOExamsR :: Handler Html
|
||
getEOExamsR = postEOExamsR
|
||
postEOExamsR = do
|
||
(uid, User{..}) <- requireAuthPair
|
||
now <- liftIO getCurrentTime
|
||
mr <- getMessageRender
|
||
|
||
getSynced <- lookupGetParam "synced" <&>
|
||
(\case
|
||
Just "yes" -> True
|
||
Just "no" -> False
|
||
_ -> userExamOfficeGetSynced
|
||
)
|
||
|
||
getLabels <- lookupGetParam "labels" <&>
|
||
(\case
|
||
Just "yes" -> True
|
||
Just "no" -> False
|
||
_ -> userExamOfficeGetLabels
|
||
)
|
||
|
||
(examsRes, examsTable) <- runDB $ do
|
||
let labelFilterNoLabelOption = Option
|
||
{ optionDisplay = mr MsgExamOfficeExamsNoLabel
|
||
, optionInternalValue = Nothing
|
||
, optionExternalValue = "no-label"
|
||
}
|
||
labelFilterOptions <- mkOptionList . (labelFilterNoLabelOption :) <$> do
|
||
labels <- E.select . E.from $ \examOfficeLabel -> do
|
||
E.where_ $ examOfficeLabel E.^. ExamOfficeLabelUser E.==. E.val uid
|
||
E.orderBy [ E.asc $ examOfficeLabel E.^. ExamOfficeLabelName ]
|
||
return examOfficeLabel
|
||
return . flip map labels $ \(Entity lblId ExamOfficeLabel{..})
|
||
-> Option { optionDisplay = examOfficeLabelName
|
||
, optionInternalValue = Just lblId
|
||
, optionExternalValue = examOfficeLabelName
|
||
}
|
||
|
||
let
|
||
examLink :: Course -> Exam -> SomeRoute UniWorX
|
||
examLink Course{..} Exam{..}
|
||
= SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName EGradesR
|
||
|
||
courseLink :: Course -> SomeRoute UniWorX
|
||
courseLink Course{..}
|
||
= SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
|
||
|
||
externalExamLink :: ExternalExam -> SomeRoute UniWorX
|
||
externalExamLink ExternalExam{..}
|
||
= SomeRoute $ EExamR externalExamTerm externalExamSchool externalExamCourseName externalExamExamName EEGradesR
|
||
|
||
examActions :: Map ExamAction (AForm Handler ExamActionData)
|
||
examActions = Map.fromList $
|
||
bool mempty
|
||
[ ( ExamSetLabel, ExamSetLabelData
|
||
<$> apopt (selectField' Nothing . fmap (fmap entityKey) $ optionsPersist [ExamOfficeLabelUser ==. uid] [Asc ExamOfficeLabelName] examOfficeLabelName) (fslI MsgExamLabel) Nothing
|
||
)
|
||
, ( ExamRemoveLabel, pure ExamRemoveLabelData )
|
||
] getLabels
|
||
|
||
examsDBTable = DBTable{..}
|
||
where
|
||
dbtSQLQuery = runReaderT $ do
|
||
exam <- view queryExam
|
||
course <- view queryCourse
|
||
school <- view querySchool
|
||
mExamLabel <- view queryExamLabel
|
||
mLabelExam <- view queryLabelExam
|
||
externalExam <- view queryExternalExam
|
||
mExternalExamLabel <- view queryExternalExamLabel
|
||
mLabelExternalExam <- view queryLabelExternalExam
|
||
|
||
lift $ do
|
||
E.on $ mExternalExamLabel E.?. ExamOfficeExternalExamLabelLabel E.==. mLabelExternalExam E.?. ExamOfficeLabelId
|
||
E.on $ E.maybe E.true (\externalExamLabelExternalExamId ->
|
||
externalExam E.?. ExternalExamId E.==. E.just externalExamLabelExternalExamId
|
||
) (mExternalExamLabel E.?. ExamOfficeExternalExamLabelExternalExam)
|
||
E.on E.false
|
||
E.on $ mExamLabel E.?. ExamOfficeExamLabelLabel E.==. mLabelExam E.?. ExamOfficeLabelId
|
||
E.on $ E.maybe E.true (\examLabelExamId ->
|
||
exam E.?. ExamId E.==. E.just examLabelExamId
|
||
) (mExamLabel E.?. ExamOfficeExamLabelExam)
|
||
E.on $ course E.?. CourseSchool E.==. school E.?. SchoolId
|
||
E.on $ exam E.?. ExamCourse E.==. course E.?. CourseId
|
||
|
||
E.where_ $ (E.not_ (E.isNothing $ exam E.?. ExamId) E.&&. E.not_ (E.isNothing $ course E.?. CourseId) E.&&. E.isNothing (externalExam E.?. ExternalExamId))
|
||
E.||. ( E.isNothing (exam E.?. ExamId) E.&&. E.isNothing (course E.?. CourseId) E.&&. E.not_ (E.isNothing $ externalExam E.?. ExternalExamId))
|
||
E.where_ $ E.val (not getLabels) E.||. (
|
||
E.val getLabels
|
||
E.&&. E.maybe E.true (\labelExamUser ->
|
||
labelExamUser E.==. E.val uid
|
||
) (mLabelExam E.?. ExamOfficeLabelUser)
|
||
E.&&. E.maybe E.true (\labelExternalExamUser ->
|
||
labelExternalExamUser E.==. E.val uid
|
||
) (mLabelExternalExam E.?. ExamOfficeLabelUser)
|
||
)
|
||
|
||
return (exam, course, school, mLabelExam, externalExam, mLabelExternalExam)
|
||
dbtRowKey = views ($(multifocusG 2) queryExam queryExternalExam) (bimap (E.?. ExamId) (E.?. ExternalExamId))
|
||
|
||
dbtProj :: _ ExamsTableData
|
||
dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do
|
||
exam <- view $ _dbtProjRow . _dbrOutput . _1
|
||
course <- view $ _dbtProjRow . _dbrOutput . _2
|
||
school <- view $ _dbtProjRow . _dbrOutput . _3
|
||
mExamLabel <- view $ _dbtProjRow . _dbrOutput . _4
|
||
externalExam <- view $ _dbtProjRow . _dbrOutput . _5
|
||
mExternalExamLabel <- view $ _dbtProjRow . _dbrOutput . _6
|
||
|
||
forMM_ (view $ _dbtProjFilter . _etProjFilterMayAccess) $ \b -> if
|
||
| Just (Entity _ exam') <- exam
|
||
, Just (Entity _ course') <- course
|
||
-> guardM . lift . lift . fmap (== b) . hasReadAccessTo . urlRoute $ examLink course' exam'
|
||
| Just (Entity _ eexam) <- externalExam
|
||
-> guardM . lift . lift . fmap (== b) . hasReadAccessTo . urlRoute $ externalExamLink eexam
|
||
| otherwise
|
||
-> error "Got neither exam nor externalExam in result"
|
||
|
||
let
|
||
getExamResults = for_ exam $ \(Entity examId _) -> E.selectSource . E.from $ \examResult -> do
|
||
E.where_ $ examResult E.^. ExamResultExam E.==. E.val examId
|
||
E.where_ $ Exam.examOfficeExamResultAuth (E.val uid) examResult
|
||
return $ Exam.resultIsSynced (E.val uid) examResult
|
||
getExternalExamResults = for_ externalExam $ \(Entity externalExamId _) -> E.selectSource . E.from $ \externalExamResult -> do
|
||
E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. E.val externalExamId
|
||
E.where_ $ ExternalExam.examOfficeExternalExamResultAuth (E.val uid) externalExamResult
|
||
return $ ExternalExam.resultIsSynced (E.val uid) externalExamResult
|
||
getResults = getExamResults >> getExternalExamResults
|
||
foldResult (E.Value isSynced) = (Sum 1, guardMonoid isSynced $ Sum 1)
|
||
|
||
mCounts <- if getSynced
|
||
then do
|
||
(Sum resCount, Sum synCount) <- lift . lift . runConduit $ getResults .| C.foldMap foldResult
|
||
forMM_ (view $ _dbtProjFilter . _etProjFilterHasResults) $ \b ->
|
||
guard $ b == (resCount > 0)
|
||
forMM_ (view $ _dbtProjFilter . _etProjFilterIsSynced) $ \b ->
|
||
guard $ b == (synCount >= resCount)
|
||
return $ Just (resCount, synCount)
|
||
else do
|
||
forMM_ (view $ _dbtProjFilter . _etProjFilterHasResults) guard
|
||
return Nothing
|
||
|
||
case (exam, course, school, mExamLabel, externalExam, mExternalExamLabel) of
|
||
(Just exam', Just course', Just school', mExamLabel', Nothing, Nothing) -> return
|
||
(Right (exam', course', school', mExamLabel'), snd <$> mCounts, fst <$> mCounts)
|
||
(Nothing, Nothing, Nothing, Nothing, Just externalExam', mExternalExamLabel') -> return
|
||
(Left (externalExam', mExternalExamLabel'), snd <$> mCounts, fst <$> mCounts)
|
||
_other -> return $ error "Got exam & externalExam in same result"
|
||
|
||
|
||
colLabel = Colonnade.singleton (fromSortable . Sortable (Just "label") $ i18nCell MsgTableExamLabel) $ \x -> flip runReader x $ do
|
||
mLabel <- preview resultLabel
|
||
|
||
-- TODO: use select frontend util
|
||
if
|
||
| Just (Just (Entity _ ExamOfficeLabel{..})) <- mLabel
|
||
-> return $ cell $(widgetFile "widgets/exam-office-label")
|
||
| otherwise -> return $ cell mempty
|
||
|
||
colSynced = Colonnade.singleton (fromSortable . Sortable (Just "synced") $ i18nCell MsgExamSynchronised) $ \x -> flip runReader x $ do
|
||
mExam <- preview resultExam
|
||
mSchool <- preview resultSchool
|
||
mSynced <- view resultSynchronised
|
||
mResults <- view resultResults
|
||
|
||
if
|
||
| Just (Entity _ Exam{examClosed, examFinished}) <- mExam
|
||
, Just (Entity _ School{schoolExamCloseMode}) <- mSchool
|
||
, bool ((min `on` NTop) examClosed examFinished > NTop (Just now))
|
||
(NTop examClosed > NTop (Just now))
|
||
$ is _ExamCloseSeparate schoolExamCloseMode
|
||
-> return . cell $ toWidget iconNew
|
||
| Just synced <- mSynced
|
||
, Just results <- mResults
|
||
-> do
|
||
isSynced <- view resultIsSynced
|
||
return $ cell
|
||
[whamlet|
|
||
$newline never
|
||
$if isSynced
|
||
#{iconOK}
|
||
$else
|
||
#{synced}/#{results}
|
||
|]
|
||
& cellAttrs <>~ [ ("class", "heated")
|
||
, ("style", [st|--hotness: #{tshow (heat results synced)}|])
|
||
]
|
||
| otherwise -> return $ cell mempty
|
||
|
||
|
||
dbtColonnade :: Colonnade Sortable _ _
|
||
dbtColonnade = mconcat
|
||
[ bool mempty (dbSelect (applying _2) id $ \DBRow{ dbrOutput=(ex,_,_) } -> return $ bimap (\(Entity eeId _,_) -> eeId) (\(Entity eId _,_,_,_) -> eId) ex) (not $ Map.null examActions)
|
||
, bool mempty colLabel getLabels
|
||
, bool mempty colSynced getSynced
|
||
, maybeAnchorColonnade ( runMaybeT $ mpreview ($(multifocusG 2) (pre $ resultCourse . _entityVal) (pre $ resultExam . _entityVal) . to (uncurry $ liftA2 examLink) . _Just)
|
||
<|> mpreviews (resultExternalExam . _entityVal) externalExamLink
|
||
)
|
||
$ emptyOpticColonnade (resultExam . _entityVal . _examName <> resultExternalExam . _entityVal . _externalExamExamName) colExamName
|
||
, emptyOpticColonnade (resultExam . _entityVal . $(multifocusG 2) _examStart _examEnd) colExamTime
|
||
, emptyOpticColonnade (resultExam . _entityVal . _examFinished) colExamFinishedOffice
|
||
, emptyOpticColonnade (resultExam . _entityVal . _examClosed) colExamClosed
|
||
, maybeAnchorColonnade (previews (resultCourse . _entityVal) courseLink)
|
||
$ emptyOpticColonnade (resultCourse . _entityVal . _courseName <> resultExternalExam . _entityVal . _externalExamCourseName) colCourseName
|
||
, emptyOpticColonnade (resultCourse . _entityVal . _courseSchool <> resultExternalExam . _entityVal . _externalExamSchool) colSchool
|
||
, emptyOpticColonnade (resultCourse . _entityVal . _courseTerm <> resultExternalExam . _entityVal . _externalExamTerm) colTermShort
|
||
]
|
||
dbtSorting = mconcat $
|
||
bool mempty
|
||
[ singletonMap "label-prio" $
|
||
SortProjected . comparing $ (fmap . fmap $ examOfficeLabelPriority . entityVal) <$> preview resultLabel
|
||
, singletonMap "label-status" $
|
||
SortProjected . comparing $ (fmap . fmap $ examOfficeLabelStatus . entityVal) <$> preview resultLabel
|
||
] getLabels <>
|
||
bool mempty
|
||
[ singletonMap "synced" $
|
||
SortProjected . comparing $ ((/) `on` toRational . fromMaybe 0) <$> view resultSynchronised <*> view resultResults
|
||
, singletonMap "is-synced" $
|
||
SortProjected . comparing $ (>=) <$> view resultSynchronised <*> view resultResults
|
||
] getSynced <>
|
||
[ sortExamName (to $ E.unsafeCoalesce . sequence [views queryExam (E.?. ExamName), views queryExternalExam (E.?. ExternalExamExamName)])
|
||
, sortExamTime (queryExam . $(multifocusG 2) (to $ E.joinV . (E.?. ExamStart)) (to $ E.joinV . (E.?. ExamEnd)))
|
||
, sortExamFinished (queryExam . to (E.joinV . (E.?. ExamFinished)))
|
||
, sortExamClosed (queryExam . to (E.joinV . (E.?. ExamClosed)))
|
||
, sortCourseName (to $ E.unsafeCoalesce . sequence [views queryCourse (E.?. CourseName), views queryExternalExam (E.?. ExternalExamCourseName)])
|
||
, sortSchool (to $ E.unsafeCoalesce . sequence [views queryCourse (E.?. CourseSchool), views queryExternalExam (E.?. ExternalExamSchool)])
|
||
, sortTerm (to $ E.unsafeCoalesce . sequence [views queryCourse (E.?. CourseTerm), views queryExternalExam (E.?. ExternalExamTerm)])
|
||
]
|
||
|
||
dbtFilter = mconcat
|
||
[ singletonMap "may-access" . FilterProjected $ (_etProjFilterMayAccess ?~) . getAny
|
||
, singletonMap "has-results" . FilterProjected $ (_etProjFilterHasResults ?~) . getAny
|
||
, singletonMap "is-synced" . FilterProjected $ (_etProjFilterIsSynced ?~) . getAny
|
||
, singletonMap "label" . FilterColumn . E.mkExactFilter $ views queryLabelExam (E.?. ExamOfficeLabelId)
|
||
]
|
||
dbtFilterUI mPrev = mconcat $
|
||
[ prismAForm (singletonFilter "label" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return labelFilterOptions) (fslI MsgExamLabel)
|
||
| getLabels ] <>
|
||
[ prismAForm (singletonFilter "is-synced" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgExamSynchronised)
|
||
| getSynced ]
|
||
|
||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||
|
||
dbtParams = DBParamsForm
|
||
{ dbParamsFormMethod = POST
|
||
, dbParamsFormAction = Just . SomeRoute $ ExamOfficeR EOExamsR
|
||
, dbParamsFormAttrs = []
|
||
, dbParamsFormSubmit = FormSubmit
|
||
, dbParamsFormAdditional
|
||
= renderAForm FormStandard
|
||
$ (, mempty) . First . Just
|
||
<$> multiActionA examActions (fslI MsgTableAction) Nothing
|
||
, dbParamsFormEvaluate = liftHandler . runFormPost
|
||
, dbParamsFormResult = id
|
||
, dbParamsFormIdent = def
|
||
}
|
||
|
||
dbtIdent :: Text
|
||
dbtIdent = "exams"
|
||
|
||
dbtCsvEncode = noCsvEncode
|
||
dbtCsvDecode = Nothing
|
||
|
||
dbtExtraReps = []
|
||
|
||
examsDBTableValidator = def
|
||
& defaultSorting (bool mempty [SortDescBy "label-prio", SortAscBy "label-status"] getLabels <> bool mempty [SortAscBy "is-synced"] getSynced <> [SortAscBy "exam-time"])
|
||
& forceFilter "may-access" (Any True)
|
||
& forceFilter "has-results" (Any True)
|
||
|
||
postprocess :: FormResult (First ExamActionData , DBFormResult (Either ExternalExamId ExamId) Bool (DBRow (Either (Entity ExternalExam, Maybe (Entity ExamOfficeLabel)) (Entity Exam, Entity Course, Entity School, Maybe (Entity ExamOfficeLabel)), Maybe Natural, Maybe Natural)))
|
||
-> FormResult ( ExamActionData , Set (Either ExternalExamId ExamId))
|
||
postprocess (FormFailure errs) = FormFailure errs
|
||
postprocess FormMissing = FormMissing
|
||
postprocess (FormSuccess (First mExamActionData, examRes))
|
||
| Just act <- mExamActionData = FormSuccess . (act,) . Map.keysSet . Map.filter id $ getDBFormResult (const False) examRes
|
||
| otherwise = FormMissing
|
||
|
||
over _1 postprocess <$> dbTable examsDBTableValidator examsDBTable
|
||
|
||
formResult examsRes $ \(examAction, exams) -> case examAction of
|
||
ExamSetLabelData{..} -> do
|
||
runDB . forM_ (Set.toList exams) $ either (\eeid -> void $ upsert (ExamOfficeExternalExamLabel eeid easlNewLabel) [ExamOfficeExternalExamLabelLabel =. easlNewLabel]) (\eid -> void $ upsert (ExamOfficeExamLabel eid easlNewLabel) [ExamOfficeExamLabelLabel =. easlNewLabel])
|
||
addMessageI Success $ MsgExamLabelsSet (Set.size exams)
|
||
redirect $ ExamOfficeR EOExamsR
|
||
ExamRemoveLabelData -> do
|
||
runDB . forM_ (Set.toList exams) $ either
|
||
(\eeId -> E.delete . E.from $ \extExLabel -> E.where_ (extExLabel E.^. ExamOfficeExternalExamLabelExternalExam E.==. E.val eeId))
|
||
(\eId -> E.delete . E.from $ \exLabel -> E.where_ (exLabel E.^. ExamOfficeExamLabelExam E.==. E.val eId))
|
||
addMessageI Success $ MsgExamLabelsRemoved (Set.size exams)
|
||
redirect $ ExamOfficeR EOExamsR
|
||
|
||
siteLayoutMsg MsgHeadingExamList $ do
|
||
setTitleI MsgHeadingExamList
|
||
examsTable
|