fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix(exam-office): better logic for isSynced

Browse Source
This commit is contained in:
Gregor Kleen 2019-09-11 09:11:24 +02:00
parent b638783f12
commit cb9ff32063
3 changed files with 89 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
models/exam-office
View File

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

108
src/Handler/ExamOffice/Exam.hs
View File

@ -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

27
src/Handler/Utils/ExamOffice/Exam.hs Normal file
View File

@ -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