fix(exams): make examClosed a button

Show examFinished and examClosed to ExamOffice
Mark not-yet-closed exams for ExamOffice

messages/uniworx/de.msg

@@ -1321,9 +1321,10 @@ ExamPublishOccurrenceAssignments: Termin- bzw. Raumzuteilung den Teilnehmern mit
 ExamPublishOccurrenceAssignmentsTip: Ab diesem Zeitpunkt Teilnehmer einsehen zu welcher Teilprüfung bzw. welchen Raum sie angemeldet sind
 ExamPublishOccurrenceAssignmentsParticipant: Termin- bzw. Raumzuteilung einsehbar ab
 ExamFinished: Bewertung abgeschlossen ab
+ExamFinishedOffice: Noten bekannt gegeben
 ExamFinishedParticipant: Bewertung vorrausichtlich abgeschlossen
 ExamFinishedTip: Zeitpunkt zu dem Prüfungergebnisse den Teilnehmern gemeldet werden
-ExamClosed: Noten stehen fest ab
+ExamClosed: Noten gemeldet
 ExamClosedTip: Prüfungsämter, die im System Noten einsehen, werden zu diesem Zeitpunkt benachrichtigt und danach bei Änderungen informiert
 ExamShowGrades: Klausur ist benotet
 ExamShowGradesTip: Sollen genaue Noten angezeigt werden, oder sollen Teilnehmer und Prüfungsämter nur informiert werden, ob die Klausur bestanden wurde?
@@ -1746,3 +1747,10 @@ MailIntroChangeUserDisplayEmail displayEmail@UserEmail: Der oben genannte Benutz
 MailTitleChangeUserDisplayEmail displayName@Text: #{displayName} möchte diese E-Mail Adresse in Uni2work veröffentlichen
 
 ExamOfficeOptOutsChanged: Zuständige Prüfungsämter erfolgreich angepasst
+
+BtnCloseExam: Klausur abschließen
+ExamCloseTip: Wenn eine Klausur abgeschlossen wird, werden Prüfungsämter, die im System Noten einsehen, benachrichtigt und danach bei Änderungen informiert.
+ExamCloseReminder: Bitte schließen Sie die Klausur frühstmöglich, sobald die Prüfungsleistungen sich voraussichtlich nicht mehr ändern werden. Z.B. direkt nach der Klausureinsicht.
+ExamDidClose: Klausur erfolgreich abgeschlossen
+
+ExamClosedSince time@Text: Klausur abgeschlossen seit #{time}

src/Handler/Exam/Edit.hs

@@ -18,12 +18,12 @@ import Jobs.Queue
 getEEditR, postEEditR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
 getEEditR = postEEditR
 postEEditR tid ssh csh examn = do
-  (cid, eId, template) <- runDB $ do
+  (cid, Entity eId oldExam, template) <- runDB $ do
-    (cid, exam@(Entity eId _)) <- fetchCourseIdExam tid ssh csh examn
+    (cid, exam) <- fetchCourseIdExam tid ssh csh examn
 
     template <- examFormTemplate exam
 
-    return (cid, eId, template)
+    return (cid, exam, template)
 
   ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm validateExam . examForm $ Just template
 
@@ -43,7 +43,7 @@ postEEditR tid ssh csh examn = do
         , examStart            = efStart
         , examEnd              = efEnd
         , examFinished         = efFinished
-        , examClosed           = efClosed
+        , examClosed           = examClosed oldExam
         , examPublicStatistics = efPublicStatistics
         , examShowGrades       = efShowGrades
         , examDescription      = efDescription

src/Handler/Exam/Form.hs

@@ -34,7 +34,6 @@ data ExamForm = ExamForm
   , efDeregisterUntil :: Maybe UTCTime
   , efPublishOccurrenceAssignments :: Maybe UTCTime
   , efFinished :: Maybe UTCTime
-  , efClosed :: Maybe UTCTime
   , efOccurrences :: Set ExamOccurrenceForm
   , efShowGrades :: Bool
   , efPublicStatistics :: Bool
