feat(external-exams): list

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

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

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

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
 

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

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

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")

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

templates/external-exam-show.hamlet

@@ -0,0 +1,41 @@
+$newline never
+$maybe ExternalExamResult{externalExamResultResult} <- mResult
+  <section>
+    <h2>
+      _{MsgExamResult}
+
+    <p .result>
+      $case externalExamResultResult
+        $of ExamAttended grade
+          $if externalExamShowGrades
+            _{grade}
+          $else
+            $if view (passingGrade . _Wrapped) grade
+              _{MsgExamPassed}
+            $else
+              _{MsgExamNotPassed}
+        $of ExamNoShow
+          _{MsgExamNoShow}
+        $of ExamVoided
+          _{MsgExamVoided}
+    
+<section>
+  <dl .deflist>
+    <dt .deflist__dt>_{MsgTerm}
+    <dd .deflist__dd>
+      _{unTermKey externalExamTerm}
+    <dt .deflist__dt>_{MsgCourseSchool}
+    <dd .deflist__dd>
+      #{schoolName}
+    <dt .deflist__dt>_{MsgCourseName}
+    <dd .deflist__dd>
+      #{externalExamCourseName}
+    <dt .deflist__dt>_{MsgExamName}
+    <dd .deflist__dd>
+      #{externalExamExamName}
+    $maybe examTime <- fmap externalExamResultTime mResult <|> externalExamDefaultTime
+      <dt .deflist__dt>
+        _{MsgExamTime}
+      <dd .deflist__dd>
+        ^{formatTimeW SelFormatDateTime examTime}
+