feat(exam-office): exams list

messages/uniworx/de.msg

@@ -1400,6 +1400,8 @@ VersionHistory: Versionsgeschichte
 KnownBugs: Bekannte Bugs
 ImplementationDetails: Implementierung
 
+ExamSynchronised: Synchronisiert
+
 ExamUsersHeading: Prüfungsteilnehmer
 ExamUserDeregister: Teilnehmer von Prüfung abmelden
 ExamUserAssignOccurrence: Termin/Raum zuweisen

src/Handler/Corrections.hs

@@ -1265,10 +1265,6 @@ assignHandler tid ssh csh cid assignSids = do
       showAvgsDays :: Maybe NominalDiffTime -> Integer -> Text
       showAvgsDays Nothing   _ = mempty
       showAvgsDays (Just dt) n = formatDiffDays $ dt / fromIntegral n
-      heat :: Integer -> Integer -> Double
-      heat = heat' 0.3
-      heat' :: Double -> Integer -> Integer -> Double
-      heat' cut full achieved = roundToDigits 3 $ cutOffPercent cut (fromIntegral full^2) (fromIntegral achieved^2)
   let headingShort
         | 0 < Map.size assignment = MsgMenuCorrectionsAssignSheet $ Text.intercalate ", " $ fmap CI.original $ Map.keys assignment
         | otherwise               = MsgMenuCorrectionsAssign

src/Handler/ExamOffice/Exams.hs

@@ -4,7 +4,183 @@ module Handler.ExamOffice.Exams
 
 import Import
 
+import Handler.Utils
+import Handler.Utils.ExamOffice.Exam.Auth
+import qualified Handler.Utils.ExamOffice.Exam as Exam
+
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
+
+import qualified Colonnade
+
+
+type ExamsTableExpr = E.SqlExpr (Entity Exam)
+        `E.InnerJoin` E.SqlExpr (Entity Course)
+
+type ExamsTableData = DBRow ( Entity Exam
+                            , Entity Course
+                            , Natural, Natural
+                            )
+
+queryExam :: Getter ExamsTableExpr (E.SqlExpr (Entity Exam))
+queryExam = to $(E.sqlIJproj 2 1)
+
+queryCourse :: Getter ExamsTableExpr (E.SqlExpr (Entity Course))
+queryCourse = to $(E.sqlIJproj 2 2)
+
+querySynchronised :: E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Natural))
+querySynchronised office = to . runReader $ do
+  exam <- view queryExam
+  let
+    synchronised = E.sub_select . E.from $ \examResult -> do
+      E.where_ $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
+      E.where_ $ examOfficeExamResultAuth office examResult
+      E.where_ $ Exam.resultIsSynced office examResult
+      return E.countRows
+  return synchronised
+  
+queryResults :: E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Natural))
+queryResults office = to . runReader $ do
+  exam <- view queryExam
+  let
+    results = E.sub_select . E.from $ \examResult -> do
+      E.where_ $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
+      E.where_ $ examOfficeExamResultAuth office examResult
+      return E.countRows
+  return results
+
+queryIsSynced :: E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Bool))
+queryIsSynced office = to . runReader $ do
+  exam <- view queryExam
+  let
+    synchronised = E.not_ . E.exists . E.from $ \examResult -> do
+      E.where_ $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
+      E.where_ $ examOfficeExamResultAuth office examResult
+      E.where_ . E.not_ $ Exam.resultIsSynced office examResult
+  return synchronised
+
+
+resultExam :: Lens' ExamsTableData (Entity Exam)
+resultExam = _dbrOutput . _1
+
+resultCourse :: Lens' ExamsTableData (Entity Course)
+resultCourse = _dbrOutput . _2
+
+resultSynchronised, resultResults :: Lens' ExamsTableData Natural
+resultSynchronised = _dbrOutput . _3
+resultResults = _dbrOutput . _4
+
+resultIsSynced :: Getter ExamsTableData Bool
+resultIsSynced = to $ (>=) <$> view resultSynchronised <*> view resultResults
+
+  
 -- | List of all exams where the current user may (in her function as
 --   exam-office) access users grades
 getEOExamsR :: Handler Html
