From fa3521d6dbebe1d07352bec2269b10e5eb3e31d5 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 28 Nov 2019 15:55:49 +0100 Subject: [PATCH] feat(external-exams): list --- messages/uniworx/de-de-formal.msg | 6 ++ messages/uniworx/en-eu.msg | 6 ++ routes | 1 + src/Foundation.hs | 1 + src/Handler/ExternalExam.hs | 1 + src/Handler/ExternalExam/List.hs | 74 ++++++++++++++++++++++++- src/Handler/ExternalExam/Show.hs | 22 +++++++- src/Handler/ExternalExam/StaffInvite.hs | 74 +++++++++++++++++++++++++ templates/external-exam-show.hamlet | 41 ++++++++++++++ 9 files changed, 224 insertions(+), 2 deletions(-) create mode 100644 src/Handler/ExternalExam/StaffInvite.hs create mode 100644 templates/external-exam-show.hamlet diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index dd3cbb73e..da7f03b5e 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -1258,6 +1258,7 @@ BreadcrumbExternalExamShow coursen@CourseName examn@ExamName: #{coursen}, #{exam BreadcrumbExternalExamEdit: Editieren BreadcrumbExternalExamUsers: Teilnehmer BreadcrumbExternalExamGrades: Prüfungsleistungen +BreadcrumbExternalExamStaffInvite: Einladung zum Prüfer TitleMetrics: Metriken @@ -1834,6 +1835,11 @@ MailSchoolFunctionInviteHeading school@SchoolName renderedFunction@Text: #{rende SchoolFunctionInviteExplanation renderedFunction@Text: Sie wurden eingeladen, als #{renderedFunction} für ein Institut zu wirken. Sie erhalten, nachdem Sie die Einladung annehmen, erweiterte Rechte innerhalb des Instituts. SchoolFunctionInvitationAccepted school@SchoolName renderedFunction@Text: #{renderedFunction}-Einladung zum Dozent für „#{school}“ angenommen +MailSubjectExternalExamStaffInvitation coursen@CourseName examn@ExamName: Einladung zum Prüfer für „#{examn}“ in „#{coursen}“ +ExternalExamStaffInviteHeading coursen@CourseName examn@ExamName: Einladung zum Prüfer für „#{examn}“ in „#{coursen}“ +ExternalExamStaffInviteExplanation: Sie wurden eingeladen als Prüfer für eine Uni2work-externe Prüfung zu wirken. Sie können dann u.A. Noten für die Prüfung hinterlegen. +ExternalExamStaffInvitationAccepted coursen@CourseName examn@ExamName: Sie sind nun als Prüfer für „#{examn}“ in „#{coursen}“ eingetragen. + AllocationActive: Aktiv AllocationName: Name AllocationAvailableCourses: Kurse diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 124a7e9f6..bbc7d1fa4 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -1255,6 +1255,7 @@ BreadcrumbExternalExamShow coursen@CourseName examn@ExamName: #{coursen}, #{exam BreadcrumbExternalExamEdit: Edit BreadcrumbExternalExamUsers: Participants BreadcrumbExternalExamGrades: Exam results +BreadcrumbExternalExamStaffInvite: Invitation TitleMetrics: Metrics @@ -1830,6 +1831,11 @@ MailSchoolFunctionInviteHeading school renderedFunction: Invitation to be #{rend SchoolFunctionInviteExplanation renderedFunction: You were invited to act as #{renderedFunction} for a department. By accepting the invitation you are granted elevated rights within the department. SchoolFunctionInvitationAccepted school renderedFunction: Successfully accepted invitation to be #{renderedFunction} for “#{school}” +MailSubjectExternalExamStaffInvitation coursen examn: Invitation to act as examiner for “#{examn}” of “#{coursen}” +ExternalExamStaffInviteHeading coursen examn: Invitation to act as examiner for “#{examn}” of “#{coursen}” +ExternalExamStaffInviteExplanation: You have been invited to act as an examiner for a uni2work-external exam. After accepting you will be able to upload exam results. +ExternalExamStaffInvitationAccepted coursen examn: You are now registered as an examiner for “#{examn}” of “#{coursen}”. + AllocationActive: Active AllocationName: Name AllocationAvailableCourses: Courses diff --git a/routes b/routes index 7e71b86f6..e2f0bbb74 100644 --- a/routes +++ b/routes @@ -87,6 +87,7 @@ /edit EEEditR GET POST /users EEUsersR GET POST /grades EEGradesR GET POST !exam-office + /staff-invite EEStaffInviteR GET POST /term TermShowR GET !free diff --git a/src/Foundation.hs b/src/Foundation.hs index 73197ac5c..117ebd26c 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1995,6 +1995,7 @@ instance YesodBreadcrumbs UniWorX where EEEditR -> i18nCrumb MsgBreadcrumbExternalExamEdit . Just $ EExamR tid ssh coursen examn EEShowR EEUsersR -> i18nCrumb MsgBreadcrumbExternalExamUsers . Just $ EExamR tid ssh coursen examn EEShowR EEGradesR -> i18nCrumb MsgBreadcrumbExternalExamGrades . Just $ EExamR tid ssh coursen examn EEShowR + EEStaffInviteR -> i18nCrumb MsgBreadcrumbExternalExamStaffInvite . Just $ EExamR tid ssh coursen examn EEShowR -- breadcrumb _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all diff --git a/src/Handler/ExternalExam.hs b/src/Handler/ExternalExam.hs index a715bcd8f..ac53b0246 100644 --- a/src/Handler/ExternalExam.hs +++ b/src/Handler/ExternalExam.hs @@ -7,3 +7,4 @@ import Handler.ExternalExam.New as Handler.ExternalExam import Handler.ExternalExam.Show as Handler.ExternalExam import Handler.ExternalExam.Edit as Handler.ExternalExam import Handler.ExternalExam.Users as Handler.ExternalExam +import Handler.ExternalExam.StaffInvite as Handler.ExternalExam diff --git a/src/Handler/ExternalExam/List.hs b/src/Handler/ExternalExam/List.hs index 7ecde480c..ac8f6e0b2 100644 --- a/src/Handler/ExternalExam/List.hs +++ b/src/Handler/ExternalExam/List.hs @@ -3,7 +3,79 @@ module Handler.ExternalExam.List ) where import Import + +import Handler.Utils + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E + +import qualified Data.Map as Map getEExamListR :: Handler Html -getEExamListR = error "Not implemented" +getEExamListR = do + mAuthId <- maybeAuthId + + let + examDBTable = DBTable{..} + where + resultEExam = _dbrOutput . _1 + resultSchool = _dbrOutput . _2 + + queryEExam = $(E.sqlIJproj 2 1) + querySchool = $(E.sqlIJproj 2 2) + + dbtSQLQuery (eexam `E.InnerJoin` school) = do + E.on $ eexam E.^. ExternalExamSchool E.==. school E.^. SchoolId + let + isStaff + | Just authId <- mAuthId + = E.exists . E.from $ \eexamStaff -> + E.where_ $ eexamStaff E.^. ExternalExamStaffExam E.==. eexam E.^. ExternalExamId + E.&&. eexamStaff E.^. ExternalExamStaffUser E.==. E.val authId + | otherwise + = E.false + isStudent + | Just authId <- mAuthId + = E.exists . E.from $ \eexamResult -> + E.where_ $ eexamResult E.^. ExternalExamResultExam E.==. eexam E.^. ExternalExamId + E.&&. eexamResult E.^. ExternalExamResultUser E.==. E.val authId + | otherwise + = E.false + E.where_ $ isStaff E.||. isStudent + + return (eexam, school) + dbtRowKey = queryEExam >>> (E.^. ExternalExamId) + dbtProj x@(view resultEExam -> Entity _ ExternalExam{..}) = do + guardM . hasReadAccessTo $ EExamR externalExamTerm externalExamSchool externalExamCourseName externalExamExamName EEShowR + return x + dbtColonnade = widgetColonnade $ mconcat + [ sortable (Just "term") (i18nCell MsgTerm) $ \(view resultEExam -> Entity _ ExternalExam{..}) -> i18nCell . ShortTermIdentifier $ unTermKey externalExamTerm + , sortable (Just "school") (i18nCell MsgSchool) $ \(view resultSchool -> Entity _ School{..}) -> i18nCell schoolName + , sortable (Just "course") (i18nCell MsgCourse) $ \(view resultEExam -> Entity _ ExternalExam{..}) -> i18nCell externalExamCourseName + , sortable (Just "name") (i18nCell MsgExamName) $ \(view resultEExam -> Entity _ ExternalExam{..}) -> anchorCell (EExamR externalExamTerm externalExamSchool externalExamCourseName externalExamExamName EEShowR) externalExamExamName + ] + dbtSorting = Map.fromList + [ ("term", SortColumn $ queryEExam >>> (E.^. ExternalExamTerm)) + , ("school", SortColumn $ querySchool >>> (E.^. SchoolName)) + , ("course", SortColumn $ queryEExam >>> (E.^. ExternalExamCourseName)) + , ("name", SortColumn $ queryEExam >>> (E.^. ExternalExamExamName)) + ] + dbtFilter = Map.empty + dbtFilterUI = const mempty + dbtStyle = def + dbtParams = def + dbtIdent :: Text + dbtIdent = "external-exams" + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + examDBTableValidator = def + & defaultSorting [SortDescBy "term", SortAscBy "school", SortAscBy "course", SortAscBy "name"] + + examTable <- runDB $ dbTableWidget' examDBTableValidator examDBTable + + let heading = MsgMenuExternalExamList + + siteLayoutMsg heading $ do + setTitleI heading + examTable diff --git a/src/Handler/ExternalExam/Show.hs b/src/Handler/ExternalExam/Show.hs index 8189dcc5a..0945fbc23 100644 --- a/src/Handler/ExternalExam/Show.hs +++ b/src/Handler/ExternalExam/Show.hs @@ -4,6 +4,26 @@ module Handler.ExternalExam.Show import Import +import Handler.Utils + +import qualified Data.CaseInsensitive as CI + getEEShowR :: TermId -> SchoolId -> CourseName -> ExamName -> Handler Html -getEEShowR = error "Not implemented" +getEEShowR tid ssh coursen examn = do + mUid <- maybeAuthId + + (Entity _ ExternalExam{..}, fmap entityVal -> mResult, School{..}) <- runDB $ do + exam@(Entity eeId ExternalExam{..}) <- getBy404 $ UniqueExternalExam tid ssh coursen examn + school <- getJust externalExamSchool + + mResult <- fmap join . for mUid $ getBy . UniqueExternalExamResult eeId + + return (exam, mResult, school) + + let heading = CI.original examn + + siteLayoutMsg heading $ do + setTitleI heading + + $(widgetFile "external-exam-show") diff --git a/src/Handler/ExternalExam/StaffInvite.hs b/src/Handler/ExternalExam/StaffInvite.hs new file mode 100644 index 000000000..e4ebfb056 --- /dev/null +++ b/src/Handler/ExternalExam/StaffInvite.hs @@ -0,0 +1,74 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Handler.ExternalExam.StaffInvite + ( externalExamStaffInvitationConfig + , getEEStaffInviteR, postEEStaffInviteR + , InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..) + ) where + +import Import + +import Handler.Utils.Invitations + +import Text.Hamlet (ihamlet) +import Data.Aeson hiding (Result(..)) + + +instance IsInvitableJunction ExternalExamStaff where + type InvitationFor ExternalExamStaff = ExternalExam + data InvitableJunction ExternalExamStaff = JunctionExternalExamStaff + deriving (Eq, Ord, Read, Show, Generic, Typeable) + data InvitationDBData ExternalExamStaff = InvDBDataExternalExamStaff + deriving (Eq, Ord, Read, Show, Generic, Typeable) + data InvitationTokenData ExternalExamStaff = InvTokenDataExternalExamStaff + deriving (Eq, Ord, Read, Show, Generic, Typeable) + + _InvitableJunction = iso + (\ExternalExamStaff{..} -> (externalExamStaffUser, externalExamStaffExam, JunctionExternalExamStaff)) + (\(externalExamStaffUser, externalExamStaffExam, JunctionExternalExamStaff{}) -> ExternalExamStaff{..}) + +instance ToJSON (InvitableJunction ExternalExamStaff) where + toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 } + toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 1 } +instance FromJSON (InvitableJunction ExternalExamStaff) where + parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 } + +instance ToJSON (InvitationDBData ExternalExamStaff) where + toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } + toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 } +instance FromJSON (InvitationDBData ExternalExamStaff) where + parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } + +instance ToJSON (InvitationTokenData ExternalExamStaff) where + toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } + toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 } +instance FromJSON (InvitationTokenData ExternalExamStaff) where + parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } + +externalExamStaffInvitationConfig :: InvitationConfig ExternalExamStaff +externalExamStaffInvitationConfig = InvitationConfig{..} + where + invitationRoute (Entity _ ExternalExam{..}) _ = return $ EExamR externalExamTerm externalExamSchool externalExamCourseName externalExamExamName EEStaffInviteR + invitationResolveFor _ = do + cRoute <- getCurrentRoute + case cRoute of + Just (EExamR tid ssh coursen examn EEStaffInviteR) -> + getKeyBy404 $ UniqueExternalExam tid ssh coursen examn + _other -> error "externalExamStaffInvitationConfig called from unsupported route" + invitationSubject (Entity _ ExternalExam{..}) _ = return . SomeMessage $ MsgMailSubjectExternalExamStaffInvitation externalExamCourseName externalExamExamName + invitationHeading (Entity _ ExternalExam{..}) _ = return . SomeMessage $ MsgExternalExamStaffInviteHeading externalExamCourseName externalExamExamName + invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExternalExamStaffInviteExplanation}|] + invitationTokenConfig _ _ = do + itAuthority <- Right <$> liftHandler requireAuthId + return $ InvitationTokenConfig itAuthority Nothing (Just Nothing) Nothing + invitationRestriction _ _ = return Authorized + invitationForm _ (InvDBDataExternalExamStaff, _) _ = pure (JunctionExternalExamStaff, ()) + invitationInsertHook _ _ _ _ = id + invitationSuccessMsg (Entity _ ExternalExam{..}) (Entity _ ExternalExamStaff{}) + = return . SomeMessage $ MsgExternalExamStaffInvitationAccepted externalExamCourseName externalExamExamName + invitationUltDest (Entity _ ExternalExam{..}) _ = return . SomeRoute $ EExamR externalExamTerm externalExamSchool externalExamCourseName externalExamExamName EEShowR + + +getEEStaffInviteR, postEEStaffInviteR :: TermId -> SchoolId -> CourseName -> ExamName -> Handler Html +getEEStaffInviteR = postEEStaffInviteR +postEEStaffInviteR = invitationR externalExamStaffInvitationConfig diff --git a/templates/external-exam-show.hamlet b/templates/external-exam-show.hamlet new file mode 100644 index 000000000..48707d0a0 --- /dev/null +++ b/templates/external-exam-show.hamlet @@ -0,0 +1,41 @@ +$newline never +$maybe ExternalExamResult{externalExamResultResult} <- mResult +
+

+ _{MsgExamResult} + +

+ $case externalExamResultResult + $of ExamAttended grade + $if externalExamShowGrades + _{grade} + $else + $if view (passingGrade . _Wrapped) grade + _{MsgExamPassed} + $else + _{MsgExamNotPassed} + $of ExamNoShow + _{MsgExamNoShow} + $of ExamVoided + _{MsgExamVoided} + +

+
+
_{MsgTerm} +
+ _{unTermKey externalExamTerm} +
_{MsgCourseSchool} +
+ #{schoolName} +
_{MsgCourseName} +
+ #{externalExamCourseName} +
_{MsgExamName} +
+ #{externalExamExamName} + $maybe examTime <- fmap externalExamResultTime mResult <|> externalExamDefaultTime +
+ _{MsgExamTime} +
+ ^{formatTimeW SelFormatDateTime examTime} +