264 lines
13 KiB
Haskell
264 lines
13 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
|
|
|
module Handler.ExamOffice.Exams
|
|
( getEOExamsR
|
|
) 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 as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import qualified Colonnade
|
|
|
|
|
|
type ExamsTableExpr = ( E.SqlExpr (Maybe (Entity Exam))
|
|
`E.InnerJoin` E.SqlExpr (Maybe (Entity Course))
|
|
`E.InnerJoin` E.SqlExpr (Maybe (Entity School))
|
|
)
|
|
`E.FullOuterJoin` E.SqlExpr (Maybe (Entity ExternalExam))
|
|
|
|
type ExamsTableData = DBRow ( Either (Entity ExternalExam) (Entity Exam, Entity Course, Entity School)
|
|
, Natural, Natural
|
|
)
|
|
|
|
queryExam :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity Exam)))
|
|
queryExam = to $ $(E.sqlIJproj 3 1) . $(E.sqlFOJproj 2 1)
|
|
|
|
queryCourse :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity Course)))
|
|
queryCourse = to $ $(E.sqlIJproj 3 2) . $(E.sqlFOJproj 2 1)
|
|
|
|
querySchool :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity School)))
|
|
querySchool = to $ $(E.sqlIJproj 3 3) . $(E.sqlFOJproj 2 1)
|
|
|
|
queryExternalExam :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity ExternalExam)))
|
|
queryExternalExam = to $(E.sqlFOJproj 2 2)
|
|
|
|
querySynchronised :: E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Word64))
|
|
querySynchronised office = to . runReader $ do
|
|
exam' <- view queryExam
|
|
externalExam' <- view queryExternalExam
|
|
let
|
|
examSynchronised examId = E.subSelectCount . E.from $ \examResult -> do
|
|
E.where_ $ examResult E.^. ExamResultExam E.==. examId
|
|
E.where_ $ Exam.examOfficeExamResultAuth office examResult
|
|
E.where_ $ Exam.resultIsSynced office examResult
|
|
externalExamSynchronised externalExamId = E.subSelectCount . E.from $ \externalExamResult -> do
|
|
E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. externalExamId
|
|
E.where_ $ ExternalExam.examOfficeExternalExamResultAuth office externalExamResult
|
|
E.where_ $ ExternalExam.resultIsSynced office externalExamResult
|
|
return $ E.maybe (E.val 0) examSynchronised (exam' E.?. ExamId) E.+. E.maybe (E.val 0) externalExamSynchronised (externalExam' E.?. ExternalExamId)
|
|
|
|
queryResults :: E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Word64))
|
|
queryResults office = to . runReader $ do
|
|
exam' <- view queryExam
|
|
externalExam' <- view queryExternalExam
|
|
let
|
|
results examId = E.subSelectCount . E.from $ \examResult -> do
|
|
E.where_ $ examResult E.^. ExamResultExam E.==. examId
|
|
E.where_ $ Exam.examOfficeExamResultAuth office examResult
|
|
externalResults externalExamId = E.subSelectCount . E.from $ \externalExamResult -> do
|
|
E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. externalExamId
|
|
E.where_ $ ExternalExam.examOfficeExternalExamResultAuth office externalExamResult
|
|
return $ E.maybe (E.val 0) results (exam' E.?. ExamId) E.+. E.maybe (E.val 0) externalResults (externalExam' E.?. ExternalExamId)
|
|
|
|
queryIsSynced :: UTCTime -> E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Bool))
|
|
queryIsSynced now office = to . runReader $ do
|
|
exam' <- view queryExam
|
|
externalExam' <- view queryExternalExam
|
|
school' <- view querySchool
|
|
let
|
|
examSynchronised examId = E.not_ . E.exists . E.from $ \examResult -> do
|
|
E.where_ $ examResult E.^. ExamResultExam E.==. examId
|
|
E.where_ $ Exam.examOfficeExamResultAuth office examResult
|
|
E.where_ . E.not_ $ Exam.resultIsSynced office examResult
|
|
externalExamSynchronised externalExamId = E.not_ . E.exists . E.from $ \externalExamResult -> do
|
|
E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. externalExamId
|
|
E.where_ $ ExternalExam.examOfficeExternalExamResultAuth office externalExamResult
|
|
E.where_ . E.not_ $ ExternalExam.resultIsSynced office externalExamResult
|
|
open examClosed' examFinished'
|
|
= E.bool (E.maybe E.true (E.>. E.val now) $ E.min examClosed' examFinished')
|
|
(E.maybe E.true (E.>. E.val now) examClosed')
|
|
(E.maybe E.false (E.==. E.val ExamCloseSeparate) (school' E.?. SchoolExamCloseMode))
|
|
return $ E.maybe E.false examSynchronised (exam' E.?. ExamId) E.||. E.maybe2 E.false open (exam' E.?. ExamClosed) (exam' E.?. ExamFinished) E.||. E.maybe E.false externalExamSynchronised (externalExam' E.?. ExternalExamId)
|
|
|
|
|
|
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
|
|
|
|
resultSynchronised, resultResults :: Lens' ExamsTableData 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 her function as
|
|
-- exam-office) access users grades
|
|
getEOExamsR :: Handler Html
|
|
getEOExamsR = do
|
|
uid <- requireAuthId
|
|
now <- liftIO getCurrentTime
|
|
|
|
examsTable <- runDB $ do
|
|
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
|
|
|
|
querySynchronised' = querySynchronised $ E.val uid
|
|
queryResults' = queryResults $ E.val uid
|
|
queryIsSynced' = queryIsSynced now $ E.val uid
|
|
|
|
examsDBTable = DBTable{..}
|
|
where
|
|
dbtSQLQuery = runReaderT $ do
|
|
exam <- view queryExam
|
|
course <- view queryCourse
|
|
school <- view querySchool
|
|
externalExam <- view queryExternalExam
|
|
|
|
synchronised <- view querySynchronised'
|
|
results <- view queryResults'
|
|
|
|
lift $ do
|
|
E.on E.false
|
|
E.on $ school E.?. SchoolId E.==. course E.?. CourseSchool
|
|
E.on $ exam E.?. ExamCourse E.==. course E.?. CourseId
|
|
|
|
E.where_ $ results E.>. E.val 0
|
|
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))
|
|
|
|
return (exam, course, school, externalExam, synchronised, results)
|
|
dbtRowKey = views ($(multifocusG 2) queryExam queryExternalExam) (bimap (E.?. ExamId) (E.?. ExternalExamId))
|
|
|
|
dbtProj :: DBRow _ -> DB ExamsTableData
|
|
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do
|
|
exam <- view _1
|
|
course <- view _2
|
|
school <- view _3
|
|
externalExam <- view _4
|
|
|
|
case (exam, course, school, externalExam) of
|
|
(Just exam', Just course', Just school', Nothing) ->
|
|
(Right (exam', course', school'),,) <$> view (_5 . _Value . _Integral) <*> view (_6 . _Value . _Integral)
|
|
(Nothing, Nothing, Nothing, Just externalExam') ->
|
|
(Left externalExam',,) <$> view (_5 . _Value . _Integral) <*> view (_6 . _Value . _Integral)
|
|
_other -> return $ error "Got exam & externalExam in same result"
|
|
|
|
|
|
colSynced = Colonnade.singleton (fromSortable . Sortable (Just "synced") $ i18nCell MsgExamSynchronised) $ \x -> flip runReader x $ do
|
|
mExam <- preview resultExam
|
|
mSchool <- preview resultSchool
|
|
|
|
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
|
|
| otherwise
|
|
-> do
|
|
synced <- view resultSynchronised
|
|
results <- view resultResults
|
|
isSynced <- view resultIsSynced
|
|
|
|
return $ cell
|
|
[whamlet|
|
|
$newline never
|
|
$if isSynced
|
|
#{iconOK}
|
|
$else
|
|
#{synced}/#{results}
|
|
|]
|
|
& cellAttrs <>~ [ ("class", "heated")
|
|
, ("style", [st|--hotness: #{tshow (heat results synced)}|])
|
|
]
|
|
|
|
|
|
dbtColonnade :: Colonnade Sortable _ _
|
|
dbtColonnade = mconcat
|
|
[ colSynced
|
|
, 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
|
|
[ singletonMap "synced" . SortColumn $ (E./.) <$> view querySynchronised' <*> view queryResults'
|
|
, singletonMap "is-synced" . SortColumn $ view queryIsSynced'
|
|
, 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 $ \(Any b) r -> (== b) <$> if
|
|
| Just exam <- r ^? resultExam . _entityVal
|
|
, Just course <- r ^? resultCourse . _entityVal
|
|
-> hasReadAccessTo . urlRoute $ examLink course exam
|
|
| Just eexam <- r ^? resultExternalExam . _entityVal
|
|
-> hasReadAccessTo . urlRoute $ externalExamLink eexam :: DB Bool
|
|
| otherwise
|
|
-> return $ error "Got neither exam nor externalExam in result"
|
|
]
|
|
dbtFilterUI = mconcat
|
|
[
|
|
]
|
|
|
|
dbtStyle = def -- { dbsFilterLayout = defaultDBSFilterLayout }
|
|
dbtParams = def
|
|
|
|
dbtIdent :: Text
|
|
dbtIdent = "exams"
|
|
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
|
|
dbtExtraReps = []
|
|
|
|
examsDBTableValidator = def
|
|
& defaultSorting [SortAscBy "is-synced", SortAscBy "exam-time"]
|
|
& forceFilter "may-access" (Any True)
|
|
|
|
dbTableWidget' examsDBTableValidator examsDBTable
|
|
|
|
siteLayoutMsg MsgMenuExamList $ do
|
|
setTitleI MsgMenuExamList
|
|
examsTable
|