@@ -89,12 +88,11 @@ examForm template html = do
     <*> aopt utcTimeField (fslpI MsgExamDeregisterUntil (mr MsgDate)) (efDeregisterUntil <$> template)
     <*> aopt utcTimeField (fslpI MsgExamPublishOccurrenceAssignments (mr MsgDate) & setTooltip MsgExamPublishOccurrenceAssignmentsTip) (efPublishOccurrenceAssignments <$> template)
     <*> aopt utcTimeField (fslpI MsgExamFinished (mr MsgDate) & setTooltip MsgExamFinishedTip) (efFinished <$> template)
-    <*> aopt utcTimeField (fslpI MsgExamClosed (mr MsgDate) & setTooltip MsgExamClosedTip) (efClosed <$> template)
     <*  aformSection MsgExamFormOccurrences
     <*> examOccurrenceForm (efOccurrences <$> template)
     <*  aformSection MsgExamFormAutomaticFunctions
-    <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamShowGrades & setTooltip MsgExamShowGradesTip) (Just . efShowGrades <$> template))
+    <*> apopt checkBoxField (fslI MsgExamShowGrades & setTooltip MsgExamShowGradesTip) (efShowGrades <$> template <|> Just True)
-    <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (Just . efPublicStatistics <$> template))
+    <*> apopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (efPublicStatistics <$> template <|> Just True)
     <*> examGradingRuleForm (efGradingRule <$> template)
     <*> examBonusRuleForm (efBonusRule <$> template)
     <*> examOccurrenceRuleForm (efOccurrenceRule <$> template)
@@ -250,7 +248,6 @@ examFormTemplate (Entity eId Exam{..}) = do
     , efStart            = examStart
     , efEnd              = examEnd
     , efFinished         = examFinished
-    , efClosed           = examClosed
     , efShowGrades       = examShowGrades
     , efPublicStatistics = examPublicStatistics
     , efDescription      = examDescription
@@ -318,7 +315,6 @@ examTemplate cid = runMaybeT $ do
     , efStart            = dateOffset <$> examStart oldExam
     , efEnd              = dateOffset <$> examEnd oldExam
     , efFinished         = dateOffset <$> examFinished oldExam
-    , efClosed           = dateOffset <$> examClosed oldExam
     , efShowGrades       = examShowGrades oldExam
     , efPublicStatistics = examPublicStatistics oldExam
     , efDescription      = examDescription oldExam
@@ -338,9 +334,6 @@ validateExam = do
   guardValidation MsgExamEndMustBeAfterStart                               $ NTop efEnd                          >= NTop efStart
   guardValidation MsgExamFinishedMustBeAfterEnd                            . fromMaybe True $ (>=) <$> efFinished <*> efEnd
   guardValidation MsgExamFinishedMustBeAfterStart                          $ NTop efFinished                     >= NTop efStart
-  guardValidation MsgExamClosedMustBeAfterFinished                         . fromMaybe True $ (>=) <$> efClosed <*> efFinished
-  guardValidation MsgExamClosedMustBeAfterStart                            $ NTop efClosed                       >= NTop efStart
-  guardValidation MsgExamClosedMustBeAfterEnd                              . fromMaybe True $ (>=) <$> efClosed <*> efEnd
 
   forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
     guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName)       $ NTop eofEnd >= NTop (Just eofStart)

src/Handler/Exam/New.hs

@@ -40,7 +40,7 @@ postCExamNewR tid ssh csh = do
         , examStart                        = efStart
         , examEnd                          = efEnd
         , examFinished                     = efFinished
-        , examClosed                       = efClosed
+        , examClosed                       = Nothing
         , examShowGrades                   = efShowGrades
         , examPublicStatistics             = efPublicStatistics
         , examDescription                  = efDescription

src/Handler/Exam/Users.hs

@@ -10,6 +10,8 @@ import Handler.Utils
 import Handler.Utils.Exam
 import Handler.Utils.Csv
 
