201 lines
7.3 KiB
Haskell
201 lines
7.3 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 Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import qualified Colonnade
|
|
|
|
|
|
type ExamsTableExpr = E.SqlExpr (Entity Exam)
|
|
`E.InnerJoin` E.SqlExpr (Entity Course)
|
|
|
|
type ExamsTableData = DBRow ( Entity Exam
|
|
, Entity Course
|
|
, Natural, Natural
|
|
)
|
|
|
|
queryExam :: Getter ExamsTableExpr (E.SqlExpr (Entity Exam))
|
|
queryExam = to $(E.sqlIJproj 2 1)
|
|
|
|
queryCourse :: Getter ExamsTableExpr (E.SqlExpr (Entity Course))
|
|
queryCourse = to $(E.sqlIJproj 2 2)
|
|
|
|
querySynchronised :: E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Natural))
|
|
querySynchronised office = to . runReader $ do
|
|
exam <- view queryExam
|
|
let
|
|
synchronised = E.sub_select . E.from $ \examResult -> do
|
|
E.where_ $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
|
|
E.where_ $ Exam.examOfficeExamResultAuth office examResult
|
|
E.where_ $ Exam.resultIsSynced office examResult
|
|
return E.countRows
|
|
return synchronised
|
|
|
|
queryResults :: E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Natural))
|
|
queryResults office = to . runReader $ do
|
|
exam <- view queryExam
|
|
let
|
|
results = E.sub_select . E.from $ \examResult -> do
|
|
E.where_ $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
|
|
E.where_ $ Exam.examOfficeExamResultAuth office examResult
|
|
return E.countRows
|
|
return results
|
|
|
|
queryIsSynced :: UTCTime -> E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Bool))
|
|
queryIsSynced now office = to . runReader $ do
|
|
exam <- view queryExam
|
|
let
|
|
synchronised = E.not_ . E.exists . E.from $ \examResult -> do
|
|
E.where_ $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
|
|
E.where_ $ Exam.examOfficeExamResultAuth office examResult
|
|
E.where_ . E.not_ $ Exam.resultIsSynced office examResult
|
|
open = E.maybe E.true (E.>. E.val now) $ exam E.^. ExamClosed
|
|
return $ synchronised E.||. open
|
|
|
|
|
|
resultExam :: Lens' ExamsTableData (Entity Exam)
|
|
resultExam = _dbrOutput . _1
|
|
|
|
resultCourse :: Lens' ExamsTableData (Entity Course)
|
|
resultCourse = _dbrOutput . _2
|
|
|
|
resultSynchronised, resultResults :: Lens' ExamsTableData Natural
|
|
resultSynchronised = _dbrOutput . _3
|
|
resultResults = _dbrOutput . _4
|
|
|
|
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
|
|
|
|
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
|
|
|
|
synchronised <- view querySynchronised'
|
|
results <- view queryResults'
|
|
|
|
lift $ do
|
|
E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId
|
|
|
|
E.where_ $ results E.>. E.val 0
|
|
|
|
return (exam, course, synchronised, results)
|
|
dbtRowKey = views queryExam (E.^. ExamId)
|
|
|
|
dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) ExamsTableData
|
|
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do
|
|
exam <- view $ _1 . _entityVal
|
|
course <- view $ _2 . _entityVal
|
|
|
|
guard =<< hasReadAccessTo (urlRoute $ examLink course exam)
|
|
|
|
(,,,)
|
|
<$> view _1 <*> view _2 <*> view (_3 . _Value) <*> view (_4 . _Value)
|
|
|
|
|
|
colSynced = Colonnade.singleton (fromSortable . Sortable (Just "synced") $ i18nCell MsgExamSynchronised) $ \x -> flip runReader x $ do
|
|
Entity _ Exam{examClosed} <- view resultExam
|
|
|
|
if
|
|
| NTop examClosed > NTop (Just now)
|
|
-> 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
|
|
, anchorColonnade (views ($(multifocusG 2) (resultCourse . _entityVal) (resultExam . _entityVal)) (uncurry examLink))
|
|
$ colExamName (resultExam . _entityVal . _examName)
|
|
, colExamTime (resultExam . _entityVal . $(multifocusG 2) _examStart _examEnd)
|
|
, colExamFinishedOffice (resultExam . _entityVal . _examFinished)
|
|
, colExamClosed (resultExam . _entityVal . _examClosed)
|
|
, anchorColonnade (views (resultCourse . _entityVal) courseLink)
|
|
$ colCourseName (resultCourse . _entityVal . _courseName)
|
|
, colSchool (resultCourse . _entityVal . _courseSchool)
|
|
, colTermShort (resultCourse . _entityVal . _courseTerm)
|
|
]
|
|
dbtSorting = mconcat
|
|
[ singletonMap "synced" . SortColumn $ (E./.) <$> view querySynchronised' <*> view queryResults'
|
|
, singletonMap "is-synced" . SortColumn $ view queryIsSynced'
|
|
, sortExamName (queryExam . to (E.^. ExamName))
|
|
, sortExamTime (queryExam . $(multifocusG 2) (to (E.^. ExamStart)) (to (E.^. ExamEnd)))
|
|
, sortExamFinished (queryExam . to (E.^. ExamFinished))
|
|
, sortExamClosed (queryExam . to (E.^. ExamClosed))
|
|
, sortCourseName (queryCourse . to (E.^. CourseName))
|
|
, sortSchool (queryCourse . to (E.^. CourseSchool))
|
|
, sortTerm (queryCourse . to (E.^. CourseTerm))
|
|
]
|
|
|
|
dbtFilter = mconcat
|
|
[
|
|
]
|
|
dbtFilterUI = mconcat
|
|
[
|
|
]
|
|
|
|
dbtStyle = def -- { dbsFilterLayout = defaultDBSFilterLayout }
|
|
dbtParams = def
|
|
|
|
dbtIdent :: Text
|
|
dbtIdent = "exams"
|
|
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
|
|
examsDBTableValidator = def & defaultSorting [SortAscBy "is-synced", SortAscBy "exam-time"]
|
|
|
|
dbTableWidget' examsDBTableValidator examsDBTable
|
|
|
|
siteLayoutMsg MsgMenuExamList $ do
|
|
setTitleI MsgMenuExamList
|
|
examsTable
|