fix(exam-office): better logic for isSynced

models/exam-office

@@ -8,7 +8,7 @@ ExamOfficeUser
     user    UserId
     UniqueExamOfficeUser office user
 ExamOfficeResultSynced
+    school  SchoolId Maybe
     office  UserId
     result  ExamResultId
-    time    UTCTime
+    time    UTCTime
-    UniqueExamOfficeResultSynced office result

src/Handler/ExamOffice/Exam.hs

@@ -6,6 +6,7 @@ import Import
 import Handler.Utils
 import Handler.Utils.Exam
 import Handler.Utils.Csv
+import qualified Handler.Utils.ExamOffice.Exam as Exam
 import Handler.Utils.ExamOffice.Exam.Auth
 
 import qualified Database.Esqueleto as E
@@ -38,6 +39,7 @@ type ExamUserTableData = DBRow ( Entity ExamResult
                                , Maybe (Entity StudyDegree)
                                , Maybe (Entity StudyTerms)
                                , Maybe (Entity ExamRegistration)
+                               , Bool
                                , [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
                                )
 
@@ -68,14 +70,8 @@ queryExamResult = to $ $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 4 1)
 -- resultExamRegistration :: Traversal' ExamUserTableData (Entity ExamRegistration)
 -- resultExamRegistration = _dbrOutput . _7 . _Just
 
-queryIsSynced :: Getter ExamUserTableExpr (E.SqlExpr (E.Value Bool))
+queryIsSynced :: E.SqlExpr (E.Value UserId) -> Getter ExamUserTableExpr (E.SqlExpr (E.Value Bool))
-queryIsSynced = to . runReader $ do
+queryIsSynced authId = to $ Exam.resultIsSynced authId <$> view queryExamResult
-  examResult <- view queryExamResult
-  let
-    lastSync = E.sub_select . E.from $ \examOfficeResultSynced -> do
-      E.where_ $ examOfficeResultSynced E.^. ExamOfficeResultSyncedResult E.==. examResult E.^. ExamResultId
-      return . E.max_ $ examOfficeResultSynced E.^. ExamOfficeResultSyncedTime
-  return $ E.maybe E.false (E.>=. examResult E.^. ExamResultLastChanged) lastSync
 
 resultUser :: Lens' ExamUserTableData (Entity User)
 resultUser = _dbrOutput . _2
@@ -95,8 +91,11 @@ resultExamOccurrence = _dbrOutput . _3 . _Just
 resultExamResult :: Lens' ExamUserTableData (Entity ExamResult)
 resultExamResult = _dbrOutput . _1
 
+resultIsSynced :: Lens' ExamUserTableData Bool
+resultIsSynced = _dbrOutput . _8
+
 resultSynchronised :: Traversal' ExamUserTableData (UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)
-resultSynchronised = _dbrOutput . _8 . traverse
+resultSynchronised = _dbrOutput . _9 . traverse
 
 data ExamUserTableCsv = ExamUserTableCsv
   { csvEUserSurname :: Text
@@ -160,6 +159,7 @@ postEGradesR tid ssh csh examn = do
 
     csvName <- getMessageRender <*> pure (MsgExamUserCsvName tid ssh csh examn)
     isLecturer <- hasReadAccessTo $ CExamR tid ssh csh examn EUsersR
+    userFunctions <- selectList [ UserFunctionUser ==. uid, UserFunctionFunction ==. SchoolExamOffice ] []
 
     let
       participantLink :: MonadCrypto m => UserId -> m (SomeRoute UniWorX)
@@ -167,6 +167,26 @@ postEGradesR tid ssh csh examn = do
         cID <- encrypt partId
         return . SomeRoute . CourseR tid ssh csh $ CUserR cID
 
+      markSynced :: ExamResultId -> DB ()
+      markSynced resId
+        | null userFunctions =
+            insert_ ExamOfficeResultSynced
+              { examOfficeResultSyncedOffice = uid
+              , examOfficeResultSyncedResult = resId
+              , examOfficeResultSyncedTime   = now
+              , examOfficeResultSyncedSchool = Nothing
+              }
+        | otherwise =
+            insertMany_ [ ExamOfficeResultSynced
+                          { examOfficeResultSyncedOffice = uid
+                          , examOfficeResultSyncedResult = resId
+                          , examOfficeResultSyncedTime   = now
+                          , examOfficeResultSyncedSchool = Just userFunctionSchool
+                          }
+                        | Entity _ UserFunction{..} <- userFunctions
+                        ]
+
+
       examUsersDBTable = DBTable{..}
         where
           dbtSQLQuery = runReaderT $ do
@@ -179,6 +199,8 @@ postEGradesR tid ssh csh examn = do
             studyDegree <- view queryStudyDegree
             studyField <- view queryStudyField
 
+            isSynced <- view . queryIsSynced $ E.val uid
+
             lift $ do
               E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
               E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
@@ -196,33 +218,31 @@ postEGradesR tid ssh csh examn = do
               unless isLecturer $ 
                 E.where_ $ examOfficeExamResultAuth (E.val uid) examResult
 
-            return (examResult, user, occurrence, studyFeatures, studyDegree, studyField, examRegistration)
+            return (examResult, user, occurrence, studyFeatures, studyDegree, studyField, examRegistration, isSynced)
           dbtRowKey = views queryExamResult (E.^. ExamResultId)
 
           dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) ExamUserTableData
           dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