+import Handler.ExamOffice.Exam (examCloseWidget)
+
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
@@ -228,7 +230,7 @@ embedRenderMessage ''UniWorX ''ExamUserCsvException id
 getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
 getEUsersR = postEUsersR
 postEUsersR tid ssh csh examn = do
-  (registrationResult, examUsersTable) <- runDB $ do
+  ((registrationResult, examUsersTable), Entity eId _) <- runDB $ do
     exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn
     bonus <- examBonus exam
 
@@ -654,7 +656,7 @@ postEUsersR tid ssh csh examn = do
         (First (Just act), regMap) <- inp
         let regSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) regMap
         return (act, regSet)
-    over _1 postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable
+    (, exam) . over _1 postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable
 
   formResult registrationResult $ \case
     (ExamUserDeregisterData, selectedRegistrations) -> do
@@ -672,6 +674,8 @@ postEUsersR tid ssh csh examn = do
       addMessageI Success $ MsgExamUsersOccurrenceUpdated nrUpdated
       redirect $ CExamR tid ssh csh examn EUsersR
 
+  closeWgt <- examCloseWidget (SomeRoute $ CExamR tid ssh csh examn EUsersR) eId
+
   siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do
     setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading
     $(widgetFile "exam-users")

src/Handler/ExamOffice/Exam.hs

@@ -1,5 +1,6 @@
 module Handler.ExamOffice.Exam
   ( getEGradesR, postEGradesR
+  , examCloseWidget
   ) where
 
 import Import
@@ -20,6 +21,46 @@ import qualified Data.Conduit.List as C
 import qualified Colonnade
 
 
+data ButtonCloseExam = BtnCloseExam
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonCloseExam
+instance Finite ButtonCloseExam
+
+nullaryPathPiece ''ButtonCloseExam $ camelToPathPiece' 1
+
+embedRenderMessage ''UniWorX ''ButtonCloseExam id
+instance Button UniWorX ButtonCloseExam where
+  btnClasses BtnCloseExam = [BCIsButton]
+
+  
+examCloseWidget :: SomeRoute UniWorX -> ExamId -> Handler Widget
+examCloseWidget dest eId = do
+  Exam{..} <- runDB $ get404 eId
+
+  ((closeRes, closeView), closeEnc) <- runFormPost $ identifyForm BtnCloseExam buttonForm
+
+  formResult closeRes $ \case
+    BtnCloseExam -> do
+      now <- liftIO getCurrentTime
+
+      unless (is _Nothing examClosed) $
+        invalidArgs ["Exam is already closed"]
+  
+      runDB $ update eId [ ExamClosed =. Just now ]
+      addMessageI Success MsgExamDidClose
+      redirect dest
+
+  let closeView' = wrapForm closeView def
+        { formSubmit   = FormNoSubmit
+        , formAction   = Just dest
+        , formEncoding = closeEnc
+        }
+
+  examClosed' <- for examClosed $ formatTime SelFormatDateTime
+
+  return $(widgetFile "widgets/exam-close")
+
+
 type ExamUserTableExpr = (              E.SqlExpr (Entity ExamResult)
                           `E.InnerJoin` E.SqlExpr (Entity User)
                          )
@@ -153,8 +194,8 @@ getEGradesR = postEGradesR
 postEGradesR tid ssh csh examn = do
   uid <- requireAuthId
   now <- liftIO getCurrentTime
-  (usersResult, examUsersTable) <- runDB $ do
+  ((usersResult, examUsersTable), Entity eId _) <- runDB $ do
-    Entity eid Exam{..} <- fetchExam tid ssh csh examn
+    exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn
 
     csvName <- getMessageRender <*> pure (MsgExamUserCsvName tid ssh csh examn)
     isLecturer <- hasReadAccessTo $ CExamR tid ssh csh examn EUsersR
