From cb9ff32063046871edd7fe84729d5ea175e132f0 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 11 Sep 2019 09:11:24 +0200 Subject: [PATCH] fix(exam-office): better logic for isSynced --- models/exam-office | 4 +- src/Handler/ExamOffice/Exam.hs | 108 +++++++++++++++------------ src/Handler/Utils/ExamOffice/Exam.hs | 27 +++++++ 3 files changed, 89 insertions(+), 50 deletions(-) create mode 100644 src/Handler/Utils/ExamOffice/Exam.hs diff --git a/models/exam-office b/models/exam-office index 0941faf1d..dc952c26f 100644 --- a/models/exam-office +++ b/models/exam-office @@ -8,7 +8,7 @@ ExamOfficeUser user UserId UniqueExamOfficeUser office user ExamOfficeResultSynced + school SchoolId Maybe office UserId result ExamResultId - time UTCTime - UniqueExamOfficeResultSynced office result \ No newline at end of file + time UTCTime \ No newline at end of file diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index aff4bb40a..c1b966d58 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/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 = to . runReader $ do - 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 +queryIsSynced :: E.SqlExpr (E.Value UserId) -> Getter ExamUserTableExpr (E.SqlExpr (E.Value Bool)) +queryIsSynced authId = to $ Exam.resultIsSynced authId <$> view queryExamResult 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 - E.on $ userFunction E.?. UserFunctionUser E.==. E.just (user E.^. UserId) - E.&&. userFunction E.?. UserFunctionFunction E.==. E.just (E.val SchoolExamOffice) + syncs <- lift . lift . E.select . E.from $ \(examOfficeResultSynced `E.InnerJoin` user) -> do 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 - Nothing -> mempty - Just ts - | ts >= lastChange - -> toWidget iconOK - | otherwise - -> toWidget iconNotOK + syncIcon + | not isSynced + , not hasSyncs + = mempty + | not isSynced + = 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 $ - void $ upsert ExamOfficeResultSynced - { examOfficeResultSyncedOffice = uid - , examOfficeResultSyncedResult = k - , examOfficeResultSyncedTime = now - } - [ ExamOfficeResultSyncedTime =. now - ] + when csvEUserMarkSynchronised $ markSynced k 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 - (ExamUserMarkSynchronisedData, selectedResults) -> do - runDB . forM_ selectedResults $ \resId -> - void $ upsert ExamOfficeResultSynced - { examOfficeResultSyncedOffice = uid - , examOfficeResultSyncedResult = resId - , examOfficeResultSyncedTime = now - } - [ ExamOfficeResultSyncedTime =. now - ] - addMessageI Success $ MsgExamUserMarkedSynchronised (length selectedResults) - redirect $ CExamR tid ssh csh examn EGradesR + usersResult' <- formResultMaybe usersResult $ \case + (ExamUserMarkSynchronisedData, selectedResults) -> do + forM_ selectedResults markSynced + return . Just $ do + addMessageI Success $ MsgExamUserMarkedSynchronised (length selectedResults) + redirect $ CExamR tid ssh csh examn EGradesR + + return (usersResult', examUsersTable) + + whenIsJust usersResult join siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamOfficeExamUsersHeading) $ do setTitleI $ prependCourseTitle tid ssh csh MsgExamOfficeExamUsersHeading diff --git a/src/Handler/Utils/ExamOffice/Exam.hs b/src/Handler/Utils/ExamOffice/Exam.hs new file mode 100644 index 000000000..806ba943b --- /dev/null +++ b/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