-getEOExamsR = fail "not implemented"
+getEOExamsR = do
+  uid <- requireAuthId
+
+  examsTable <- runDB $ do
+    let
+      examLink :: Course -> Exam -> SomeRoute UniWorX
+      examLink Course{..} Exam{..} 
+        = SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName EGradesR
+
+      courseLink :: Course -> SomeRoute UniWorX
+      courseLink Course{..}
+        = SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
+
+      querySynchronised' = querySynchronised $ E.val uid
+      queryResults' = queryResults $ E.val uid
+      queryIsSynced' = queryIsSynced $ E.val uid
+
+      examsDBTable = DBTable{..}
+        where
+          dbtSQLQuery = runReaderT $ do
+            exam <- view queryExam
+            course <- view queryCourse
+
+            synchronised <- view querySynchronised'
+            results <- view queryResults'
+
+            lift $ do
+              E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId
+
+              E.where_ $ results E.>. E.val 0
+
+            return (exam, course, synchronised, results)
+          dbtRowKey = views queryExam (E.^. ExamId)
+
+          dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) ExamsTableData
+          dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do
+            exam <- view $ _1 . _entityVal
+            course <- view $ _2 . _entityVal
+
+            guard =<< hasReadAccessTo (urlRoute $ examLink course exam)
+    
+            (,,,)
+              <$> view _1 <*> view _2 <*> view (_3 . _Value) <*> view (_4 . _Value)
+
+
+          colSynced = Colonnade.singleton (fromSortable . Sortable (Just "synced") $ i18nCell MsgExamSynchronised) $ \x -> flip runReader x $ do
+            synced <- view resultSynchronised
+            results <- view resultResults
+            isSynced <- view resultIsSynced
+
+            return $ cell
+              [whamlet|
+                $newline never
+                $if isSynced
+                  #{iconOK}
+                $else
+                  #{synced}/#{results}
+              |]
+              & cellAttrs <>~ [ ("class", "heated")
+                              , ("style", [st|--hotness: #{tshow (heat results synced)}|])
+                              ]
+        
+
+          dbtColonnade :: Colonnade Sortable _ _
+          dbtColonnade = mconcat
+            [ colSynced
+            , anchorColonnade (views ($(multifocusG 2) (resultCourse . _entityVal) (resultExam . _entityVal)) (uncurry examLink))
+                $ colExamName (resultExam . _entityVal . _examName)
+            , colExamTime (resultExam . _entityVal . $(multifocusG 2) _examStart _examEnd)
+            , anchorColonnade (views (resultCourse . _entityVal) courseLink)
+                $ colCourseName (resultCourse . _entityVal . _courseName)
+            , colSchool (resultCourse . _entityVal . _courseSchool)
+            , colTermShort (resultCourse . _entityVal . _courseTerm)
+            ]
+          dbtSorting = mconcat
+            [ singletonMap "synced" . SortColumn $ (E./.) <$> view querySynchronised' <*> view queryResults'
+            , singletonMap "is-synced" . SortColumn $ view queryIsSynced'
+            , sortExamName (queryExam . to (E.^. ExamName))
+            , sortExamTime (queryExam . $(multifocusG 2) (to (E.^. ExamStart)) (to (E.^. ExamEnd)))
+            , sortCourseName (queryCourse . to (E.^. CourseName))
+            , sortSchool (queryCourse . to (E.^. CourseSchool))
+            , sortTerm (queryCourse . to (E.^. CourseTerm))
+            ]
+
+          dbtFilter = mconcat
+            [
+            ]
+          dbtFilterUI = mconcat
+            [
+            ]
+
+          dbtStyle = def -- { dbsFilterLayout = defaultDBSFilterLayout }
+          dbtParams = def
+
+          dbtIdent :: Text
+          dbtIdent = "exams"
+
+          dbtCsvEncode = noCsvEncode
+          dbtCsvDecode = Nothing
+
+      examsDBTableValidator = def & defaultSorting [SortAscBy "is-synced", SortAscBy "exam-time"]
+
+    dbTableWidget' examsDBTableValidator examsDBTable
+
+  siteLayoutMsg MsgMenuExamList $ do
+    setTitleI MsgMenuExamList
+    examsTable

src/Handler/Utils/Table/Columns.hs

@@ -19,6 +19,7 @@ import Handler.Utils.Table.Cells
 import Handler.Utils.Table.Pagination
 import Handler.Utils.Form
 import Handler.Utils.Widgets
+import Handler.Utils.DateTime
 
 import qualified Data.CaseInsensitive as CI
 
@@ -203,6 +204,29 @@ fltrAllocationActiveUI :: DBFilterUI
 fltrAllocationActiveUI mPrev = prismAForm (singletonFilter "active" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgAllocationActive)
 
 
+-----------
+-- Exams --
+-----------
+
+colExamName :: OpticColonnade ExamName
+colExamName resultName = Colonnade.singleton (fromSortable header) body
+  where
+    header = Sortable (Just "exam-name") (i18nCell MsgExamName)
+    body = views resultName i18nCell
+
+sortExamName :: OpticSortColumn ExamName
+sortExamName queryName = singletonMap "exam-name" . SortColumn $ view queryName
+
+colExamTime :: OpticColonnade (Maybe UTCTime, Maybe UTCTime)
+colExamTime resultTimes = Colonnade.singleton (fromSortable header) body
+  where
+    header = Sortable (Just "exam-time") (i18nCell MsgExamTime)
+    body = views resultTimes $ \(eStart, eEnd)
+      -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) eEnd) eStart
+
+sortExamTime :: OpticSortColumn' (E.SqlExpr (E.Value (Maybe UTCTime)), E.SqlExpr (E.Value (Maybe UTCTime)))
+sortExamTime queryTimes = singletonMap "exam-time" . SortColumns . toListOf $ queryTimes . _1 . to SomeExprValue <> queryTimes . _2 . to SomeExprValue
+  
 ---------------------
 -- Exam occurences --
 ---------------------
