{-# 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 , 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 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 ]