Better exam table

messages/uniworx/de.msg

@@ -278,6 +278,7 @@ UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen.
 UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben.
 UnauthorizedMaterialTime: Dieses Material ist momentan nicht freigegeben.
 UnauthorizedTutorialTime: Dieses Tutorium erlaubt momentan keine Anmeldungen.
+UnauthorizedExamTime: Diese Klausur ist momentan nicht freigegeben.
 UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt.
 UnauthorizedSubmissionRated: Diese Abgabe ist noch nicht korrigiert.
 UnauthorizedSubmissionCorrector: Sie sind nicht der Korrektor für diese Abgabe.

routes

@@ -137,9 +137,10 @@
     /register                 TRegisterR           POST        !timeANDcapacityANDcourse-registeredANDregister-group !timeANDtutorial-registered
     /communication            TCommR           GET POST        !tutor
     /tutor-invite             TInviteR         GET POST
-  /exams                        CExamListR     GET             !development -- Missing permission checks on which exams can be shown
+  /exams                        CExamListR     GET             !free
   /exams/new                    CExamNewR      GET POST
   /exams/#ExamName ExamR:
+    /show                       EShowR         GET             !time
     /corrector-invite           ECInviteR      GET POST
 
 

src/Foundation.hs

@@ -641,6 +641,15 @@ tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return
       guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor)
       return Authorized
 tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
+  CExamR tid ssh csh examn _subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do
+    course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+    Entity _ Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn
+    cTime <- liftIO getCurrentTime
+
+    guard $ NTop examVisibleFrom <= NTop (Just cTime)
+
+    return Authorized
+  
   CTutorialR tid ssh csh tutn TRegisterR -> maybeT (unauthorizedI MsgUnauthorizedTutorialTime) $ do
     now <- liftIO getCurrentTime
     course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
@@ -1446,6 +1455,8 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb (CourseR tid ssh csh CExamListR) = return ("Klausuren", Just $ CourseR tid ssh csh CShowR)
   breadcrumb (CourseR tid ssh csh CExamNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CExamListR)
 
+  breadcrumb (CExamR tid ssh csh examn EShowR) = return (CI.original examn, Just $ CourseR tid ssh csh CExamListR)
+
   breadcrumb (CTutorialR tid ssh csh tutn TUsersR)   = return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR)
   breadcrumb (CTutorialR tid ssh csh tutn TEditR)    = return ("Bearbeiten", Just $ CTutorialR tid ssh csh tutn TUsersR)
   breadcrumb (CTutorialR tid ssh csh tutn TDeleteR)  = return ("Löschen", Just $ CTutorialR tid ssh csh tutn TUsersR)

src/Handler/Exam.hs

@@ -7,6 +7,7 @@ import Import
 import Handler.Utils
 import Handler.Utils.Exam
 import Handler.Utils.Invitations
+import Handler.Utils.Table.Cells
 import Jobs.Queue
 
 import Utils.Lens
@@ -25,6 +26,8 @@ import Text.Blaze.Html.Renderer.String (renderHtml)
 getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCExamListR tid ssh csh = do
   Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
+  now <- liftIO getCurrentTime
+  mayCreate <- hasWriteAccessTo $ CourseR tid ssh csh CExamNewR
 
   let
     examDBTable = DBTable{..}
@@ -33,10 +36,15 @@ getCExamListR tid ssh csh = do
           E.where_ $ exam E.^. ExamCourse E.==. E.val cid
           return exam
         dbtRowKey = (E.^. ExamId)
-        dbtProj = return
+        dbtProj x@DBRow{ dbrOutput = Entity _ Exam{..} } = do
-        dbtColonnade = dbColonnade $ mconcat
+          guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR
-          [ sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> cell $ toWidget examName
+          return x
-          , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> cell $ do
+        dbtColonnade = dbColonnade . mconcat $ catMaybes
+          [ Just . sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> anchorCell (CExamR tid ssh csh examName EShowR) $ toWidget examName
+          , (<$ guard mayCreate) . sortable (Just "visible") (i18nCell MsgExamVisibleFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty (dateTimeCellVisible now) examVisibleFrom
+          , Just . sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
+          , Just . sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
+          , Just . sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> cell $ do
               startT <- formatTime SelFormatDateTime examStart
               endT <- traverse (\examEnd' -> formatTime (bool SelFormatDateTime SelFormatTime $ ((==) `on` utctDay) examStart examEnd') examEnd') examEnd
               [whamlet|
@@ -389,3 +397,6 @@ postCExamNewR tid ssh csh = do
         , formEncoding = newExamEnctype
         }
     $(widgetFile "exam-new")
+
+getEShowR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
+getEShowR = error "getExamShowR"

src/Handler/Utils/Exam.hs

@@ -3,7 +3,7 @@ module Handler.Utils.Exam
   , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam
   ) where
 
-import Import
+import Import.NoFoundation
 
 import Database.Persist.Sql (SqlBackendCanRead)
 import qualified Database.Esqueleto as E
@@ -34,14 +34,14 @@ fetchExamAux prj tid ssh csh examn =
           [tut] -> return tut
           _other  -> notFound
 
-fetchExam :: TermId -> SchoolId -> CourseShorthand -> ExamName -> DB (Entity Exam)
+fetchExam :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Entity Exam)
 fetchExam = fetchExamAux const
 
-fetchExamId :: TermId -> SchoolId -> CourseShorthand -> ExamName -> YesodDB UniWorX (Key Exam)
+fetchExamId :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Key Exam)
 fetchExamId tid ssh cid examn = E.unValue <$> fetchExamAux (\tutorial _ -> tutorial E.^. ExamId) tid ssh cid examn
 
-fetchCourseIdExamId  :: TermId -> SchoolId -> CourseShorthand -> ExamName -> YesodDB UniWorX (Key Course, Key Exam)
+fetchCourseIdExamId  :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Key Course, Key Exam)
 fetchCourseIdExamId tid ssh cid examn = $(unValueN 2) <$> fetchExamAux (\tutorial course -> (course E.^. CourseId, tutorial E.^. ExamId)) tid ssh cid examn
 
-fetchCourseIdExam  :: TermId -> SchoolId -> CourseShorthand -> ExamName -> YesodDB UniWorX (Key Course, Entity Exam)
+fetchCourseIdExam  :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Key Course, Entity Exam)
 fetchCourseIdExam tid ssh cid examn = over _1 E.unValue <$> fetchExamAux (\tutorial course -> (course E.^. CourseId, tutorial)) tid ssh cid examn