@@ -253,6 +277,19 @@ fltrExamResultPointsUI showGrades mPrev = prismAForm (singletonFilter "exam-resu
     field
       | showGrades = examResultField examGradeField
       | otherwise  = convertField (over _examResult $ review passingGrade) (over _examResult $ view passingGrade) $ examResultField examPassedField
+
+-------------
+-- Courses --
+-------------
+
+colCourseName :: OpticColonnade CourseName
+colCourseName resultName = Colonnade.singleton (fromSortable header) body
+  where
+    header = Sortable (Just "course-name") (i18nCell MsgCourse)
+    body = views resultName i18nCell
+
+sortCourseName :: OpticSortColumn CourseName
+sortCourseName queryName = singletonMap "course-name" . SortColumn $ view queryName
   
 -------------------------
 -- Course Applications --

src/Handler/Utils/Widgets.hs

@@ -92,3 +92,7 @@ editedByW :: SelDateTimeFormat -> UTCTime -> Text -> Widget
 editedByW fmt tm usr  = do
   ft <- handlerToWidget $ formatTime fmt tm
   [whamlet|_{MsgEditedBy usr ft}|]
+
+heat :: Integral a => a -> a -> Double
+heat (toInteger -> full) (toInteger -> achieved)
+  = roundToDigits 3 $ cutOffPercent 0.3 (fromIntegral full^2) (fromIntegral achieved^2)

src/Utils/Lens.hs

@@ -170,6 +170,7 @@ makeLenses_ ''ExamResult
 
 makeLenses_ ''UTCTime
 
+makeLenses_ ''Exam
 makeLenses_ ''ExamOccurrence
 
 makePrisms ''AuthenticationMode
@@ -189,7 +190,7 @@ makeLenses_ ''School
 makeLenses_ ''SchoolLdap
 
 makeLenses_ ''UserFunction
-
+  
 
 -- makeClassy_ ''Load