569 lines
26 KiB
Haskell
569 lines
26 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
|
|
|
module Handler.Utils.ExternalExam.Users where
|
|
|
|
import Import hiding ((.:))
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Csv
|
|
import Handler.Utils.Users
|
|
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
import qualified Data.List.NonEmpty as NonEmpty (head)
|
|
|
|
import qualified Colonnade
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import Data.Csv ((.:))
|
|
import qualified Data.Csv as Csv
|
|
|
|
import qualified Handler.Utils.ExamOffice.ExternalExam as ExternalExam
|
|
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Lens as Text
|
|
|
|
import qualified Data.Conduit.List as C
|
|
|
|
import Data.List (cycle)
|
|
|
|
import Handler.Utils.StudyFeatures
|
|
|
|
|
|
data ExternalExamUserMode = EEUMUsers | EEUMGrades
|
|
deriving (Eq, Ord, Read, Show, Bounded, Enum, Generic, Typeable)
|
|
instance Universe ExternalExamUserMode
|
|
instance Finite ExternalExamUserMode
|
|
nullaryPathPiece ''ExternalExamUserMode $ camelToPathPiece' 1
|
|
makePrisms ''ExternalExamUserMode
|
|
|
|
|
|
type ExternalExamUserTableExpr = E.SqlExpr (Entity ExternalExamResult)
|
|
`E.InnerJoin` E.SqlExpr (Entity User)
|
|
|
|
type ExternalExamUserTableData = DBRow ( Entity ExternalExamResult
|
|
, Entity User
|
|
, Bool
|
|
, [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
|
|
, UserTableStudyFeatures
|
|
)
|
|
|
|
queryUser :: Getter ExternalExamUserTableExpr (E.SqlExpr (Entity User))
|
|
queryUser = to $(E.sqlIJproj 2 2)
|
|
|
|
queryResult :: Getter ExternalExamUserTableExpr (E.SqlExpr (Entity ExternalExamResult))
|
|
queryResult = to $(E.sqlIJproj 2 1)
|
|
|
|
queryIsSynced :: E.SqlExpr (E.Value UserId) -> Getter ExternalExamUserTableExpr (E.SqlExpr (E.Value Bool))
|
|
queryIsSynced authId = to $ ExternalExam.resultIsSynced authId <$> view queryResult
|
|
|
|
resultUser :: Lens' ExternalExamUserTableData (Entity User)
|
|
resultUser = _dbrOutput . _2
|
|
|
|
resultResult :: Lens' ExternalExamUserTableData (Entity ExternalExamResult)
|
|
resultResult = _dbrOutput . _1
|
|
|
|
resultIsSynced :: Lens' ExternalExamUserTableData Bool
|
|
resultIsSynced = _dbrOutput . _3
|
|
|
|
resultSynchronised :: Traversal' ExternalExamUserTableData (UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)
|
|
resultSynchronised = _dbrOutput . _4 . traverse
|
|
|
|
resultStudyFeatures :: Lens' ExternalExamUserTableData UserTableStudyFeatures
|
|
resultStudyFeatures = _dbrOutput . _5
|
|
|
|
|
|
data ExternalExamUserTableCsv = ExternalExamUserTableCsv
|
|
{ csvEUserSurname :: Maybe Text
|
|
, csvEUserFirstName :: Maybe Text
|
|
, csvEUserName :: Maybe Text
|
|
, csvEUserMatriculation :: Maybe Text
|
|
, csvEUserStudyFeatures :: UserTableStudyFeatures
|
|
, csvEUserOccurrenceStart :: Maybe ZonedTime
|
|
, csvEUserExamResult :: ExamResultPassedGrade
|
|
} deriving (Generic)
|
|
makeLenses_ ''ExternalExamUserTableCsv
|
|
|
|
externalExamUserTableCsvOptions :: Csv.Options
|
|
externalExamUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3 }
|
|
|
|
instance ToNamedRecord ExternalExamUserTableCsv where
|
|
toNamedRecord = Csv.genericToNamedRecord externalExamUserTableCsvOptions
|
|
|
|
instance DefaultOrdered ExternalExamUserTableCsv where
|
|
headerOrder = Csv.genericHeaderOrder externalExamUserTableCsvOptions
|
|
|
|
instance FromNamedRecord ExternalExamUserTableCsv where
|
|
parseNamedRecord csv
|
|
= ExternalExamUserTableCsv
|
|
<$> csv .:?? "surname"
|
|
<*> csv .:?? "first-name"
|
|
<*> csv .:?? "name"
|
|
<*> csv .:?? "matriculation"
|
|
<*> pure mempty
|
|
<*> csv .:?? "occurrence-start"
|
|
<*> csv .: "exam-result"
|
|
|
|
|
|
instance CsvColumnsExplained ExternalExamUserTableCsv where
|
|
csvColumnsExplanations = genericCsvColumnsExplanations externalExamUserTableCsvOptions $ Map.fromList
|
|
[ ('csvEUserSurname , MsgCsvColumnExamUserSurname )
|
|
, ('csvEUserFirstName , MsgCsvColumnExamUserFirstName )
|
|
, ('csvEUserName , MsgCsvColumnExamUserName )
|
|
, ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculation )
|
|
, ('csvEUserStudyFeatures , MsgCsvColumnUserStudyFeatures )
|
|
, ('csvEUserOccurrenceStart , MsgCsvColumnExamOfficeExamUserOccurrenceStart )
|
|
, ('csvEUserExamResult , MsgCsvColumnExamUserResult )
|
|
]
|
|
|
|
data ExternalExamUserAction
|
|
= ExternalExamUserMarkSynchronised
|
|
| ExternalExamUserEditOccurrence
|
|
| ExternalExamUserEditResult
|
|
| ExternalExamUserDelete
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
instance Universe ExternalExamUserAction
|
|
instance Finite ExternalExamUserAction
|
|
nullaryPathPiece ''ExternalExamUserAction $ camelToPathPiece' 3
|
|
embedRenderMessage ''UniWorX ''ExternalExamUserAction id
|
|
|
|
data ExternalExamUserActionData
|
|
= ExternalExamUserMarkSynchronisedData
|
|
| ExternalExamUserEditOccurrenceData UTCTime
|
|
| ExternalExamUserEditResultData ExamResultPassedGrade
|
|
| ExternalExamUserDeleteData
|
|
|
|
newtype ExternalExamUserCsvExportDataGrades = ExternalExamUserCsvExportDataGrades
|
|
{ csvEEUserMarkSynchronised :: Bool
|
|
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
|
|
data ExamUserCsvException
|
|
= ExamUserCsvExceptionNoMatchingUser
|
|
| ExamUserCsvExceptionNoOccurrenceTime
|
|
deriving (Show, Generic, Typeable)
|
|
|
|
instance Exception ExamUserCsvException
|
|
|
|
embedRenderMessage ''UniWorX ''ExamUserCsvException id
|
|
|
|
|
|
data ExternalExamUserCsvActionClass
|
|
= ExternalExamUserCsvRegister
|
|
| ExternalExamUserCsvDeregister
|
|
| ExternalExamUserCsvSetTime
|
|
| ExternalExamUserCsvSetResult
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
|
embedRenderMessage ''UniWorX ''ExternalExamUserCsvActionClass id
|
|
|
|
data ExternalExamUserCsvAction
|
|
= ExternalExamUserCsvRegisterData
|
|
{ externalExamUserCsvActUser :: UserId
|
|
, externalExamUserCsvActTime :: UTCTime
|
|
, externalExamUserCsvActResult :: ExamResultPassedGrade
|
|
}
|
|
| ExternalExamUserCsvSetTimeData
|
|
{ externalExamUserCsvActRegistration :: ExternalExamResultId
|
|
, externalExamUserCsvActTime :: UTCTime
|
|
}
|
|
| ExternalExamUserCsvSetResultData
|
|
{ externalExamUserCsvActRegistration :: ExternalExamResultId
|
|
, externalExamUserCsvActResult :: ExamResultPassedGrade
|
|
}
|
|
| ExternalExamUserCsvDeregisterData
|
|
{ externalExamUserCsvActRegistration :: ExternalExamResultId
|
|
}
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
deriveJSON defaultOptions
|
|
{ constructorTagModifier = over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 4 . dropEnd 1 . splitCamel
|
|
, fieldLabelModifier = camelToPathPiece' 5
|
|
, sumEncoding = TaggedObject "action" "data"
|
|
} ''ExternalExamUserCsvAction
|
|
|
|
|
|
makeExternalExamUsersTable :: ExternalExamUserMode
|
|
-> Entity ExternalExam
|
|
-> DB (FormResult (ExternalExamUserActionData, Set ExternalExamResultId), Widget)
|
|
makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
|
|
let tid = externalExamTerm
|
|
ssh = externalExamSchool
|
|
coursen = externalExamCourseName
|
|
examn = externalExamExamName
|
|
|
|
uid <- requireAuthId
|
|
csvName <- getMessageRender <*> pure (MsgExternalExamUserCsvName tid ssh coursen examn)
|
|
isLecturer <- hasReadAccessTo $ EExamR tid ssh coursen examn EEUsersR
|
|
currentRoute <- fromMaybe (error "makeExternalExamUsersTable called from 404-handler") <$> getCurrentRoute
|
|
MsgRenderer mr <- getMsgRenderer
|
|
exampleTime <- over _utctDayTime (fromInteger . round . toRational) <$> liftIO getCurrentTime
|
|
|
|
let
|
|
dbtSQLQuery = runReaderT $ do
|
|
result <- view queryResult
|
|
user <- view queryUser
|
|
isSynced <- view . queryIsSynced $ E.val uid
|
|
|
|
lift $ do
|
|
E.on $ result E.^. ExternalExamResultUser E.==. user E.^. UserId
|
|
|
|
E.where_ $ result E.^. ExternalExamResultExam E.==. E.val eeId
|
|
|
|
unless (isLecturer || mode == EEUMUsers) $
|
|
E.where_ $ ExternalExam.examOfficeExternalExamResultAuth (E.val uid) result
|
|
|
|
return (result, user, isSynced)
|
|
dbtRowKey = views queryResult (E.^. ExternalExamResultId)
|
|
|
|
dbtProj :: DBRow _ -> DB ExternalExamUserTableData
|
|
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
|
|
(,,,,)
|
|
<$> view _1 <*> view _2 <*> view (_3 . _Value)
|
|
<*> getSynchronised
|
|
<*> (lift . externalExamUserStudyFeatures eeId =<< view (_2 . _entityKey))
|
|
where
|
|
getSynchronised :: ReaderT _ DB [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
|
|
getSynchronised = do
|
|
resId <- view $ _1 . _entityKey
|
|
syncs <- lift . E.select . E.from $ \(examOfficeExternalResultSynced `E.InnerJoin` user) -> do
|
|
E.on $ examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedOffice E.==. user E.^. UserId
|
|
E.where_ $ examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedResult E.==. E.val resId
|
|
return ( examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedOffice
|
|
, ( user E.^. UserDisplayName
|
|
, user E.^. UserSurname
|
|
, examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedTime
|
|
, examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedSchool
|
|
)
|
|
)
|
|
let syncs' = Map.fromListWith
|
|
(\(dn, sn, t, sshs) (_, _, _, sshs') -> (dn, sn, t, Set.union sshs sshs'))
|
|
[ ((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'
|
|
|
|
colSynced = Colonnade.singleton (fromSortable . Sortable (Just "is-synced") $ i18nCell MsgExamUserSynchronised) $ \x -> cell . flip runReaderT x $ do
|
|
syncs <- asks $ sortOn (Down . view _3) . toListOf resultSynchronised
|
|
lastChange <- view $ resultResult . _entityVal . _externalExamResultLastChanged
|
|
user <- view $ resultUser . _entityVal
|
|
isSynced <- view resultIsSynced
|
|
let
|
|
hasSyncs = has folded syncs
|
|
|
|
syncs' = [ Right sync | sync@(_, _, t, _) <- syncs, t > lastChange]
|
|
++ [ Left lastChange ]
|
|
++ [ Right sync | sync@(_, _, t, _) <- syncs, t <= lastChange]
|
|
|
|
syncIcon :: Widget
|
|
syncIcon
|
|
| not isSynced
|
|
, not hasSyncs
|
|
= mempty
|
|
| not isSynced
|
|
= toWidget iconNotOK
|
|
| otherwise
|
|
= toWidget iconOK
|
|
|
|
syncsModal :: Widget
|
|
syncsModal = $(widgetFile "exam-office/exam-result-synced")
|
|
lift $ bool id (flip modal $ Right syncsModal) hasSyncs syncIcon
|
|
|
|
dbtColonnade :: Colonnade Sortable _ _
|
|
dbtColonnade = mconcat
|
|
[ dbSelect (applying _2) id $ return . view (resultResult . _entityKey)
|
|
, fromMaybe mempty . guardOn (is _EEUMGrades mode) $ colSynced
|
|
, colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
|
|
, colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
|
|
, colStudyFeatures resultStudyFeatures
|
|
, Colonnade.singleton (fromSortable . Sortable (Just "occurrence-start") $ i18nCell MsgExamTime) $ \x -> cell . flip runReaderT x $ do
|
|
t <- view $ resultResult . _entityVal . _externalExamResultTime
|
|
lift $ formatTimeW SelFormatDateTime t
|
|
, colExamResult (resultResult . _entityVal . _externalExamResultResult)
|
|
]
|
|
dbtSorting = mconcat
|
|
[ sortUserName' (queryUser . to ((,) <$> (E.^. UserDisplayName) <*> (E.^. UserSurname)))
|
|
, sortUserMatriculation (queryUser . to (E.^. UserMatrikelnummer))
|
|
, sortOccurrenceStart (queryResult . to (E.^. ExternalExamResultTime))
|
|
, maybeOpticSortColumn sortExamResult (queryResult . to (E.^. ExternalExamResultResult))
|
|
, singletonMap "is-synced" . SortColumn $ view (queryIsSynced $ E.val uid)
|
|
]
|
|
dbtFilter = mconcat
|
|
[ fltrUserName' (queryUser . to (E.^. UserDisplayName))
|
|
, fltrUserMatriculation (queryUser . to (E.^. UserMatrikelnummer))
|
|
, fltrExamResultPoints (queryResult . to (E.^. ExternalExamResultResult) . to E.just)
|
|
, singletonMap "is-synced" . FilterColumn $ E.mkExactFilter (view . queryIsSynced $ E.val uid)
|
|
, fltrRelevantStudyFeaturesTerms (to $
|
|
\t -> ( E.val externalExamTerm
|
|
, views queryUser (E.^. UserId) t
|
|
))
|
|
, fltrRelevantStudyFeaturesDegree (to $
|
|
\t -> ( E.val externalExamTerm
|
|
, views queryUser (E.^. UserId) t
|
|
))
|
|
, fltrRelevantStudyFeaturesSemester (to $
|
|
\t -> ( E.val externalExamTerm
|
|
, views queryUser (E.^. UserId) t
|
|
))
|
|
|
|
]
|
|
dbtFilterUI = mconcat
|
|
[ fltrUserNameUI'
|
|
, fltrUserMatriculationUI
|
|
, fltrExamResultPointsUI
|
|
, case mode of
|
|
EEUMGrades ->
|
|
\mPrev -> prismAForm (singletonFilter "is-synced" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgExamUserSynchronised)
|
|
_other -> mempty
|
|
, fltrRelevantStudyFeaturesTermsUI
|
|
, fltrRelevantStudyFeaturesDegreeUI
|
|
, fltrRelevantStudyFeaturesSemesterUI
|
|
]
|
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
dbtParams = DBParamsForm
|
|
{ dbParamsFormMethod = POST
|
|
, dbParamsFormAction = Just $ SomeRoute currentRoute
|
|
, dbParamsFormAttrs = []
|
|
, dbParamsFormSubmit = FormSubmit
|
|
, dbParamsFormAdditional = case mode of
|
|
EEUMGrades -> \csrf -> do
|
|
let
|
|
actionMap :: Map ExternalExamUserAction (AForm Handler ExternalExamUserActionData)
|
|
actionMap = Map.fromList
|
|
[ ( ExternalExamUserMarkSynchronised
|
|
, pure ExternalExamUserMarkSynchronisedData
|
|
)
|
|
]
|
|
(res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf
|
|
let formRes = (, mempty) . First . Just <$> res
|
|
return (formRes, formWgt)
|
|
EEUMUsers -> \csrf -> do
|
|
let
|
|
actionMap :: Map ExternalExamUserAction (AForm Handler ExternalExamUserActionData)
|
|
actionMap = mconcat
|
|
[ singletonMap ExternalExamUserEditOccurrence $
|
|
ExternalExamUserEditOccurrenceData
|
|
<$> apopt utcTimeField (fslI MsgExamTime) externalExamDefaultTime
|
|
, singletonMap ExternalExamUserEditResult $
|
|
ExternalExamUserEditResultData
|
|
<$> apopt (examResultPassedGradeField Nothing) (fslI MsgExamResult) Nothing
|
|
, singletonMap ExternalExamUserDelete $
|
|
pure ExternalExamUserDeleteData
|
|
]
|
|
(res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf
|
|
let formRes = (, mempty) . First . Just <$> res
|
|
return (formRes, formWgt)
|
|
, dbParamsFormEvaluate = liftHandler . runFormPost
|
|
, dbParamsFormResult = id
|
|
, dbParamsFormIdent = def
|
|
}
|
|
dbtIdent = mode
|
|
dbtCsvEncode = case mode of
|
|
EEUMGrades -> Just DBTCsvEncode
|
|
{ dbtCsvExportForm = ExternalExamUserCsvExportDataGrades
|
|
<$> apopt checkBoxField (fslI MsgExamUserMarkSynchronisedCsv & setTooltip MsgExamUserMarkSynchronisedCsvTip) (Just False)
|
|
, dbtCsvDoEncode = \ExternalExamUserCsvExportDataGrades{..} -> C.mapM $ \(E.Value k, row) -> do
|
|
when csvEEUserMarkSynchronised $ externalExamResultMarkSynchronised k
|
|
return $ encodeCsv' row
|
|
, dbtCsvName = unpack csvName
|
|
, dbtCsvNoExportData = Nothing
|
|
, dbtCsvHeader = const . return $ headerOrder (error "headerOrder" :: ExternalExamUserTableCsv)
|
|
, dbtCsvExampleData = Nothing
|
|
}
|
|
EEUMUsers ->
|
|
let baseEncode = simpleCsvEncode csvName encodeCsv'
|
|
csvEUserStudyFeatures = mempty
|
|
in baseEncode <&> \enc -> enc
|
|
{ dbtCsvExampleData = Just
|
|
[ ExternalExamUserTableCsv{..}
|
|
| (csvEUserSurname, csvEUserFirstName, csvEUserName, csvEUserMatriculation) <-
|
|
[ ( Just $ mr MsgExampleUser1Surname
|
|
, Just $ mr MsgExampleUser1FirstName
|
|
, Just $ mr MsgExampleUser1DisplayName
|
|
, Just "12345678"
|
|
)
|
|
, ( Nothing
|
|
, Nothing
|
|
, Nothing
|
|
, Just "87654321"
|
|
)
|
|
, ( Nothing
|
|
, Nothing
|
|
, Just $ mr MsgExampleUser2DisplayName
|
|
, Nothing
|
|
)
|
|
, ( Just $ mr MsgExampleUser3Surname
|
|
, Nothing
|
|
, Nothing
|
|
, Nothing
|
|
)
|
|
]
|
|
| csvEUserOccurrenceStart <- catMaybes $
|
|
guardOn (is _Just externalExamDefaultTime) Nothing
|
|
: repeat (Just . Just $ utcToZonedTime exampleTime)
|
|
| csvEUserExamResult <- cycle . catMaybes $
|
|
[ guardOn (hasExamGradingPass externalExamGradingMode) $ ExamAttended (Left $ ExamPassed True)
|
|
, guardOn (hasExamGradingGrades externalExamGradingMode) $ ExamAttended (Right Grade50)
|
|
, pure ExamVoided
|
|
, pure ExamNoShow
|
|
]
|
|
]
|
|
}
|
|
where
|
|
encodeCsv' :: ExternalExamUserTableData -> ExternalExamUserTableCsv
|
|
encodeCsv' row = ExternalExamUserTableCsv
|
|
{ csvEUserSurname = row ^? resultUser . _entityVal . _userSurname
|
|
, csvEUserFirstName = row ^? resultUser . _entityVal . _userFirstName
|
|
, csvEUserName = row ^? resultUser . _entityVal . _userDisplayName
|
|
, csvEUserMatriculation = row ^? resultUser . _entityVal . _userMatrikelnummer . _Just
|
|
, csvEUserStudyFeatures = row ^. resultStudyFeatures
|
|
, csvEUserOccurrenceStart = row ^? resultResult . _entityVal . _externalExamResultTime . to utcToZonedTime
|
|
, csvEUserExamResult = row ^. resultResult . _entityVal . _externalExamResultResult
|
|
}
|
|
dbtCsvDecode
|
|
| mode == EEUMUsers = Just DBTCsvDecode
|
|
{ dbtCsvRowKey = \csv -> do
|
|
guess <- lift $ guessUser' csv
|
|
let pid = either (entityKey . NonEmpty.head) entityKey guess
|
|
fmap E.Value . MaybeT . getKeyBy $ UniqueExternalExamResult eeId pid
|
|
, dbtCsvComputeActions = \case
|
|
DBCsvDiffMissing{dbCsvOldKey}
|
|
-> yield . ExternalExamUserCsvDeregisterData $ E.unValue dbCsvOldKey
|
|
DBCsvDiffNew{dbCsvNewKey = Just _}
|
|
-> error "An UniqueExternalExamResult could be found, but the ExternalExamResultKey is not among the existing keys"
|
|
DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
|
|
guess <- lift $ guessUser' dbCsvNew
|
|
let
|
|
pid = either (entityKey . NonEmpty.head) entityKey guess
|
|
ExternalExamUserTableCsv{..} = dbCsvNew
|
|
occTime <- maybe (throwM ExamUserCsvExceptionNoOccurrenceTime) return $ fmap zonedTimeToUTC csvEUserOccurrenceStart <|> externalExamDefaultTime
|
|
yield $ ExternalExamUserCsvRegisterData pid occTime csvEUserExamResult
|
|
DBCsvDiffExisting{..} -> do
|
|
let ExternalExamUserTableCsv{..} = dbCsvNew
|
|
whenIsJust (zonedTimeToUTC <$> csvEUserOccurrenceStart) $ \occTime ->
|
|
when (occTime /= dbCsvOld ^. resultResult . _entityVal . _externalExamResultTime) $
|
|
yield $ ExternalExamUserCsvSetTimeData (E.unValue dbCsvOldKey) occTime
|
|
|
|
when (csvEUserExamResult /= dbCsvOld ^. resultResult . _entityVal . _externalExamResultResult) $
|
|
yield $ ExternalExamUserCsvSetResultData (E.unValue dbCsvOldKey) csvEUserExamResult
|
|
, dbtCsvValidateActions = return ()
|
|
, dbtCsvClassifyAction = \case
|
|
ExternalExamUserCsvRegisterData{} -> ExternalExamUserCsvRegister
|
|
ExternalExamUserCsvSetTimeData{} -> ExternalExamUserCsvSetTime
|
|
ExternalExamUserCsvSetResultData{} -> ExternalExamUserCsvSetResult
|
|
ExternalExamUserCsvDeregisterData{} -> ExternalExamUserCsvDeregister
|
|
, dbtCsvCoarsenActionClass = \case
|
|
ExternalExamUserCsvRegister -> DBCsvActionNew
|
|
ExternalExamUserCsvDeregister -> DBCsvActionMissing
|
|
_other -> DBCsvActionExisting
|
|
, dbtCsvExecuteActions = do
|
|
C.mapM_ $ \case
|
|
ExternalExamUserCsvRegisterData{..} -> do
|
|
now <- liftIO getCurrentTime
|
|
insert_ ExternalExamResult
|
|
{ externalExamResultExam = eeId
|
|
, externalExamResultUser = externalExamUserCsvActUser
|
|
, externalExamResultTime = externalExamUserCsvActTime
|
|
, externalExamResultResult = externalExamUserCsvActResult
|
|
, externalExamResultLastChanged = now
|
|
}
|
|
audit $ TransactionExternalExamResultEdit eeId externalExamUserCsvActUser
|
|
ExternalExamUserCsvSetTimeData{..} -> do
|
|
now <- liftIO getCurrentTime
|
|
ExternalExamResult{..} <- updateGet externalExamUserCsvActRegistration
|
|
[ ExternalExamResultTime =. externalExamUserCsvActTime
|
|
, ExternalExamResultLastChanged =. now
|
|
]
|
|
audit $ TransactionExternalExamResultEdit eeId externalExamResultUser
|
|
ExternalExamUserCsvSetResultData{..} -> do
|
|
now <- liftIO getCurrentTime
|
|
ExternalExamResult{..} <- updateGet externalExamUserCsvActRegistration
|
|
[ ExternalExamResultResult =. externalExamUserCsvActResult
|
|
, ExternalExamResultLastChanged =. now
|
|
]
|
|
audit $ TransactionExternalExamResultEdit eeId externalExamResultUser
|
|
ExternalExamUserCsvDeregisterData{..} -> do
|
|
ExternalExamResult{..} <- getJust externalExamUserCsvActRegistration
|
|
delete externalExamUserCsvActRegistration
|
|
audit $ TransactionExternalExamResultDelete eeId externalExamResultUser
|
|
return $ EExamR tid ssh coursen examn EEUsersR
|
|
, dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case
|
|
ExternalExamUserCsvRegisterData{..} -> do
|
|
User{..} <- liftHandler . runDB $ getJust externalExamUserCsvActUser
|
|
[whamlet|
|
|
$newline never
|
|
^{nameWidget userDisplayName userSurname}
|
|
, ^{formatTimeW SelFormatDateTime externalExamUserCsvActTime}
|
|
, _{externalExamUserCsvActResult}
|
|
|]
|
|
ExternalExamUserCsvSetTimeData{..} ->
|
|
[whamlet|
|
|
$newline never
|
|
^{registeredUserName' externalExamUserCsvActRegistration}
|
|
, ^{formatTimeW SelFormatDateTime externalExamUserCsvActTime}
|
|
|]
|
|
ExternalExamUserCsvSetResultData{..} ->
|
|
[whamlet|
|
|
$newline never
|
|
^{registeredUserName' externalExamUserCsvActRegistration}
|
|
, _{externalExamUserCsvActResult}
|
|
|]
|
|
ExternalExamUserCsvDeregisterData{..} ->
|
|
registeredUserName' externalExamUserCsvActRegistration
|
|
, dbtCsvRenderActionClass = i18n
|
|
, dbtCsvRenderException = ap getMessageRender . pure :: ExamUserCsvException -> DB Text
|
|
}
|
|
| otherwise = Nothing
|
|
where
|
|
registeredUserName :: Map (E.Value ExternalExamResultId) ExternalExamUserTableData -> ExternalExamResultId -> Widget
|
|
registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname
|
|
where
|
|
Entity _ User{..} = view resultUser $ existing Map.! registration
|
|
|
|
guessUser' :: ExternalExamUserTableCsv -> DB (Either (NonEmpty (Entity User)) (Entity User))
|
|
guessUser' ExternalExamUserTableCsv{..} = do
|
|
let criteria = PredDNF . maybe Set.empty Set.singleton . fromNullable . Set.fromList . fmap PLVariable $ catMaybes
|
|
[ GuessUserMatrikelnummer <$> csvEUserMatriculation
|
|
, GuessUserDisplayName <$> csvEUserName
|
|
, GuessUserSurname <$> csvEUserSurname
|
|
, GuessUserFirstName <$> csvEUserFirstName
|
|
]
|
|
maybe (throwM ExamUserCsvExceptionNoMatchingUser) return =<< guessUser criteria (Just 1) -- we're only interested in at most one match
|
|
dbtExtraReps = []
|
|
externalExamUsersDBTableValidator = def
|
|
& defaultSorting (bool id (SortAscBy "is-synced" :) (mode == EEUMGrades) [SortAscBy "user-name"])
|
|
& defaultPagesize PagesizeAll
|
|
|
|
postprocess :: FormResult (First ExternalExamUserActionData, DBFormResult ExternalExamResultId Bool ExternalExamUserTableData) -> FormResult (ExternalExamUserActionData, Set ExternalExamResultId)
|
|
postprocess inp = do
|
|
(First (Just act), regMap) <- inp
|
|
let regSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) regMap
|
|
return (act, regSet)
|
|
|
|
over _1 postprocess <$> dbTable externalExamUsersDBTableValidator DBTable{..}
|
|
|
|
externalExamResultMarkSynchronised :: ExternalExamResultId -> DB ()
|
|
externalExamResultMarkSynchronised resId = do
|
|
uid <- requireAuthId
|
|
now <- liftIO getCurrentTime
|
|
|
|
userFunctions <- selectList [ UserFunctionUser ==. uid, UserFunctionFunction ==. SchoolExamOffice ] []
|
|
if
|
|
| null userFunctions ->
|
|
insert_ ExamOfficeExternalResultSynced
|
|
{ examOfficeExternalResultSyncedOffice = uid
|
|
, examOfficeExternalResultSyncedResult = resId
|
|
, examOfficeExternalResultSyncedTime = now
|
|
, examOfficeExternalResultSyncedSchool = Nothing
|
|
}
|
|
| otherwise ->
|
|
insertMany_ [ ExamOfficeExternalResultSynced
|
|
{ examOfficeExternalResultSyncedOffice = uid
|
|
, examOfficeExternalResultSyncedResult = resId
|
|
, examOfficeExternalResultSyncedTime = now
|
|
, examOfficeExternalResultSyncedSchool = Just userFunctionSchool
|
|
}
|
|
| Entity _ UserFunction{..} <- userFunctions
|
|
]
|
|
|