diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 530f07b25..5dfe93c8c 100644 --- a/messages/uniworx/de.msg +++ b/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. diff --git a/routes b/routes index f409deb1d..17d24e02c 100644 --- a/routes +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index dc3621858..2808e6180 100644 --- a/src/Foundation.hs +++ b/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) diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index 4f1c4917a..5def10ff3 100644 --- a/src/Handler/Exam.hs +++ b/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 - dbtColonnade = dbColonnade $ mconcat - [ sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> cell $ toWidget examName - , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> cell $ do + dbtProj x@DBRow{ dbrOutput = Entity _ Exam{..} } = do + guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR + return x + 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" diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 249d98b73..3d1d43845 100644 --- a/src/Handler/Utils/Exam.hs +++ b/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