Better exam table
This commit is contained in:
Gregor Kleen
parent
a42c6dc91f
commit
d054370b29
@ -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.
|
||||
|
||||
3
routes
3
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
|
||||
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user