@@ -387,10 +428,12 @@ postEGradesR tid ssh csh examn = do
           addMessageI Success $ MsgExamUserMarkedSynchronised (length selectedResults)
           redirect $ CExamR tid ssh csh examn EGradesR
 
-    return (usersResult', examUsersTable)
+    return ((usersResult', examUsersTable), exam)
 
   whenIsJust usersResult join
 
+  closeWgt <- examCloseWidget (SomeRoute $ CExamR tid ssh csh examn EGradesR) eId
+
   siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamOfficeExamUsersHeading) $ do
     setTitleI $ prependCourseTitle tid ssh csh MsgExamOfficeExamUsersHeading
     $(widgetFile "exam-office/exam-results")

src/Handler/ExamOffice/Exams.hs

@@ -48,15 +48,16 @@ queryResults office = to . runReader $ do
       return E.countRows
   return results
 
-queryIsSynced :: E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Bool))
+queryIsSynced :: UTCTime -> E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Bool))
-queryIsSynced office = to . runReader $ do
+queryIsSynced now 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_ $ Exam.examOfficeExamResultAuth office examResult
       E.where_ . E.not_ $ Exam.resultIsSynced office examResult
-  return synchronised
+    open = E.maybe E.true (E.>. E.val now) $ exam E.^. ExamClosed
+  return $ synchronised E.||. open
 
 
 resultExam :: Lens' ExamsTableData (Entity Exam)
@@ -78,6 +79,7 @@ resultIsSynced = to $ (>=) <$> view resultSynchronised <*> view resultResults
 getEOExamsR :: Handler Html
 getEOExamsR = do
   uid <- requireAuthId
+  now <- liftIO getCurrentTime
 
   examsTable <- runDB $ do
     let
@@ -91,7 +93,7 @@ getEOExamsR = do
 
       querySynchronised' = querySynchronised $ E.val uid
       queryResults' = queryResults $ E.val uid
-      queryIsSynced' = queryIsSynced $ E.val uid
+      queryIsSynced' = queryIsSynced now $ E.val uid
 
       examsDBTable = DBTable{..}
         where
@@ -122,21 +124,28 @@ getEOExamsR = do
 
 
           colSynced = Colonnade.singleton (fromSortable . Sortable (Just "synced") $ i18nCell MsgExamSynchronised) $ \x -> flip runReader x $ do
-            synced <- view resultSynchronised
+            Entity _ Exam{examClosed} <- view resultExam
-            results <- view resultResults
-            isSynced <- view resultIsSynced
 
