refactor(db): widen the type for DBRead for more flexibility also - change some AdminProblemR DB actions to DBRead instead - add insane supervision warning to AdminProblem page
This commit is contained in:
parent
d6b4afe975
commit
8adcdf69fe
@ -1,4 +1,4 @@
|
||||
# SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
# SPDX-FileCopyrightText: 2022-25 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
#
|
||||
# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -112,6 +112,7 @@ ProblemsDriversHaveAvsIds: Alle Inhaber einer Fahrberechtigung konnten einer AVS
|
||||
ProblemsUsersAreReachable: Für alle Benutzer ist eine E-Mail oder postalische Adresse bekannt
|
||||
ProblemsNoStalePrintJobs n@Integer: Alle Briefversandaufträge #{pluralDE n "des vergangenen Tages" ("der vergangenen "<> tshow n <> " Tage")} wurden von der Druckerei bestätigt
|
||||
ProblemsNoBadAPCIds: Alle kürzlich empfangenen Druckauftragsbestätigungen waren gültig
|
||||
ProblemsNoInsaneCompanySupervisions: Sind alle Firmen-bezogenen Ansprechpartnerbeziehungen zwischen passenden Firmenangehörigen?
|
||||
ProblemsUnreachableHeading: Unerreichbare Benutzer
|
||||
ProblemsUnreachableBody: Benutzer ohne E-Mail oder Postadresse, welche z.B. bei ablaufenden Berechtigungen nicht benachrichtigt werden können:
|
||||
ProblemsUnreachableButtons: Synchronisation für Unerreichbare starten
|
||||
@ -123,6 +124,7 @@ ProblemsAvsSynchHeading: Synchronisation AVS Fahrberechtigungen
|
||||
ProblemsAvsErrorHeading: Fehlermeldungen
|
||||
ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit
|
||||
ProblemAvsUsrHadR: Momentan gültiges R im AVS
|
||||
ProblemCheckOncePerDay: Prüfung nur einmal pro Tag
|
||||
|
||||
AdminProblemSolved: Erledigt
|
||||
AdminProblemSolver: Bearbeitet von
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
# SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
# SPDX-FileCopyrightText: 2022-25 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
#
|
||||
# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -112,6 +112,7 @@ ProblemsDriversHaveAvsIds: All driving licence holder could be matched with thei
|
||||
ProblemsUsersAreReachable: Either Email or postal address is known for all users
|
||||
ProblemsNoStalePrintJobs n: All requests for letter mailing within the last #{pluralENsN n "day"} were acknowledged as printed by the airport printing center
|
||||
ProblemsNoBadAPCIds: All recently received print job ids from Airport Print Center were legit
|
||||
ProblemsNoInsaneCompanySupervisions: All company related supervisions are between company-associated users
|
||||
ProblemsUnreachableHeading: Unreachable Users
|
||||
ProblemsUnreachableBody: Users without Email nor postal address, who thus cannot be notified about expiring qualifications:
|
||||
ProblemsUnreachableButtons: Start synchronisation for unreachable users only
|
||||
@ -123,6 +124,7 @@ ProblemsAvsSynchHeading: Synchronisation AVS Driving Licences
|
||||
ProblemsAvsErrorHeading: Error Log
|
||||
ProblemsInterfaceSince: Only considering successes and errors since
|
||||
ProblemAvsUsrHadR: Currenlt R valid in AVS
|
||||
ProblemCheckOncePerDay: Checkd once per day
|
||||
|
||||
AdminProblemSolved: Done
|
||||
AdminProblemSolver: Solved by
|
||||
|
||||
@ -29,10 +29,12 @@ import Foundation.Routes
|
||||
import Foundation.I18n
|
||||
import Foundation.Authorization
|
||||
|
||||
import Utils.Company (areThereInsaneCompanySupervisions)
|
||||
import Utils.Sheet
|
||||
|
||||
import Handler.Utils.DateTime
|
||||
import Handler.Utils.Memcached
|
||||
import Handler.Utils.ExamOffice.Course
|
||||
import Utils.Sheet
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
@ -2458,12 +2460,12 @@ pageActions ApiDocsR = return
|
||||
, navChildren = []
|
||||
}
|
||||
]
|
||||
pageActions FirmAllR = return
|
||||
[ NavPageActionPrimary
|
||||
{ navLink = defNavLink MsgMenuFirmsSupervision FirmsSupervisionR
|
||||
, navChildren = []
|
||||
}
|
||||
]
|
||||
pageActions FirmAllR = do
|
||||
let navLink = defNavLink MsgMenuFirmsSupervision FirmsSupervisionR
|
||||
navChildren = []
|
||||
thereAre <- liftHandler areThereInsaneCompanySupervisions
|
||||
return [ NavPageActionPrimary{..} | thereAre ]
|
||||
|
||||
pageActions (FirmUsersR fsh) = return
|
||||
[ NavPageActionPrimary
|
||||
{ navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
-- SPDX-FileCopyrightText: 2022-26 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -13,7 +13,9 @@ module Foundation.Type
|
||||
, _memcachedKey, _memcachedConn
|
||||
, SMTPPool
|
||||
, _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport, _appMemcached, _appUploadCache, _appVerpSecret, _appAuthKey, _appPersonalisedSheetFilesSeedKey, _appVolatileClusterSettingsCache, _appAvsQuery
|
||||
, DB, DBRead, Form, MsgRenderer, MailM, DBFile
|
||||
, DB
|
||||
, DBRead, DBRead', DBReadUq, DBReadUq'
|
||||
, Form, MsgRenderer, MailM, DBFile
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
@ -105,9 +107,17 @@ instance HasCookieSettings RegisteredCookie UniWorX where
|
||||
instance (MonadHandler m, HandlerSite m ~ UniWorX) => ReadLogSettings m where
|
||||
readLogSettings = liftIO . readTVarIO =<< getsYesod (view _appLogSettings)
|
||||
|
||||
type DB = YesodDB UniWorX
|
||||
type DB = YesodDB UniWorX
|
||||
-- ~ ReaderT SqlBackend (HandlerFor UniWorX)
|
||||
type DBRead = ReaderT SqlReadBackend (HandlerFor UniWorX)
|
||||
-- type DBRead = ReaderT SqlReadBackend (HandlerFor UniWorX) -- old, was too unflexible. Try DBRead first, then add suffixes ' or Uq until it types ;)
|
||||
type DBRead a = forall backend . (PersistQueryRead backend, BackendCompatible SqlBackend backend)
|
||||
=> ReaderT backend (HandlerFor UniWorX) a
|
||||
type DBRead' a = forall backend . (PersistQueryRead backend, BackendCompatible SqlBackend backend, BaseBackend backend ~ SqlBackend) -- ought to be redundant, but somehow isn´t. Using this everywhere give redundant constraint warnings, also undesirable
|
||||
=> ReaderT backend (HandlerFor UniWorX) a
|
||||
type DBReadUq a = forall backend . (PersistQueryRead backend, BackendCompatible SqlBackend backend, PersistUniqueRead backend) -- adding this to DBRead would yield some unnecessary constraint warnings
|
||||
=> ReaderT backend (HandlerFor UniWorX) a
|
||||
type DBReadUq' a = forall backend . (PersistQueryRead backend, BackendCompatible SqlBackend backend, BaseBackend backend ~ SqlBackend, PersistUniqueRead backend)
|
||||
=> ReaderT backend (HandlerFor UniWorX) a
|
||||
type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, WidgetFor UniWorX ())
|
||||
type MsgRenderer = MsgRendererS UniWorX -- see Utils
|
||||
type MailM a = MailT (HandlerFor UniWorX) a
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
-- SPDX-FileCopyrightText: 2022-25 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -25,6 +25,7 @@ import qualified Database.Esqueleto.Legacy as EL (on) -- needed for dbTable
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import Jobs
|
||||
import Utils.Company (areThereInsaneCompanySupervisions)
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Avs
|
||||
import Handler.Utils.Users
|
||||
@ -79,13 +80,14 @@ handleAdminProblems mbProblemTable = do
|
||||
flagNonZero n | n <= 0 = flagError True
|
||||
| otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n))
|
||||
|
||||
(usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, (interfaceOks, interfaceTable)) <- runDB $ (,,,,,)
|
||||
thereAreInsanceFirmSupervisions <- not <$> areThereInsaneCompanySupervisions -- cached for 22h
|
||||
(usersAreReachable, driversHaveAvsIds, rDriversHaveFs, not -> noStalePrintJobs, not -> noBadAPCids) <- runDBRead $ (,,,,)
|
||||
<$> areAllUsersReachable
|
||||
<*> allDriversHaveAvsId now
|
||||
<*> allRDriversHaveFs now
|
||||
<*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <. cutOffOldTime])
|
||||
<*> (not <$> exists [PrintAcknowledgeProcessed ==. False])
|
||||
<*> mkInterfaceLogTable mempty
|
||||
<*> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <. cutOffOldTime]
|
||||
<*> exists [PrintAcknowledgeProcessed ==. False]
|
||||
(interfaceOks, interfaceTable) <- runDB $ mkInterfaceLogTable mempty
|
||||
let interfacesBadNr = length $ filter (not . snd) interfaceOks
|
||||
-- interfacesOk = all snd interfaceOks
|
||||
|
||||
@ -141,7 +143,7 @@ postAdminProblemsR = do
|
||||
getProblemUnreachableR, postProblemUnreachableR :: Handler Html
|
||||
getProblemUnreachableR = postProblemUnreachableR
|
||||
postProblemUnreachableR = do
|
||||
unreachables <- runDB retrieveUnreachableUsers
|
||||
unreachables <- runDBRead retrieveUnreachableUsers
|
||||
|
||||
-- the following form is a nearly identicaly copy from Handler.Users:
|
||||
((noreachUsersRes, noreachUsersWgt'), noreachUsersEnctype) <- runFormPost . identifyForm FIDUnreachableUsersAction $ buttonForm
|
||||
@ -215,7 +217,7 @@ mkUnreachableUsersTable = do
|
||||
dbtColonnade =
|
||||
-}
|
||||
|
||||
areAllUsersReachable :: DB Bool
|
||||
areAllUsersReachable :: DBReadUq' Bool
|
||||
-- areAllUsersReachable = E.selectNotExists retrieveUnreachableUsers' -- works and would be more efficient, but we cannot check proper email validity within DB alone
|
||||
areAllUsersReachable = null <$> retrieveUnreachableUsers
|
||||
|
||||
@ -228,7 +230,7 @@ areAllUsersReachable = null <$> retrieveUnreachableUsers
|
||||
-- E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%")
|
||||
-- return user
|
||||
|
||||
retrieveUnreachableUsers :: DB [Entity User]
|
||||
retrieveUnreachableUsers :: DBReadUq' [Entity User]
|
||||
retrieveUnreachableUsers = do
|
||||
emailOnlyUsers <- E.select $ do
|
||||
user <- E.from $ E.table @User
|
||||
@ -248,7 +250,7 @@ retrieveUnreachableUsers = do
|
||||
hasInvalidEmail = fmap isNothing . getUserEmail
|
||||
|
||||
|
||||
allDriversHaveAvsId :: UTCTime -> DB Bool
|
||||
allDriversHaveAvsId :: UTCTime -> DBReadUq Bool
|
||||
-- allDriversHaveAvsId = fmap isNothing . E.selectOne . retrieveDriversWithoutAvsId
|
||||
allDriversHaveAvsId = E.selectNotExists . retrieveDriversWithoutAvsId
|
||||
|
||||
@ -295,7 +297,7 @@ retrieveDriversWithoutAvsId now = do
|
||||
return usr
|
||||
|
||||
|
||||
allRDriversHaveFs :: UTCTime -> DB Bool
|
||||
allRDriversHaveFs :: UTCTime -> DBReadUq Bool
|
||||
-- allRDriversHaveFs = fmap isNothing . E.selectOne . retrieveDriversRWithoutF
|
||||
allRDriversHaveFs = E.selectNotExists . retrieveDriversRWithoutF
|
||||
|
||||
|
||||
@ -960,7 +960,9 @@ getDifferingLicences (AvsResponseGetLicences licences) = do
|
||||
vorORrollfeld = Set.map avsLicencePersonID vorORrollfeld'
|
||||
rollfeld = Set.map avsLicencePersonID rollfeld'
|
||||
|
||||
antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DBRead (Set AvsPersonId,Set AvsPersonId)
|
||||
antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DBReadUq (Set AvsPersonId,Set AvsPersonId)
|
||||
-- antijoinAvsLicences :: forall backend . (BackendCompatible SqlBackend backend, PersistQueryRead backend, PersistUniqueRead backend)
|
||||
-- => AvsLicence -> Set AvsPersonId -> ReaderT backend (HandlerFor UniWorX) (Set AvsPersonId,Set AvsPersonId)
|
||||
antijoinAvsLicences lic avsLics = fmap unwrapIds $
|
||||
E.select $ do
|
||||
((_qauli :& _qualUser :& usrAvs) :& excl) <-
|
||||
|
||||
@ -63,18 +63,16 @@ import Data.Type.Equality (TestEquality(..))
|
||||
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
|
||||
import Control.Concurrent.STM.Delay
|
||||
import qualified Control.Concurrent.TokenBucket as Concurrent (TokenBucket, newTokenBucket, tokenBucketTryAlloc)
|
||||
import qualified Control.Monad.State.Class as State
|
||||
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
|
||||
import Control.Concurrent.STM.Delay
|
||||
|
||||
import qualified Crypto.Saltine.Class as Saltine
|
||||
import qualified Crypto.Saltine.Internal.ByteSizes as Saltine
|
||||
import qualified Crypto.Saltine.Core.AEAD as AEAD
|
||||
|
||||
import qualified Control.Monad.State.Class as State
|
||||
|
||||
import qualified Data.ByteString.Lazy as Lazy (ByteString)
|
||||
|
||||
import GHC.Fingerprint
|
||||
|
||||
@ -1,8 +1,9 @@
|
||||
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
-- SPDX-FileCopyrightText: 2022-26 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
||||
|
||||
-- NOTE: Also see Handler.Utils.Profile for similar utilities
|
||||
module Handler.Utils.Users
|
||||
@ -78,12 +79,15 @@ abbrvName User{userDisplayName, userFirstName, userSurname} =
|
||||
|
||||
|
||||
-- Note: Entity can be recovered, since CompanyShort is also the key
|
||||
getUserPrimaryCompany :: UserId -> DB (Maybe UserCompany)
|
||||
-- getUserPrimaryCompany :: UserId -> DBRead (Maybe UserCompany)
|
||||
-- getUserPrimaryCompany :: (MonadIO m, PersistQueryRead backend, BaseBackend backend ~ SqlBackend) =>
|
||||
-- UserId -> ReaderT backend m (Maybe UserCompany)
|
||||
getUserPrimaryCompany :: UserId -> DBRead' (Maybe UserCompany)
|
||||
getUserPrimaryCompany uid = entityVal <<$>>
|
||||
selectFirst [UserCompanyUser ==. uid]
|
||||
[Desc UserCompanyPriority, Desc UserCompanySupervisorReroute, Desc UserCompanySupervisor, Asc UserCompanyCompany]
|
||||
|
||||
getUserPrimaryCompanyAddress :: UserId -> (Company -> Maybe a) -> DB (Maybe a)
|
||||
getUserPrimaryCompanyAddress :: UserId -> (Company -> Maybe a) -> DBRead' (Maybe a)
|
||||
getUserPrimaryCompanyAddress uid prj = runMaybeT $ do
|
||||
UserCompany{userCompanyCompany=cid, userCompanyUseCompanyAddress=True} <- MaybeT $ getUserPrimaryCompany uid -- return Nothing if company address is not to be used
|
||||
company <- MaybeT $ get cid
|
||||
@ -93,7 +97,7 @@ getUserPrimaryCompanyAddress uid prj = runMaybeT $ do
|
||||
|
||||
-- | Compute actual address for user; returning True for Postal preference, as well as address (user or company) and primary e-mail
|
||||
-- result (True, Nothing, Nothing) indicates that neither userEmail nor userPostAddress is known
|
||||
getPostalPreferenceAndAddress :: Entity User -> DB (Bool, Maybe [Text], Maybe UserEmail)
|
||||
getPostalPreferenceAndAddress :: Entity User -> DBRead' (Bool, Maybe [Text], Maybe UserEmail)
|
||||
getPostalPreferenceAndAddress usr = do
|
||||
pa <- getPostalAddress usr
|
||||
em <- getUserEmail usr
|
||||
@ -104,7 +108,7 @@ getPostalPreferenceAndAddress usr = do
|
||||
|
||||
-- | result (True, Nothing, Nothing) indicates that neither userEmail nor userPostAddress is known
|
||||
-- primed variant returns storedMarkup without prefixed userDisplayName
|
||||
getPostalPreferenceAndAddress' :: Entity User -> DB (Bool, (Maybe StoredMarkup, Bool), (Maybe UserEmail, Bool))
|
||||
getPostalPreferenceAndAddress' :: Entity User -> DBReadUq' (Bool, (Maybe StoredMarkup, Bool), (Maybe UserEmail, Bool))
|
||||
getPostalPreferenceAndAddress' usr = do
|
||||
pa <- getPostalAddress' usr
|
||||
em <- getUserEmailAutomatic usr
|
||||
@ -113,20 +117,20 @@ getPostalPreferenceAndAddress' usr = do
|
||||
-- finalPref = isJust (fst pa) && (usrPrefPost || isNothing (fst em))
|
||||
return (finalPref, pa, em)
|
||||
|
||||
getEmailAddressFor :: UserId -> DB (Maybe Address)
|
||||
getEmailAddressFor :: UserId -> DBRead' (Maybe Address)
|
||||
getEmailAddressFor = maybeM (return Nothing) getEmailAddress . getEntity
|
||||
|
||||
getJustEmailAddressFor :: UserId -> DB Address
|
||||
getJustEmailAddressFor :: UserId -> DBRead' Address
|
||||
getJustEmailAddressFor = maybeThrowM ExceptionUserHasNoEmail . getEmailAddressFor
|
||||
|
||||
getJustEmailAddress :: Entity User -> DB Address
|
||||
getJustEmailAddress :: Entity User -> DBRead' Address
|
||||
getJustEmailAddress = maybeThrowM ExceptionUserHasNoEmail . getEmailAddress
|
||||
|
||||
getEmailAddress :: Entity User -> DB (Maybe Address)
|
||||
getEmailAddress :: Entity User -> DBRead' (Maybe Address)
|
||||
getEmailAddress usr@Entity{entityVal=User{userDisplayName}} = toAddress <<$>> getUserEmail usr
|
||||
where toAddress = Address (Just userDisplayName) . CI.original
|
||||
|
||||
getUserEmail :: Entity User -> DB (Maybe UserEmail)
|
||||
getUserEmail :: Entity User -> DBRead' (Maybe UserEmail)
|
||||
getUserEmail Entity{entityKey=uid, entityVal=User{userDisplayEmail, userEmail}}
|
||||
| validEmail' userDisplayEmail
|
||||
= return $ Just userDisplayEmail
|
||||
@ -136,7 +140,7 @@ getUserEmail Entity{entityKey=uid, entityVal=User{userDisplayEmail, userEmail}}
|
||||
return $ pickValidEmail' $ mcons compEmailMb [userEmail]
|
||||
|
||||
-- like `getUserEmail`, but also checks whether the Email will be update automatically
|
||||
getUserEmailAutomatic :: Entity User -> DB (Maybe UserEmail, Bool)
|
||||
getUserEmailAutomatic :: Entity User -> DBReadUq' (Maybe UserEmail, Bool)
|
||||
getUserEmailAutomatic Entity{entityKey=uid, entityVal=User{userDisplayEmail, userEmail}}
|
||||
| validEmail' userDisplayEmail
|
||||
= do
|
||||
@ -151,7 +155,7 @@ getUserEmailAutomatic Entity{entityKey=uid, entityVal=User{userDisplayEmail, use
|
||||
_ -> return (Nothing , False)
|
||||
|
||||
-- address is prefixed with userDisplayName
|
||||
getPostalAddress :: Entity User -> DB (Maybe [Text])
|
||||
getPostalAddress :: Entity User -> DBRead' (Maybe [Text])
|
||||
getPostalAddress Entity{entityKey=uid, entityVal=User{..}}
|
||||
| (Just upo) <- userPostAddress, validPostAddress userPostAddress
|
||||
= prefixMarkupName upo
|
||||
@ -169,7 +173,7 @@ getPostalAddress Entity{entityKey=uid, entityVal=User{..}}
|
||||
prefixMarkupName = return . Just . (userDisplayName :) . html2textlines
|
||||
|
||||
-- primed variant returns storedMarkup without prefixed userDisplayName and whether updates are automatic
|
||||
getPostalAddress' :: Entity User -> DB (Maybe StoredMarkup, Bool)
|
||||
getPostalAddress' :: Entity User -> DBReadUq' (Maybe StoredMarkup, Bool)
|
||||
getPostalAddress' Entity{entityKey=uid, entityVal=User{..}}
|
||||
| validPostAddress userPostAddress
|
||||
= do
|
||||
|
||||
46
src/Utils/Company.hs
Normal file
46
src/Utils/Company.hs
Normal file
@ -0,0 +1,46 @@
|
||||
-- SPDX-FileCopyrightText: 2025 Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
module Utils.Company where
|
||||
|
||||
import Import.NoFoundation
|
||||
import Foundation.Type
|
||||
import Foundation.DB
|
||||
|
||||
-- import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
-- import qualified Database.Esqueleto.PostgreSQL as E
|
||||
|
||||
import Handler.Utils.Memcached
|
||||
|
||||
|
||||
-- DB Queries related to firms and supervision that are used in several places
|
||||
|
||||
|
||||
-- | check if a user is NOT associated with a company; false if company is null
|
||||
usrDoesNotBelong :: E.SqlExpr (E.Value UserId) -> E.SqlExpr (E.Value (Maybe CompanyId)) -> E.SqlExpr (E.Value Bool)
|
||||
usrDoesNotBelong uid fsh = E.isJust fsh E.&&. E.notExists (do
|
||||
uc <- E.from $ E.table @UserCompany
|
||||
E.where_ $ uc E.^. UserCompanyUser E.==. uid
|
||||
E.&&. uc E.^. UserCompanyCompany E.=?. fsh
|
||||
)
|
||||
|
||||
-- | given a supervisionship, true if supervisor is NOT associated with the supervisionship-company
|
||||
missingCompanySupervisor :: E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)
|
||||
missingCompanySupervisor us = (us E.^. UserSupervisorSupervisor) `usrDoesNotBelong` (us E.^. UserSupervisorCompany)
|
||||
|
||||
-- | given a supervisionship, true if subordinate is NOT associated with the supervisionship-company
|
||||
missingCompanySubordinate :: E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)
|
||||
missingCompanySubordinate us = (us E.^. UserSupervisorUser) `usrDoesNotBelong` (us E.^. UserSupervisorCompany)
|
||||
|
||||
-- | once per day, check if there are supervisionships where supervisor or subordinate are not associated witht the supervisionship-company
|
||||
areThereInsaneCompanySupervisions :: HandlerFor UniWorX Bool
|
||||
areThereInsaneCompanySupervisions = $(memcachedByHere) (Just . Right $ 22 * diffHour) [st|isane-company-supervision|] $ do
|
||||
res <- runDBRead $ E.selectExists $ do
|
||||
us <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ E.isJust (us E.^. UserSupervisorCompany)
|
||||
E.&&. (missingCompanySupervisor us E.||. missingCompanySubordinate us)
|
||||
$logInfoS "sanity" [st|Are there insane company supervisions: #{tshow res}|]
|
||||
return res
|
||||
@ -1,6 +1,6 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 2022-24 Steffen Jost <s.jost@fraport.de>
|
||||
$# SPDX-FileCopyrightText: 2022-25 Steffen Jost <s.jost@fraport.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -28,7 +28,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
<dd .deflist__dd>^{simpleLinkI MsgProblemsDriverSynch1up ProblemAvsSynchR}
|
||||
|
||||
<dt .deflist__dt>^{flagNonZero ok0}
|
||||
<dd .deflist__dd>^{simpleLinkI MsgProblemsDriverSynch0 ProblemAvsSynchR}
|
||||
<dd .deflist__dd>^{simpleLinkI MsgProblemsDriverSynch0 ProblemAvsSynchR} (_{MsgProblemCheckOncePerDay})
|
||||
|
||||
<dt .deflist__dt>^{flagWarning rDriversHaveFs}
|
||||
<dd .deflist__dd>^{simpleLinkI MsgProblemsRDriversHaveFs ProblemFbutNoR}
|
||||
@ -52,6 +52,9 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
<dt .deflist__dt>^{flagWarning False}
|
||||
<dd .deflist__dd>_{MsgMailRerouteTo reroute}
|
||||
|
||||
<dt .deflist__dt>^{flagError thereAreInsanceFirmSupervisions}
|
||||
<dd .deflist__dd>^{simpleLinkI MsgProblemsNoInsaneCompanySupervisions FirmsSupervisionR}
|
||||
|
||||
<section>
|
||||
<h2>
|
||||
_{MsgMenuInterfaces}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user