92 lines
4.1 KiB
Haskell
92 lines
4.1 KiB
Haskell
module Handler.Exam.List
|
|
( mkExamTable
|
|
, getCExamListR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Handler.Utils
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
|
|
mkExamTable :: Entity Course -> DB (Any, Widget)
|
|
mkExamTable (Entity cid Course{..}) = do
|
|
let tid = courseTerm
|
|
ssh = courseSchool
|
|
csh = courseShorthand
|
|
now <- liftIO getCurrentTime
|
|
mbAid <- maybeAuthId
|
|
mayCreate <- hasWriteAccessTo $ CourseR tid ssh csh CExamNewR
|
|
|
|
let
|
|
examDBTable = DBTable{..}
|
|
where
|
|
dbtSQLQuery exam = do
|
|
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
|
|
return exam
|
|
dbtRowKey = (E.^. ExamId)
|
|
dbtProj = dbtProjFilteredPostId
|
|
dbtColonnade = dbColonnade . mconcat $ catMaybes
|
|
[ Just . sortable (Just "name") (i18nCell MsgTableExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> indicatorCell <> anchorCell (CExamR tid ssh csh examName EShowR) examName
|
|
, (<$ guard mayCreate) . sortable (Just "visible") (i18nCell MsgExamVisibleFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty (dateTimeCellVisible now) examVisibleFrom
|
|
, Just . sortable (Just "register-from") (i18nCell MsgTableExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
|
|
, Just . sortable (Just "register-to") (i18nCell MsgTableExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
|
|
, Just . sortable (Just "time") (i18nCell MsgTableExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
|
|
, Just . sortable (Just "registered") (i18nCell MsgTableExamRegistration ) $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do
|
|
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
|
|
isRegistered <- case mbAid of
|
|
Nothing -> return False
|
|
Just uid -> existsBy $ UniqueExamRegistration eId uid
|
|
let label = bool MsgExamNotRegistered MsgExamRegistered isRegistered
|
|
examUrl = CExamR tid ssh csh examName EShowR
|
|
if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl
|
|
| otherwise -> return [whamlet|_{label}|]
|
|
]
|
|
dbtSorting = Map.fromList
|
|
[ ("name", SortColumn $ \exam -> exam E.^. ExamName )
|
|
, ("time", SortColumn $ \exam -> exam E.^. ExamStart )
|
|
, ("register-from", SortColumn $ \exam -> exam E.^. ExamRegisterFrom )
|
|
, ("register-to", SortColumn $ \exam -> exam E.^. ExamRegisterTo )
|
|
, ("visible", SortColumn $ \exam -> exam E.^. ExamVisibleFrom )
|
|
, ("registered", SortColumn $ \exam ->
|
|
case mbAid of
|
|
Nothing -> E.false
|
|
Just uid ->
|
|
E.exists $ E.from $ \reg -> do
|
|
E.where_ $ reg E.^. ExamRegistrationUser E.==. E.val uid
|
|
E.where_ $ reg E.^. ExamRegistrationExam E.==. exam E.^. ExamId
|
|
)
|
|
]
|
|
dbtFilter = singletonMap "may-read" . mkFilterProjectedPost $
|
|
\(Any b) DBRow{ dbrOutput = Entity _ Exam{..} }
|
|
-> (== b) <$> hasReadAccessTo (CExamR tid ssh csh examName EShowR) :: DB Bool
|
|
dbtFilterUI = const mempty
|
|
dbtStyle = def
|
|
dbtParams = def
|
|
dbtIdent :: Text
|
|
dbtIdent = "exams"
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
|
|
examDBTableValidator = def
|
|
& defaultSorting [SortAscBy "time"]
|
|
& forceFilter "may-read" (Any True)
|
|
|
|
dbTable examDBTableValidator examDBTable
|
|
|
|
|
|
getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCExamListR tid ssh csh = do
|
|
examTable <- runDB $ do
|
|
c <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
|
view _2 <$> mkExamTable c
|
|
|
|
siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamsHeading) $ do
|
|
setTitleI $ prependCourseTitle tid ssh csh MsgExamsHeading
|
|
$(widgetFile "exam-list")
|