-            return $ cell
+            if
-              [whamlet|
+              | NTop examClosed > NTop (Just now)
-                $newline never
+                -> return . cell $ toWidget iconNew
-                $if isSynced
+              | otherwise
-                  #{iconOK}
+                -> do
-                $else
+                  synced <- view resultSynchronised
-                  #{synced}/#{results}
+                  results <- view resultResults
-              |]
+                  isSynced <- view resultIsSynced
-              & cellAttrs <>~ [ ("class", "heated")
+
-                              , ("style", [st|--hotness: #{tshow (heat results synced)}|])
+                  return $ cell
-                              ]
+                     [whamlet|
+                       $newline never
+                       $if isSynced
+                         #{iconOK}
+                       $else
+                         #{synced}/#{results}
+                     |]
+                     & cellAttrs <>~ [ ("class", "heated")
+                                     , ("style", [st|--hotness: #{tshow (heat results synced)}|])
+                                     ]
         
 
           dbtColonnade :: Colonnade Sortable _ _
@@ -145,6 +154,8 @@ getEOExamsR = do
             , anchorColonnade (views ($(multifocusG 2) (resultCourse . _entityVal) (resultExam . _entityVal)) (uncurry examLink))
                 $ colExamName (resultExam . _entityVal . _examName)
             , colExamTime (resultExam . _entityVal . $(multifocusG 2) _examStart _examEnd)
+            , colExamFinishedOffice (resultExam . _entityVal . _examFinished)
+            , colExamClosed (resultExam . _entityVal . _examClosed)
             , anchorColonnade (views (resultCourse . _entityVal) courseLink)
                 $ colCourseName (resultCourse . _entityVal . _courseName)
             , colSchool (resultCourse . _entityVal . _courseSchool)
@@ -155,6 +166,8 @@ getEOExamsR = do
             , singletonMap "is-synced" . SortColumn $ view queryIsSynced'
             , sortExamName (queryExam . to (E.^. ExamName))
             , sortExamTime (queryExam . $(multifocusG 2) (to (E.^. ExamStart)) (to (E.^. ExamEnd)))
+            , sortExamFinished (queryExam . to (E.^. ExamFinished))
+            , sortExamClosed (queryExam . to (E.^. ExamClosed))
             , sortCourseName (queryCourse . to (E.^. CourseName))
             , sortSchool (queryCourse . to (E.^. CourseSchool))
             , sortTerm (queryCourse . to (E.^. CourseTerm))

src/Handler/Utils/Table/Columns.hs

@@ -227,6 +227,30 @@ colExamTime resultTimes = Colonnade.singleton (fromSortable header) body
 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
 
+colExamClosed :: OpticColonnade (Maybe UTCTime)
+colExamClosed resultClosed = Colonnade.singleton (fromSortable header) body
+  where
+    header = Sortable (Just "exam-closed") (i18nCell MsgExamClosed)
+    body = views resultClosed $ maybe mempty (cell . formatTimeW SelFormatDateTime)
+
+sortExamClosed :: OpticSortColumn (Maybe UTCTime)
+sortExamClosed queryClosed = singletonMap "exam-closed" . SortColumn $ view queryClosed
+
+colExamFinished :: OpticColonnade (Maybe UTCTime)
+colExamFinished resultFinished = Colonnade.singleton (fromSortable header) body
+  where
+    header = Sortable (Just "exam-finished") (i18nCell MsgExamFinished)
+    body = views resultFinished $ maybe mempty (cell . formatTimeW SelFormatDateTime)
+
+colExamFinishedOffice :: OpticColonnade (Maybe UTCTime)
+colExamFinishedOffice resultFinished = Colonnade.singleton (fromSortable header) body
+  where
+    header = Sortable (Just "exam-finished") (i18nCell MsgExamFinishedOffice)
+    body = views resultFinished $ maybe mempty (cell . formatTimeW SelFormatDateTime)
+
+sortExamFinished :: OpticSortColumn (Maybe UTCTime)
+sortExamFinished queryFinished = singletonMap "exam-finished" . SortColumn $ view queryFinished
+
 ---------------------
 -- Exam occurences --
 ---------------------

templates/exam-office/exam-results.hamlet

@@ -1,2 +1,5 @@
 $newline never
-^{examUsersTable}
+<section>
+  ^{closeWgt}
+<section>
+  ^{examUsersTable}

templates/exam-show.hamlet

@@ -55,6 +55,9 @@ $maybe desc <- examDescription
     $maybe finished <- examFinished
       <dt .deflist__dt>_{MsgExamFinishedParticipant}
       <dd .deflist__dd>^{formatTimeW SelFormatDateTime finished}
+    $maybe closed <- examClosed
+      <dt .deflist__dt>_{MsgExamClosed}
+      <dd .deflist__dd>^{formatTimeW SelFormatDateTime closed}
     $if gradingShown
       $if examGradingRule /= ExamGradingManual
         <dt .deflist__dt>

templates/exam-users.hamlet

@@ -1,2 +1,5 @@
 $newline never
-^{examUsersTable}
+<section>
+  ^{closeWgt}
+<section>
+  ^{examUsersTable}

templates/widgets/exam-close.hamlet

@@ -0,0 +1,9 @@
+$newline never
+$maybe closed <- examClosed'
+  _{MsgExamClosedSince closed}
+$nothing
+  <p>
+    _{MsgExamCloseTip}
+  <p>
+    _{MsgExamCloseReminder}
+  ^{closeView'}