chore(avs): WIP update UserCompany accodring to AVS
This commit is contained in:
parent
b51f8a454a
commit
4a51f94a8f
@ -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"}!
|
||||
|
||||
@ -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"}!
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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"
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 ~=.)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user