-            (,,,,,,,)
+            (,,,,,,,,)
-              <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5 <*> view _6 <*> view _7
+              <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5 <*> view _6 <*> view _7 <*> view (_8 . _Value)
               <*> getSynchronised
             where
               getSynchronised :: ReaderT _ (MaybeT (YesodDB UniWorX)) [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
               getSynchronised = do
                 resId <- view $ _1 . _entityKey
-                syncs <- lift . lift . E.select . E.from $ \((examOfficeResultSynced `E.InnerJoin` user) `E.LeftOuterJoin` userFunction) -> do
+                syncs <- lift . lift . E.select . E.from $ \(examOfficeResultSynced `E.InnerJoin` user) -> do
-                  E.on $ userFunction E.?. UserFunctionUser E.==. E.just (user E.^. UserId)
-                   E.&&. userFunction E.?. UserFunctionFunction E.==. E.just (E.val SchoolExamOffice)
                   E.on $ examOfficeResultSynced E.^. ExamOfficeResultSyncedOffice E.==. user E.^. UserId
                   E.where_ $ examOfficeResultSynced E.^. ExamOfficeResultSyncedResult E.==. E.val resId
                   return ( examOfficeResultSynced E.^. ExamOfficeResultSyncedOffice
                          , ( user E.^. UserDisplayName
                            , user E.^. UserSurname
                            , examOfficeResultSynced E.^. ExamOfficeResultSyncedTime
-                           , userFunction E.?. UserFunctionSchool
+                           , examOfficeResultSynced E.^. ExamOfficeResultSyncedSchool
                            )
                          )
                 let syncs' = Map.fromListWith
                                (\(dn, sn, t, sshs) (_, _, _, sshs') -> (dn, sn, t, Set.union sshs sshs'))
-                               [ (officeId, (dn, sn, t, maybe Set.empty Set.singleton ssh'))
+                               [ ((officeId, t), (dn, sn, t, maybe Set.empty Set.singleton ssh'))
                                | (E.Value officeId, (E.Value dn, E.Value sn, E.Value t, fmap unSchoolKey . E.unValue -> ssh')) <- syncs
                                ]
                 return $ Map.elems syncs'
@@ -231,8 +251,8 @@ postEGradesR tid ssh csh examn = do
             syncs <- asks $ sortOn (Down . view _3) . toListOf resultSynchronised
             lastChange <- view $ resultExamResult . _entityVal . _examResultLastChanged
             user <- view $ resultUser . _entityVal
+            isSynced <- view resultIsSynced
             let
-              lastSync = maximumOf (folded . _3) syncs
               hasSyncs = has folded syncs
 
               syncs' = [ Right sync | sync@(_, _, t, _) <- syncs, t >  lastChange]
@@ -240,13 +260,14 @@ postEGradesR tid ssh csh examn = do
                     ++ [ Right sync | sync@(_, _, t, _) <- syncs, t <= lastChange]
               
               syncIcon :: Widget
-              syncIcon = case lastSync of
+              syncIcon 
-                Nothing -> mempty
+                | not isSynced
-                Just ts
+                , not hasSyncs
-                  | ts >= lastChange
+                = mempty
-                    -> toWidget iconOK
+                | not isSynced
-                  | otherwise
+                = toWidget iconNotOK
-                    -> toWidget iconNotOK
+                | otherwise
+                = toWidget iconOK
             
               syncsModal :: Widget
               syncsModal = $(widgetFile "exam-office/exam-result-synced")
@@ -275,7 +296,7 @@ postEGradesR tid ssh csh examn = do
             , sortStudyFeaturesSemester (queryStudyFeatures . to (E.?. StudyFeaturesSemester))
             , sortOccurrenceStart (queryExamOccurrence . to (E.maybe (E.val examStart) E.just . (E.?. ExamOccurrenceStart)))
             , maybeOpticSortColumn (sortExamResult examShowGrades) (queryExamResult . to (E.^. ExamResultResult))
-            , singletonMap "is-synced" . SortColumn $ view queryIsSynced
+            , singletonMap "is-synced" . SortColumn $ view (queryIsSynced $ E.val uid)
             ]
           dbtFilter = mconcat
             [ fltrUserName' (queryUser . to (E.^. UserDisplayName))
@@ -284,7 +305,7 @@ postEGradesR tid ssh csh examn = do
             , fltrStudyDegree queryStudyDegree
             , fltrStudyFeaturesSemester (queryStudyFeatures . to (E.?. StudyFeaturesSemester))
             , fltrExamResultPoints examShowGrades (queryExamResult . to (E.^. ExamResultResult))
-            , singletonMap "is-synced" . FilterColumn $ E.mkExactFilter (view queryIsSynced)
+            , singletonMap "is-synced" . FilterColumn $ E.mkExactFilter (view . queryIsSynced $ E.val uid)
             ]
           dbtFilterUI = mconcat
             [ fltrUserNameUI'
@@ -322,14 +343,7 @@ postEGradesR tid ssh csh examn = do
             { dbtCsvExportForm = ExamUserCsvExportData
               <$> apopt checkBoxField (fslI MsgExamUserMarkSynchronisedCsv) (Just True)
             , dbtCsvDoEncode = \ExamUserCsvExportData{..} -> C.mapM $ \(E.Value k, row) -> do
-                when csvEUserMarkSynchronised $
+                when csvEUserMarkSynchronised $ markSynced k
-                  void $ upsert ExamOfficeResultSynced
-                    { examOfficeResultSyncedOffice = uid
-                    , examOfficeResultSyncedResult = k
-                    , examOfficeResultSyncedTime   = now
-                    }
-                    [ ExamOfficeResultSyncedTime =. now
-                    ]
                 return $ ExamUserTableCsv
                   (row ^. resultUser . _entityVal . _userSurname)
                   (row ^. resultUser . _entityVal . _userFirstName)
@@ -353,20 +367,18 @@ postEGradesR 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
+    (usersResult, examUsersTable) <- over _1 postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable
 
-  formResult usersResult $ \case
+    usersResult' <- formResultMaybe usersResult $ \case
-    (ExamUserMarkSynchronisedData, selectedResults) -> do
+      (ExamUserMarkSynchronisedData, selectedResults) -> do
-      runDB . forM_ selectedResults $ \resId ->
+        forM_ selectedResults markSynced
-        void $ upsert ExamOfficeResultSynced
+        return . Just $ do
-          { examOfficeResultSyncedOffice = uid
+          addMessageI Success $ MsgExamUserMarkedSynchronised (length selectedResults)
-          , examOfficeResultSyncedResult = resId
+          redirect $ CExamR tid ssh csh examn EGradesR
-          , examOfficeResultSyncedTime   = now
+
-          }
+    return (usersResult', examUsersTable)
-          [ ExamOfficeResultSyncedTime =. now
+
-          ]
+  whenIsJust usersResult join
-      addMessageI Success $ MsgExamUserMarkedSynchronised (length selectedResults)
-      redirect $ CExamR tid ssh csh examn EGradesR
 
   siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamOfficeExamUsersHeading) $ do
     setTitleI $ prependCourseTitle tid ssh csh MsgExamOfficeExamUsersHeading

src/Handler/Utils/ExamOffice/Exam.hs

@@ -0,0 +1,27 @@
+module Handler.Utils.ExamOffice.Exam
+  ( resultIsSynced
+  ) where
+
+import Import.NoFoundation
+
+import qualified Database.Esqueleto as E
+
+resultIsSynced :: E.SqlExpr (E.Value UserId) -- ^ office
+               -> E.SqlExpr (Entity ExamResult)
+               -> E.SqlExpr (E.Value Bool)
+resultIsSynced authId examResult = (hasSchool E.&&. allSchools) E.||. anySync
+  where
+    anySync = E.exists . E.from $ \synced ->
+      E.where_ $ synced E.^. ExamOfficeResultSyncedResult E.==. examResult E.^. ExamResultId
+           E.&&. synced E.^. ExamOfficeResultSyncedTime   E.>=. examResult E.^. ExamResultLastChanged
+    
+    hasSchool = E.exists . E.from $ \userFunction ->
+      E.where_ $ userFunction E.^. UserFunctionUser E.==. authId
+           E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice
+    allSchools = E.not_ . E.exists . E.from $ \userFunction -> do
+      E.where_ $ userFunction E.^. UserFunctionUser E.==. authId
+           E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice
+      E.where_ . E.not_ . E.exists . E.from $ \synced ->
+        E.where_ $ synced E.^. ExamOfficeResultSyncedSchool E.==. E.just (userFunction E.^. UserFunctionSchool)
+             E.&&. synced E.^. ExamOfficeResultSyncedResult E.==. examResult E.^. ExamResultId
+             E.&&. synced E.^. ExamOfficeResultSyncedTime   E.>=. examResult E.^. ExamResultLastChanged