From 4a51f94a8fddab2a3b4475476df476585c330fcf Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 19 Mar 2024 18:29:38 +0100 Subject: [PATCH] chore(avs): WIP update UserCompany accodring to AVS --- .../uniworx/categories/admin/de-de-formal.msg | 7 +- messages/uniworx/categories/admin/en-eu.msg | 7 +- src/Audit/Types.hs | 18 ++++- src/Database/Esqueleto/Utils.hs | 16 +++- src/Foundation/I18n.hs | 3 + src/Handler/Admin.hs | 75 ++++++++++++------- src/Handler/Utils/Avs.hs | 35 ++++++--- src/Handler/Utils/Users.hs | 11 +-- src/Utils/DB.hs | 24 +++++- test/Database/Fill.hs | 2 + 10 files changed, 140 insertions(+), 58 deletions(-) diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index 9c3c020db..1b5295489 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -123,12 +123,15 @@ ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit AdminProblemSolved: Erledigt AdminProblemSolver: Bearbeitet von -AdminProblemCreated: Zeitpunkt +AdminProblemCreated: Erkannt AdminProblemInfo: Problembeschreibung AdminProblemsSolved n@Int: #{pluralDEeN n "Admin Probleme"} als erledigt markiert +AdminProblemsReopened n@Int: #{pluralDEeN n "Admin Probleme"} erneut eröffnet AdminProblemNewCompany: Neue Firma aus AVS automatisch erstellt; prüfen und ggf. Standardansprechpartner eintragen +AdminProblemSupervisorNewCompany b@Bool: Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} wechselte zu neuer Firma +AdminProblemUser: Betroffener ProblemTableMarkSolved: Als erledigt markieren -ProblemTableUnknownTodo: Unbekanntes ToDo Problem +ProblemTableMarkUnsolved: Erledigt Markierung löschen InterfacesOk: Schnittstellen sind ok. InterfacesFail n@Int: #{pluralDEeN n "Schnittstellenproblem"}! diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index 1cece93e8..12c2b5df7 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -123,12 +123,15 @@ ProblemsInterfaceSince: Only considering successes and errors since AdminProblemSolved: Done AdminProblemSolver: Solved by -AdminProblemCreated: Creation time +AdminProblemCreated: Recognized AdminProblemInfo: Problem AdminProblemsSolved n: #{pluralENsN n "admin problem"} marked as solved +AdminProblemsReopened n: #{pluralENsN n "admin problem"} reopened AdminProblemNewCompany: New company from AVS; verify and add default supervisors +AdminProblemSupervisorNewCompany b: Default company supervisor #{boolText mempty "with reroute" b} changed to new company +AdminProblemUser: Affected ProblemTableMarkSolved: Mark done -ProblemTableUnknownTodo: Unknown todo problem +ProblemTableMarkUnsolved: Reopen as undone InterfacesOk: Interfaces are ok. InterfacesFail n: #{pluralENsN n "interface problem"}! diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 2933edcdf..a81efaa51 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -262,19 +262,29 @@ derivePersistFieldJSON ''Transaction -- Database stores generic Value in table ProblemLog, such that changes do not disturb old entries data AdminProblem - = AdminProblemNewCompany -- new company without supervisors has been created - { adminProblemCompany :: CompanyId + = AdminProblemNewCompany -- new company was noticed, presumably without supervisors + { adminProblemCompany :: CompanyId } - | AdminProblemUnknown -- placeholder to avoid hlint newtype suggestion while we have few problems yet - { adminProblemText :: Text + | AdminProblemSupervisorNewCompany + { adminProblemUser :: UserId -- a default supervisor has changed company + , adminProblemCompany :: CompanyId -- old company where the user had default supervisor rights + , adminProblemCompanyNew :: CompanyId -- new company of the user + , adminProblemSupervisorReroute :: Bool -- reroute included? + } + | AdminProblemUnknown -- miscellanous problem, just displaying text + { adminProblemText :: Text } deriving (Eq, Ord, Read, Show, Generic) +-- Columns shown in problem table: adminProblemCompany, adminProblemUser +-- For display: add clause to Handler.Admin.adminProblemCell + deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 2 , fieldLabelModifier = camelToPathPiece' 2 , tagSingleConstructors = True , sumEncoding = TaggedObject "problem" "data" + , rejectUnknownFields = False } ''AdminProblem derivePersistFieldJSON ''AdminProblem diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 65d3bbdf7..4bd3f85d3 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -41,13 +41,13 @@ module Database.Esqueleto.Utils , greatest, least , abs , SqlProject(..) - , (->.), (->>.), (#>>.) + , (->.), (->>.), (->>>.), (#>>.) , fromSqlKey , unKey , subSelectCountDistinct , selectCountRows, selectCountDistinct , selectMaybe - , num2text + , num2text --, text2num , day, day', dayMaybe, interval, diffDays, diffTimes , exprLift , explicitUnsafeCoerceSqlExprValue @@ -642,9 +642,15 @@ infixl 8 ->. infixl 8 ->>. -(->>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value Text) +(->>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value Text) (->>.) expr t = E.unsafeSqlBinOp "->>" expr $ E.val t +infixl 8 ->>>. + +-- Unsafe variant to obtain a DB key from a JSON field. Use with caution! +(->>>.) :: (PersistField (Key entity)) => E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value (Maybe (Key entity))) +(->>>.) expr t = E.unsafeSqlCastAs "int" $ E.unsafeSqlBinOp "->>" expr $ E.val t + infixl 8 #>>. (#>>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value (Maybe Text)) @@ -692,6 +698,10 @@ selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1) num2text :: Num n => E.SqlExpr (E.Value n) -> E.SqlExpr (E.Value Text) num2text = E.unsafeSqlCastAs "text" +-- unsafe, use with care! +-- text2num :: E.SqlExpr (E.Value Text) -> E.SqlExpr (E.Value n) +-- text2num = E.unsafeSqlCastAs "int" + day :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day) day = E.unsafeSqlCastAs "date" diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index fd2bb9479..576963ae5 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -210,6 +210,9 @@ maybeBoolMessage Nothing n _ _ = n maybeBoolMessage (Just True) _ t _ = t maybeBoolMessage (Just False) _ _ f = f +-- | Convenience function avoiding type signatures +boolText :: Text -> Text -> Bool -> Text +boolText = bool newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier deriving stock (Eq, Ord, Read, Show) diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 44f0ac35f..54af42978 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -43,7 +43,7 @@ single = uncurry Map.singleton -- Types and Template Haskell data ProblemTableAction = ProblemTableMarkSolved - | ProblemTableUnknownTodo -- Placeholder, remove later, inculding associated Message + | ProblemTableMarkUnsolved deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -51,7 +51,7 @@ nullaryPathPiece ''ProblemTableAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''ProblemTableAction id data ProblemTableActionData = ProblemTableMarkSolvedData - | ProblemTableUnknownTodoData -- Placeholder, remove later + | ProblemTableMarkUnsolvedData -- Placeholder, remove later deriving (Eq, Ord, Read, Show, Generic) @@ -119,21 +119,25 @@ handleAdminProblems mbProblemTable = do $(widgetFile "admin-problems") postAdminProblemsR = do - (problemLogRes, problemLogTable) <- runDB mkProblemLogTable - let procProblems :: (ProblemTableActionData, Set ProblemLogId) -> Handler () - procProblems (ProblemTableMarkSolvedData, pids) = do - mauid <- maybeAuthId - now <- liftIO getCurrentTime - (fromIntegral -> oks) <- runDB $ updateWhereCount [ProblemLogSolved ==. Nothing, ProblemLogId <-. toList pids] - [ProblemLogSolved =. Just now, ProblemLogSolver =. mauid] - let no_req = Set.size pids - mkind = if oks < no_req || no_req < 0 then Warning else Success - addMessageI mkind $ MsgAdminProblemsSolved oks - when (oks > 0) $ redirect AdminProblemsR -- reload to update all tables - procProblems (ProblemTableUnknownTodoData, _) = return () -- just a no-op - formResult problemLogRes procProblems - handleAdminProblems $ Just problemLogTable - + (problemLogRes, problemLogTable) <- runDB mkProblemLogTable + formResult problemLogRes procProblems + handleAdminProblems $ Just problemLogTable + where + procProblems :: (ProblemTableActionData, Set ProblemLogId) -> Handler () + procProblems (ProblemTableMarkSolvedData , pids) = actUpdate True pids + procProblems (ProblemTableMarkUnsolvedData, pids) = actUpdate False pids + + actUpdate markdone pids = do + mauid <- maybeAuthId + now <- liftIO getCurrentTime + let (pls_fltr,newv,msg) | markdone = (ProblemLogSolved ==. Nothing, Just now, MsgAdminProblemsSolved) + | otherwise = (ProblemLogSolved !=. Nothing, Nothing , MsgAdminProblemsReopened) + (fromIntegral -> oks) <- runDB $ updateWhereCount [pls_fltr, ProblemLogId <-. toList pids] + [ProblemLogSolved =. newv, ProblemLogSolver =. mauid] + let no_req = Set.size pids + mkind = if oks < no_req || no_req <= 0 then Warning else Success + addMessageI mkind $ msg oks + when (oks > 0) $ reloadKeepGetParams AdminProblemsR -- reload to update all tables getProblemUnreachableR :: Handler Html getProblemUnreachableR = do @@ -284,27 +288,35 @@ retrieveDriversRWithoutF now = do -type ProblemLogTableExpr = E.SqlExpr (Entity ProblemLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) +type ProblemLogTableExpr = E.SqlExpr (Entity ProblemLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) queryProblem :: ProblemLogTableExpr -> E.SqlExpr (Entity ProblemLog) -queryProblem = $(E.sqlLOJproj 2 1) +queryProblem = $(E.sqlLOJproj 3 1) querySolver :: ProblemLogTableExpr -> E.SqlExpr (Maybe (Entity User)) -querySolver = $(E.sqlLOJproj 2 2) +querySolver = $(E.sqlLOJproj 3 2) -type ProblemLogTableData = DBRow (Entity ProblemLog, Maybe (Entity User)) +queryUser :: ProblemLogTableExpr -> E.SqlExpr (Maybe (Entity User)) +queryUser = $(E.sqlLOJproj 3 3) + +type ProblemLogTableData = DBRow (Entity ProblemLog, Maybe (Entity User), Maybe (Entity User)) resultProblem :: Lens' ProblemLogTableData (Entity ProblemLog) resultProblem = _dbrOutput . _1 resultSolver :: Traversal' ProblemLogTableData (Entity User) resultSolver = _dbrOutput . _2 . _Just +resultUser :: Traversal' ProblemLogTableData (Entity User) +resultUser = _dbrOutput . _3 . _Just + mkProblemLogTable :: DB (FormResult (ProblemTableActionData, Set ProblemLogId), Widget) mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..} where dbtIdent = "problem-log" :: Text - dbtSQLQuery = \(problem `E.LeftOuterJoin` solver) -> do - EL.on (problem E.^. ProblemLogSolver E.==. solver E.?. UserId) - return (problem, solver) + dbtSQLQuery = \(problem `E.LeftOuterJoin` solver `E.LeftOuterJoin` usr) -> do + -- EL.on (usr E.?. UserId E.==. E.text2num (problem E.^. ProblemLogInfo E.->>. "user")) -- works + EL.on (usr E.?. UserId E.==. problem E.^. ProblemLogInfo E.->>>. "user") + EL.on (solver E.?. UserId E.==. problem E.^. ProblemLogSolver) + return (problem, solver, usr) dbtRowKey = queryProblem >>> (E.^. ProblemLogId) dbtProj = dbtProjId dbtColonnade = formColonnade $ mconcat @@ -312,7 +324,8 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..} , sortable (Just "time") (i18nCell MsgAdminProblemCreated) $ \( view $ resultProblem . _entityVal . _problemLogTime -> t) -> dateTimeCell t , sortable (Just "info") (i18nCell MsgAdminProblemInfo) $ \( view $ resultProblem . _entityVal . _problemLogAdminProblem -> p) -> adminProblemCell p , sortable (Just "firm") (i18nCell MsgTableCompany) $ \(preview $ resultProblem . _entityVal . _problemLogAdminProblem . _adminProblemCompany -> c) -> cellMaybe companyIdCell c - , sortable (Just "solved") (i18nCell MsgAdminProblemSolver) $ \( view $ resultProblem . _entityVal . _problemLogSolved -> t) -> cellMaybe dateTimeCell t + , sortable (Just "user") (i18nCell MsgAdminProblemUser) $ \(preview resultUser -> u) -> maybeCell u $ cellHasUserLink AdminUserR + , sortable (Just "solved") (i18nCell MsgAdminProblemSolved) $ \( view $ resultProblem . _entityVal . _problemLogSolved -> t) -> cellMaybe dateTimeCell t , sortable (Just "solver") (i18nCell MsgAdminProblemSolver) $ \(preview resultSolver -> u) -> maybeCell u $ cellHasUserLink AdminUserR ] dbtSorting = mconcat @@ -320,6 +333,7 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..} , single ("info" , SortColumn $ queryProblem >>> (E.^. ProblemLogInfo)) -- , single ("firm" , SortColumn ((E.->>. "company" ).(queryProblem >>> (E.^. ProblemLogInfo)))) , single ("firm" , SortColumn $ \r -> queryProblem r E.^. ProblemLogInfo E.->>. "company") + , single ("user" , sortUserNameBareM queryUser) , single ("solved", SortColumn $ queryProblem >>> (E.^. ProblemLogSolved)) , single ("solver", sortUserNameBareM querySolver) ] @@ -331,7 +345,8 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..} ] acts :: Map ProblemTableAction (AForm Handler ProblemTableActionData) acts = mconcat - [ singletonMap ProblemTableMarkSolved $ pure ProblemTableMarkSolvedData + [ singletonMap ProblemTableMarkSolved $ pure ProblemTableMarkSolvedData + , singletonMap ProblemTableMarkUnsolved $ pure ProblemTableMarkUnsolvedData ] dbtParams = DBParamsForm { dbParamsFormMethod = POST @@ -360,5 +375,9 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..} return (act, usrSet) adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a -adminProblemCell AdminProblemNewCompany{} = i18nCell MsgAdminProblemNewCompany -adminProblemCell AdminProblemUnknown{adminProblemText} = textCell $ "Problem: " <> adminProblemText +adminProblemCell AdminProblemNewCompany{} + = i18nCell MsgAdminProblemNewCompany +adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute} + = i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew +adminProblemCell AdminProblemUnknown{adminProblemText} + = textCell $ "Problem: " <> adminProblemText diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index aae3a9a5c..30011ae98 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -513,25 +513,38 @@ updateAvsUserByIds apids = do -- lift $ do -- no more maybeT neeed from here update usrId usr_ups - -- update company association + -- update company association & supervision oldCompanyMb <- join <$> (getAvsCompany `traverse` oldAvsFirmInfo) - let oldCompanyId = entityKey <$> oldCompanyMb + let oldCompanyId = entityKey <$> oldCompanyMb newCompanyId <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo - -- newCompanyMb <- get newCompanyId - -- adjusting supervisors + newCompanyMb <- get newCompanyId + + -- TODO: possibly change postal preferences + let _prefPostal = maybe True companyPrefersPostal newCompanyMb + -- _primaryCompanyIdMb <- getUserPrimaryCompany usrId (pure . companyShorthand) + -- possibly add to usr_ups! + -- case (oldAvsFirmInfo, oldCompanyMb, newCompanyMb) of case oldAvsFirmInfo of _ | oldCompanyId == Just newCompanyId -- company unchanged entirely -> return () - (Just oafi) | ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- company address unchanged - -> return () - (Just oafi) | ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- company primary email unchanged - -> return () + -- (Just oafi) | ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- company address unchanged + -- -> return () + -- (Just oafi) | ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- company primary email unchanged + -- -> return () _ -- company changed completely -> do -- switch company - whenIsJust oldCompanyId (deleteBy . UniqueUserCompany usrId) - forMM_ (get newCompanyId) $ \Company{} -> - void $ upsertBy (UniqueUserCompany usrId newCompanyId) (UserCompany usrId newCompanyId False False 0 True) [error "continue here"] -- TODO: better defaults + (join <$> ((getBy . UniqueUserCompany usrId) `traverse` oldCompanyId)) >>= (\case + Nothing -> do + void $ insertUnique $ UserCompany usrId newCompanyId False False 1 True + (Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}}) -> do + when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute + delete ucidOld + void $ insertUnique $ UserCompany usrId newCompanyId False False userCompanyPriority True + ) + + -- forMM_ (get newCompanyId) $ \Company{} -> + -- void $ upsertBy (UniqueUserCompany usrId newCompanyId) (UserCompany usrId newCompanyId False False 0 True) [error "continue here"] -- TODO: better defaults let superReasonComDef = tshow SupervisorReasonCompanyDefault superCompanyFilter = maybe [UserSupervisorCompany ==. Nothing] (UserSupervisorCompany ~=.) diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 8c3276d92..7e101eba2 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -15,6 +15,7 @@ module Handler.Utils.Users , guessUser, guessUserByEmail , UserAssimilateException(..), UserAssimilateExceptionReason(..) , assimilateUser + , getUserPrimaryCompany , getUserEmail , getEmailAddress, getJustEmailAddress , getEmailAddressFor, getJustEmailAddressFor @@ -75,8 +76,8 @@ abbrvName User{userDisplayName, userFirstName, userSurname} = assemble = Text.intercalate "." -getUserCompanyAddress :: UserId -> (Company -> Maybe a) -> DB (Maybe a) -getUserCompanyAddress uid prj = runMaybeT $ do +getUserPrimaryCompany :: UserId -> (Company -> Maybe a) -> DB (Maybe a) +getUserPrimaryCompany uid prj = runMaybeT $ do Entity{entityVal=UserCompany{userCompanyCompany=cid}} <- MaybeT $ selectFirst [UserCompanyUser ==. uid, UserCompanyUseCompanyAddress ==. True] [Desc UserCompanyPriority, Desc UserCompanySupervisorReroute, Desc UserCompanySupervisor, Asc UserCompanyCompany] @@ -125,7 +126,7 @@ getUserEmail Entity{entityKey=uid, entityVal=User{userDisplayEmail, userEmail}} = return $ Just userDisplayEmail | otherwise = do - compEmailMb <- getUserCompanyAddress uid companyEmail + compEmailMb <- getUserPrimaryCompany uid companyEmail return $ pickValidEmail' $ mcons compEmailMb [userEmail] -- address is prefixed with userDisplayName @@ -135,7 +136,7 @@ getPostalAddress Entity{entityKey=uid, entityVal=User{..}} = prefixMarkupName pa | otherwise = do - getUserCompanyAddress uid companyPostAddress >>= \case + getUserPrimaryCompany uid companyPostAddress >>= \case (Just pa) -> prefixMarkupName pa Nothing @@ -153,7 +154,7 @@ getPostalAddress' Entity{entityKey=uid, entityVal=User{..}} = return res | otherwise = do - getUserCompanyAddress uid companyPostAddress >>= \case + getUserPrimaryCompany uid companyPostAddress >>= \case res@(Just _) -> return res Nothing diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 9730b0678..73f12b8a7 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -4,13 +4,12 @@ module Utils.DB where -import ClassyPrelude.Yesod +import ClassyPrelude.Yesod hiding (addMessageI) import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Set as Set import qualified Database.Esqueleto.Legacy as E --- import Database.Persist -- currently not needed here import Utils import Control.Lens @@ -20,7 +19,7 @@ import Control.Monad.Catch hiding (bracket) import qualified Utils.Pool as Custom -import Database.Persist.Sql (runSqlConn) +import Database.Persist.Sql (runSqlConn) -- , updateWhereCount) import GHC.Stack (HasCallStack, CallStack, callStack) @@ -219,6 +218,25 @@ class WithRunDB backend m' m | m -> backend m' where instance WithRunDB backend m (ReaderT backend m) where useRunDB = id +-- Could be used at Handler.Admin.postAdminProblemsR, but not yet elsewhere, thus inlined for now, as it may be too special: +-- updateWithMessage +-- :: ( YesodPersist site, PersistEntity val, BackendCompatible SqlBackend (YesodPersistBackend site), PersistEntityBackend val ~ SqlBackend +-- , Num a, Ord a, RenderMessage site msg, RedirectUrl site (url,[(Text,Text)])) +-- => url -- where to redirect, if changes were mage +-- -> [Filter val] -- update filter +-- -> [Update val] -- actual update +-- -> a -- expected updates +-- -> (a -> msg) -- message to add with number of actual changes +-- -> HandlerFor site () +-- updateWithMessage route flt upd no_req msg = do +-- (fromIntegral -> oks) <- runDB $ updateWhereCount flt upd +-- let mkind = if oks < no_req || no_req <= 0 then Warning else Success +-- addMessageI mkind $ msg oks +-- when (oks > 0) $ do -- reload to ensure updates are displayed +-- getps <- reqGetParams <$> getRequest +-- redirect (route, getps) + + -- newtype DBRunner' backend m = DBRunner' { runDBRunner' :: forall b. ReaderT backend m b -> m b } -- _DBRunner' :: Iso' (DBRunner site) (DBRunner' (YesodPersistBackend site) (HandlerFor site)) diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 5b4606153..0b85772af 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -787,6 +787,8 @@ fillDb = do insert_ $ ProblemLog now (toJSON $ AdminProblemNewCompany fraportAg) Nothing Nothing insert_ $ ProblemLog now (toJSON $ AdminProblemNewCompany ffacil ) Nothing Nothing + insert_ $ ProblemLog now (toJSON $ AdminProblemSupervisorNewCompany fhamann fraportAg ffacil True ) Nothing Nothing + insert_ $ ProblemLog now (toJSON $ AdminProblemSupervisorNewCompany gkleen ffacil fraGround False) Nothing Nothing insert_ $ ProblemLog now (toJSON $ AdminProblemUnknown "This is a test problem only.") Nothing Nothing let