fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix(avs): company superior emails become company wide supervisors

Browse Source
This commit is contained in:
Steffen Jost 2024-06-27 12:40:35 +02:00
parent 975bf13d9c
commit 37efc89e07
10 changed files with 398 additions and 377 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
messages/uniworx/categories/admin/de-de-formal.msg
View File

@ -67,6 +67,7 @@ BearerTokenExpiresTip: Wird der Ablaufzeitpunkt überschrieben und kein Ablaufze
BearerTokenOverrideStart: Startzeitpunkt BearerTokenOverrideStart: Startzeitpunkt
BearerTokenOverrideStartTip: Wird kein Startzeitpunkt angegeben, wird bei Verwendung des Tokens nur der Ablaufzeitpunkt überprüft. BearerTokenOverrideStartTip: Wird kein Startzeitpunkt angegeben, wird bei Verwendung des Tokens nur der Ablaufzeitpunkt überprüft.
HeadingAdminTokens: Tokens ausstellen HeadingAdminTokens: Tokens ausstellen
UserUnknown: Unbekannter Benutzer:in
#templates adminFeautures #templates adminFeautures
StudyFeaturesDegrees: Abschlüsse StudyFeaturesDegrees: Abschlüsse
@ -127,9 +128,11 @@ AdminProblemCreated: Erkannt
AdminProblemInfo: Problembeschreibung AdminProblemInfo: Problembeschreibung
AdminProblemsSolved n@Int: #{pluralDEeN n "Admin Problem"} als erledigt markiert AdminProblemsSolved n@Int: #{pluralDEeN n "Admin Problem"} als erledigt markiert
AdminProblemsReopened n@Int: #{pluralDEeN n "Admin Problem"} erneut eröffnet AdminProblemsReopened n@Int: #{pluralDEeN n "Admin Problem"} erneut eröffnet
AdminProblemNewCompany: Neue Firma aus AVS automatisch erstellt; prüfen und ggf. Standardansprechpartner eintragen AdminProblemNewCompany: Neue Firma über AVS automatisch erstellt; prüfen und ggf. Standardansprechpartner eintragen
AdminProblemSupervisorNewCompany b@Bool: Dieser Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} wechselte zu neuer Firma AdminProblemSupervisorNewCompany b@Bool: Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} wechselte zu neuer Firma
AdminProblemSupervisorLeftCompany b@Bool: Einziger Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} dieses Fahrers wechselte zu neuer Firma AdminProblemSupervisorLeftCompany b@Bool: Einziger Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} dieses Fahrers wechselte zu neuer Firma
AdminProblemCompanySuperiorChange: Neuer firmenweiter Vorgesetzer.
AdminProblemCompanySuperiorPrevious: Ehemaliger Vorgesetzer:
AdminProblemNewlyUnsupervised: Fahrer hat keinen Firmenansprechpartner mehr nach AVS Firmenwechsel zu Firma AdminProblemNewlyUnsupervised: Fahrer hat keinen Firmenansprechpartner mehr nach AVS Firmenwechsel zu Firma
AdminProblemUser: Betroffener AdminProblemUser: Betroffener
ProblemTableMarkSolved: Als erledigt markieren ProblemTableMarkSolved: Als erledigt markieren

5
messages/uniworx/categories/admin/en-eu.msg
View File

@ -67,6 +67,7 @@ BearerTokenExpiresTip: If no expiration time is given, the token will not expire
BearerTokenOverrideStart: Start time BearerTokenOverrideStart: Start time
BearerTokenOverrideStartTip: If no start time is given, only the expiration time will be checked when the token is used. BearerTokenOverrideStartTip: If no start time is given, only the expiration time will be checked when the token is used.
HeadingAdminTokens: Issue tokens HeadingAdminTokens: Issue tokens
UserUnknown: User unknown
#templates adminfeatures #templates adminfeatures
StudyFeaturesDegrees: Degrees StudyFeaturesDegrees: Degrees
@ -128,8 +129,10 @@ AdminProblemInfo: Problem
AdminProblemsSolved n: #{pluralENsN n "admin problem"} marked as solved AdminProblemsSolved n: #{pluralENsN n "admin problem"} marked as solved
AdminProblemsReopened n: #{pluralENsN n "admin problem"} reopened AdminProblemsReopened n: #{pluralENsN n "admin problem"} reopened
AdminProblemNewCompany: New company from AVS; verify and add default supervisors AdminProblemNewCompany: New company from AVS; verify and add default supervisors
AdminProblemSupervisorNewCompany b: This default company supervisor #{boolText mempty "with reroute" b} changed to new company AdminProblemSupervisorNewCompany b: Default company supervisor #{boolText mempty "with reroute" b} changed to new company
AdminProblemSupervisorLeftCompany b: Only default company supervisor #{boolText mempty "with reroute" b} for this user changed to new company AdminProblemSupervisorLeftCompany b: Only default company supervisor #{boolText mempty "with reroute" b} for this user changed to new company
AdminProblemCompanySuperiorChange: New company wide superior.
AdminProblemCompanySuperiorPrevious: Previous superior:
AdminProblemNewlyUnsupervised: Driver has no longer a company default supervisor after AVS update at new company AdminProblemNewlyUnsupervised: Driver has no longer a company default supervisor after AVS update at new company
AdminProblemUser: Affected AdminProblemUser: Affected
ProblemTableMarkSolved: Mark done ProblemTableMarkSolved: Mark done

15
src/Audit/Types.hs
View File

@ -185,7 +185,7 @@ data Transaction
} }
| TransactionLmsStart | TransactionLmsStart
{ transactionQualification :: QualificationId { transactionQualification :: QualificationId
, transactionLmsIdent :: LmsIdent , transactionLmsIdent :: LmsIdent
, transactionLmsUser :: UserId , transactionLmsUser :: UserId
, transactionLmsUserKey :: LmsUserId , transactionLmsUserKey :: LmsUserId
} }
@ -216,7 +216,7 @@ data Transaction
| TransactionQualificationUserEdit -- Note that a renewal always entails unblocking as well! | TransactionQualificationUserEdit -- Note that a renewal always entails unblocking as well!
{ transactionUser :: UserId -- qualification holder that is updated { transactionUser :: UserId -- qualification holder that is updated
, transactionQualificationUser :: QualificationUserId -- not really necessary, maybe remove? , transactionQualificationUser :: QualificationUserId -- not really necessary, maybe remove?
, transactionQualification :: QualificationId , transactionQualification :: QualificationId
, transactionQualificationValidUntil :: Day , transactionQualificationValidUntil :: Day
, transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration) , transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration)
, transactionNote :: Maybe Text , transactionNote :: Maybe Text
@ -265,7 +265,7 @@ data AdminProblem
= AdminProblemNewCompany -- new company was noticed, presumably without supervisors = AdminProblemNewCompany -- new company was noticed, presumably without supervisors
{ adminProblemCompany :: CompanyId { adminProblemCompany :: CompanyId
} }
| AdminProblemSupervisorNewCompany | AdminProblemSupervisorNewCompany
{ adminProblemUser :: UserId -- a default supervisor has changed company { adminProblemUser :: UserId -- a default supervisor has changed company
, adminProblemCompany :: CompanyId -- old company where the user had default supervisor rights , adminProblemCompany :: CompanyId -- old company where the user had default supervisor rights
, adminProblemCompanyNew :: CompanyId -- new company of the user , adminProblemCompanyNew :: CompanyId -- new company of the user
@ -276,13 +276,18 @@ data AdminProblem
, adminProblemCompany :: CompanyId -- old company , adminProblemCompany :: CompanyId -- old company
, adminProblemSupervisorReroute :: Bool -- reroute included? , adminProblemSupervisorReroute :: Bool -- reroute included?
} }
| AdminProblemNewlyUnsupervised | AdminProblemCompanySuperiorChange -- a company received a new superior user through AVS
{ adminProblemUser :: UserId -- new superior user
, adminProblemCompany :: CompanyId -- affected company
, adminProblemUserOld :: Maybe UserId -- previous superior
}
| AdminProblemNewlyUnsupervised
{ adminProblemUser :: UserId -- user who had a supervisor but no longer has, due to user company change { adminProblemUser :: UserId -- user who had a supervisor but no longer has, due to user company change
, adminProblemCompanyOld :: Maybe CompanyId -- old company , adminProblemCompanyOld :: Maybe CompanyId -- old company
, adminProblemCompanyNew :: CompanyId -- new company of the user , adminProblemCompanyNew :: CompanyId -- new company of the user
} }
| AdminProblemUnknown -- miscellanous problem, just displaying text | AdminProblemUnknown -- miscellanous problem, just displaying text
{ adminProblemText :: Text { adminProblemText :: Text
} }
deriving (Eq, Ord, Read, Show, Generic) deriving (Eq, Ord, Read, Show, Generic)

119
src/Handler/Admin.hs
View File

@ -55,7 +55,7 @@ data ProblemTableActionData = ProblemTableMarkSolvedData
deriving (Eq, Ord, Read, Show, Generic) deriving (Eq, Ord, Read, Show, Generic)
-- Handlers -- Handlers
getAdminR :: Handler Html getAdminR :: Handler Html
getAdminR = redirect AdminProblemsR getAdminR = redirect AdminProblemsR
@ -63,7 +63,7 @@ getAdminProblemsR, postAdminProblemsR :: Handler Html
getAdminProblemsR = handleAdminProblems Nothing getAdminProblemsR = handleAdminProblems Nothing
handleAdminProblems :: Maybe Widget -> Handler Html handleAdminProblems :: Maybe Widget -> Handler Html
handleAdminProblems mbProblemTable = do handleAdminProblems mbProblemTable = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let nowaday = utctDay now let nowaday = utctDay now
cutOffOldDays = 1 cutOffOldDays = 1
@ -75,21 +75,21 @@ handleAdminProblems mbProblemTable = do
msgErrorTooltip <- messageI Error MsgMessageError msgErrorTooltip <- messageI Error MsgMessageError
let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip
flagWarning = messageTooltip . bool msgWarningTooltip msgSuccessTooltip flagWarning = messageTooltip . bool msgWarningTooltip msgSuccessTooltip
flagNonZero :: Int -> Widget flagNonZero :: Int -> Widget
flagNonZero n | n <= 0 = flagError True flagNonZero n | n <= 0 = flagError True
| otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n)) | otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n))
(usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, (interfaceOks, interfaceTable)) <- runDB $ (,,,,,) (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, (interfaceOks, interfaceTable)) <- runDB $ (,,,,,)
<$> areAllUsersReachable <$> areAllUsersReachable
<*> allDriversHaveAvsId now <*> allDriversHaveAvsId now
<*> allRDriversHaveFs now <*> allRDriversHaveFs now
<*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <. cutOffOldTime]) <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <. cutOffOldTime])
<*> (not <$> exists [PrintAcknowledgeProcessed ==. False]) <*> (not <$> exists [PrintAcknowledgeProcessed ==. False])
<*> mkInterfaceLogTable flagError mempty <*> mkInterfaceLogTable flagError mempty
let interfacesBadNr = length $ filter (not . snd) interfaceOks let interfacesBadNr = length $ filter (not . snd) interfaceOks
-- interfacesOk = all snd interfaceOks -- interfacesOk = all snd interfaceOks
diffLics <- try retrieveDifferingLicences >>= \case diffLics <- try retrieveDifferingLicences >>= \case
-- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received" -- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received"
(Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException) (Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException)
@ -118,13 +118,13 @@ handleAdminProblems mbProblemTable = do
setTitleI MsgProblemsHeading setTitleI MsgProblemsHeading
$(widgetFile "admin-problems") $(widgetFile "admin-problems")
postAdminProblemsR = do postAdminProblemsR = do
(problemLogRes, problemLogTable) <- runDB mkProblemLogTable (problemLogRes, problemLogTable) <- runDB mkProblemLogTable
formResult problemLogRes procProblems formResult problemLogRes procProblems
handleAdminProblems $ Just problemLogTable handleAdminProblems $ Just problemLogTable
where where
procProblems :: (ProblemTableActionData, Set ProblemLogId) -> Handler () procProblems :: (ProblemTableActionData, Set ProblemLogId) -> Handler ()
procProblems (ProblemTableMarkSolvedData , pids) = actUpdate True pids procProblems (ProblemTableMarkSolvedData , pids) = actUpdate True pids
procProblems (ProblemTableMarkUnsolvedData, pids) = actUpdate False pids procProblems (ProblemTableMarkUnsolvedData, pids) = actUpdate False pids
actUpdate markdone pids = do actUpdate markdone pids = do
@ -146,7 +146,7 @@ getProblemUnreachableR = do
setTitleI MsgProblemsUnreachableHeading setTitleI MsgProblemsUnreachableHeading
[whamlet| [whamlet|
<section> <section>
#{length unreachables} _{MsgProblemsUnreachableBody} #{length unreachables} _{MsgProblemsUnreachableBody}
<ul> <ul>
$forall usr <- unreachables $forall usr <- unreachables
<li> <li>
@ -154,8 +154,8 @@ getProblemUnreachableR = do
|] |]
getProblemFbutNoR :: Handler Html getProblemFbutNoR :: Handler Html
getProblemFbutNoR = do getProblemFbutNoR = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
rnofs <- runDB $ E.select $ retrieveDriversRWithoutF now rnofs <- runDB $ E.select $ retrieveDriversRWithoutF now
siteLayoutMsg MsgProblemsRWithoutFHeading $ do siteLayoutMsg MsgProblemsRWithoutFHeading $ do
setTitleI MsgProblemsRWithoutFHeading setTitleI MsgProblemsRWithoutFHeading
@ -169,8 +169,8 @@ getProblemFbutNoR = do
|] |]
getProblemWithoutAvsId :: Handler Html getProblemWithoutAvsId :: Handler Html
getProblemWithoutAvsId = do getProblemWithoutAvsId = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
rnofs <- runDB $ E.select $ retrieveDriversWithoutAvsId now rnofs <- runDB $ E.select $ retrieveDriversWithoutAvsId now
siteLayoutMsg MsgProblemsNoAvsIdHeading $ do siteLayoutMsg MsgProblemsNoAvsIdHeading $ do
setTitleI MsgProblemsNoAvsIdHeading setTitleI MsgProblemsNoAvsIdHeading
@ -185,40 +185,40 @@ getProblemWithoutAvsId = do
{- {-
mkUnreachableUsersTable = do mkUnreachableUsersTable = do
let dbtSQLQuery user -> do let dbtSQLQuery user -> do
E.where_ $ E.isNothing (user E.^. UserPostAddress) E.where_ $ E.isNothing (user E.^. UserPostAddress)
E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%") E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%")
pure user pure user
dbtRowKey = (E.^. UserId) dbtRowKey = (E.^. UserId)
dbtProj = dbtProjId dbtProj = dbtProjId
dbtColonnade = dbtColonnade =
-} -}
areAllUsersReachable :: DB Bool areAllUsersReachable :: DB Bool
-- areAllUsersReachable = isNothing <$> E.selectOne retrieveUnreachableUsers' -- areAllUsersReachable = isNothing <$> E.selectOne retrieveUnreachableUsers'
-- areAllUsersReachable = E.selectNotExists retrieveUnreachableUsers' -- areAllUsersReachable = E.selectNotExists retrieveUnreachableUsers'
areAllUsersReachable = null <$> retrieveUnreachableUsers areAllUsersReachable = null <$> retrieveUnreachableUsers
-- retrieveUnreachableUsers' :: E.SqlQuery (E.SqlExpr (Entity User)) -- retrieveUnreachableUsers' :: E.SqlQuery (E.SqlExpr (Entity User))
-- retrieveUnreachableUsers' = do -- retrieveUnreachableUsers' = do
-- user <- E.from $ E.table @User -- user <- E.from $ E.table @User
-- E.where_ $ E.isNothing (user E.^. UserPostAddress) -- E.where_ $ E.isNothing (user E.^. UserPostAddress)
-- E.&&. (E.isNothing (user E.^. UserCompanyDepartment) E.||. user E.^. UserCompanyPersonalNumber `E.ilike` E.justVal "E%") -- E.&&. (E.isNothing (user E.^. UserCompanyDepartment) E.||. user E.^. UserCompanyPersonalNumber `E.ilike` E.justVal "E%")
-- E.&&. E.not_ ((user E.^. UserDisplayEmail) `E.like` E.val "%@%.%") -- E.&&. E.not_ ((user E.^. UserDisplayEmail) `E.like` E.val "%@%.%")
-- E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%") -- E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%")
-- return user -- return user
retrieveUnreachableUsers :: DB [Entity User] retrieveUnreachableUsers :: DB [Entity User]
retrieveUnreachableUsers = do retrieveUnreachableUsers = do
emailOnlyUsers <- E.select $ do emailOnlyUsers <- E.select $ do
user <- E.from $ E.table @User user <- E.from $ E.table @User
E.where_ $ E.isNothing (user E.^. UserPostAddress) E.where_ $ E.isNothing (user E.^. UserPostAddress)
E.&&. (E.isNothing (user E.^. UserCompanyDepartment) E.||. user E.^. UserCompanyPersonalNumber `E.ilike` E.justVal "E%") E.&&. (E.isNothing (user E.^. UserCompanyDepartment) E.||. user E.^. UserCompanyPersonalNumber `E.ilike` E.justVal "E%")
return user return user
filterM hasInvalidEmail emailOnlyUsers filterM hasInvalidEmail emailOnlyUsers
where where
hasInvalidEmail = fmap isNothing . getUserEmail hasInvalidEmail = fmap isNothing . getUserEmail
allDriversHaveAvsId :: UTCTime -> DB Bool allDriversHaveAvsId :: UTCTime -> DB Bool
-- allDriversHaveAvsId = fmap isNothing . E.selectOne . retrieveDriversWithoutAvsId -- allDriversHaveAvsId = fmap isNothing . E.selectOne . retrieveDriversWithoutAvsId
@ -227,17 +227,17 @@ allDriversHaveAvsId = E.selectNotExists . retrieveDriversWithoutAvsId
{- {-
-- | Returns users more than once if they own multiple avs-related valid licences, but no AvsID is known -- | Returns users more than once if they own multiple avs-related valid licences, but no AvsID is known
retrieveDriversWithoutAvsId' :: Day -> E.SqlQuery (E.SqlExpr (Entity User)) retrieveDriversWithoutAvsId' :: Day -> E.SqlQuery (E.SqlExpr (Entity User))
retrieveDriversWithoutAvsId' nowaday = do retrieveDriversWithoutAvsId' nowaday = do
(usr :& qualUsr :& qual) <- E.from $ E.table @User (usr :& qualUsr :& qual) <- E.from $ E.table @User
`E.innerJoin` E.table @QualificationUser `E.innerJoin` E.table @QualificationUser
`E.on` (\(usr :& qualUsr) -> usr E.^. UserId E.==. qualUsr E.^. QualificationUserUser) `E.on` (\(usr :& qualUsr) -> usr E.^. UserId E.==. qualUsr E.^. QualificationUserUser)
`E.innerJoin` E.table @Qualification `E.innerJoin` E.table @Qualification
`E.on` (\(_usr :& qualUsr :& qual) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification) `E.on` (\(_usr :& qualUsr :& qual) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification)
E.where_ $ -- is avs licence E.where_ $ -- is avs licence
E.isJust (qual E.^. QualificationAvsLicence) E.isJust (qual E.^. QualificationAvsLicence)
E.&&. (qualUsr & validQualification nowaday) E.&&. (qualUsr & validQualification nowaday)
E.&&. -- AvsId is unknown E.&&. -- AvsId is unknown
E.notExists (do E.notExists (do
avsUsr <- E.from $ E.table @UserAvs avsUsr <- E.from $ E.table @UserAvs
E.where_ $ avsUsr E.^. UserAvsUser E.==. usr E.^. UserId E.where_ $ avsUsr E.^. UserAvsUser E.==. usr E.^. UserId
) )
@ -246,20 +246,20 @@ retrieveDriversWithoutAvsId' nowaday = do
-- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known -- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known
retrieveDriversWithoutAvsId :: UTCTime -> E.SqlQuery (E.SqlExpr (Entity User)) retrieveDriversWithoutAvsId :: UTCTime -> E.SqlQuery (E.SqlExpr (Entity User))
retrieveDriversWithoutAvsId now = do retrieveDriversWithoutAvsId now = do
usr <- E.from $ E.table @User usr <- E.from $ E.table @User
E.where_ $ E.where_ $
E.exists (do -- a valid avs licence E.exists (do -- a valid avs licence
(qual :& qualUsr) <- E.from (E.table @Qualification (qual :& qualUsr) <- E.from (E.table @Qualification
`E.innerJoin` E.table @QualificationUser `E.innerJoin` E.table @QualificationUser
`E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification)) `E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification))
E.where_ $ -- is avs licence E.where_ $ -- is avs licence
E.isJust (qual E.^. QualificationAvsLicence) E.isJust (qual E.^. QualificationAvsLicence)
E.&&. (qualUsr & validQualification now) -- currently valid E.&&. (qualUsr & validQualification now) -- currently valid
E.&&. -- matches user E.&&. -- matches user
(qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId) (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId)
) )
E.&&. E.&&.
E.notExists (do -- a known AvsId E.notExists (do -- a known AvsId
avsUsr <- E.from $ E.table @UserAvs avsUsr <- E.from $ E.table @UserAvs
E.where_ $ avsUsr E.^. UserAvsUser E.==. usr E.^. UserId E.where_ $ avsUsr E.^. UserAvsUser E.==. usr E.^. UserId
@ -268,20 +268,20 @@ retrieveDriversWithoutAvsId now = do
allRDriversHaveFs :: UTCTime -> DB Bool allRDriversHaveFs :: UTCTime -> DB Bool
-- allRDriversHaveFs = fmap isNothing . E.selectOne . retrieveDriversRWithoutF -- allRDriversHaveFs = fmap isNothing . E.selectOne . retrieveDriversRWithoutF
allRDriversHaveFs = E.selectNotExists . retrieveDriversRWithoutF allRDriversHaveFs = E.selectNotExists . retrieveDriversRWithoutF
-- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known -- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known
retrieveDriversRWithoutF :: UTCTime -> E.SqlQuery (E.SqlExpr (Entity User)) retrieveDriversRWithoutF :: UTCTime -> E.SqlQuery (E.SqlExpr (Entity User))
retrieveDriversRWithoutF now = do retrieveDriversRWithoutF now = do
usr <- E.from $ E.table @User usr <- E.from $ E.table @User
let hasValidQual lic = do let hasValidQual lic = do
(qual :& qualUsr) <- E.from (E.table @Qualification (qual :& qualUsr) <- E.from (E.table @Qualification
`E.innerJoin` E.table @QualificationUser `E.innerJoin` E.table @QualificationUser
`E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification)) `E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification))
E.where_ $ (qual E.^. QualificationAvsLicence E.==. E.justVal lic) -- matches licence E.where_ $ (qual E.^. QualificationAvsLicence E.==. E.justVal lic) -- matches licence
E.&&. (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId) -- matches user E.&&. (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId) -- matches user
E.&&. (qualUsr & validQualification now) -- currently valid E.&&. (qualUsr & validQualification now) -- currently valid
E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld) E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld)
E.&&. E.notExists (hasValidQual AvsLicenceVorfeld) E.&&. E.notExists (hasValidQual AvsLicenceVorfeld)
return usr return usr
@ -375,28 +375,5 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
return (act, usrSet) return (act, usrSet)
-- adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a -- adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a -- moved to Handler.Utils
-- -- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns -- msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX) -- moved to Handler.Utils
-- adminProblemCell AdminProblemNewCompany{}
-- = i18nCell MsgAdminProblemNewCompany
-- adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute}
-- = i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew
-- adminProblemCell AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute}
-- = i18nCell (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute)
-- adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew}
-- = i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew
-- adminProblemCell AdminProblemUnknown{adminProblemText}
-- = textCell $ "Problem: " <> adminProblemText
-- msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX)
-- msgAdminProblem AdminProblemNewCompany{adminProblemCompany=comp} = return $
-- SomeMessages [SomeMessage MsgAdminProblemNewCompany, text2message ": ", company2msg comp]
-- msgAdminProblem AdminProblemSupervisorNewCompany{adminProblemCompany=comp, adminProblemCompanyNew=newComp} = return $
-- SomeMessages [SomeMessage MsgAdminProblemSupervisorNewCompany, text2message ": ", company2msg comp, text2message " -> ", company2msg newComp]
-- msgAdminProblem AdminProblemSupervisorLeftCompany{adminProblemCompany=comp} = return $
-- SomeMessages [SomeMessage MsgAdminProblemSupervisorLeftCompany, text2message ": ", company2msg comp]
-- msgAdminProblem AdminProblemNewlyUnsupervised{adminProblemCompanyOld=comp, adminProblemCompanyNew=newComp} = return $
-- SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp]
-- msgAdminProblem AdminProblemUnknown{adminProblemText=err} = return $
-- someMessages ["Problem: ", err]

39
src/Handler/Utils.hs
View File

@ -150,47 +150,53 @@ reload r = getCurrentRoute >>= redirect . fromMaybe r
-- | like `reload` to current route, but also preserving all GET parameters, using the current route, if known -- | like `reload` to current route, but also preserving all GET parameters, using the current route, if known
reloadKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a reloadKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
reloadKeepGetParams r = liftHandler $ do reloadKeepGetParams r = liftHandler $ do
getps <- reqGetParams <$> getRequest getps <- reqGetParams <$> getRequest
route <- fromMaybe r <$> getCurrentRoute route <- fromMaybe r <$> getCurrentRoute
-- addMessage Info $ toHtml (show getps) -- DEBUG ONLY -- addMessage Info $ toHtml (show getps) -- DEBUG ONLY
-- RECALL: redirect GET parameters are used like so: -- redirect (UsersR, [("users-user-company","fraport")]) -- RECALL: redirect GET parameters are used like so: -- redirect (UsersR, [("users-user-company","fraport")])
redirect (route, getps) redirect (route, getps)
-- | like `reloadKeepGetParams`, but always leading to the specific route instead of the current route -- | like `reloadKeepGetParams`, but always leading to the specific route instead of the current route
redirectKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a redirectKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
redirectKeepGetParams route = liftHandler $ do redirectKeepGetParams route = liftHandler $ do
getps <- reqGetParams <$> getRequest getps <- reqGetParams <$> getRequest
redirect (route, getps) redirect (route, getps)
adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a adminProblemCell :: (IsDBTable m a) => AdminProblem -> DBCell m a
-- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns -- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns
adminProblemCell AdminProblemNewCompany{} adminProblemCell AdminProblemNewCompany{}
= i18nCell MsgAdminProblemNewCompany = i18nCell MsgAdminProblemNewCompany
adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute} adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute}
= i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew = i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew
adminProblemCell AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute} adminProblemCell AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute}
= i18nCell (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute) = i18nCell (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute)
adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew} adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld=Nothing}
= i18nCell MsgAdminProblemCompanySuperiorChange
adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld=Just uid}
= i18nCell MsgAdminProblemCompanySuperiorChange <> spacerCell <> i18nCell MsgAdminProblemCompanySuperiorPrevious <> anchorCellM (AdminUserR <$> encrypt uid) (userIdWidget uid)
adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew}
= i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew = i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew
adminProblemCell AdminProblemUnknown{adminProblemText} adminProblemCell AdminProblemUnknown{adminProblemText}
= textCell $ "Problem: " <> adminProblemText = textCell $ "Problem: " <> adminProblemText
company2msg :: CompanyId -> SomeMessage UniWorX company2msg :: CompanyId -> SomeMessage UniWorX
company2msg = text2message . ciOriginal . unCompanyKey company2msg = text2message . ciOriginal . unCompanyKey
msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX) msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX)
msgAdminProblem AdminProblemNewCompany{adminProblemCompany=comp} = return $ msgAdminProblem AdminProblemNewCompany{adminProblemCompany=comp} = return $
SomeMessages [SomeMessage MsgAdminProblemNewCompany, text2message ": ", company2msg comp] SomeMessages [SomeMessage MsgAdminProblemNewCompany, text2message ": ", company2msg comp]
msgAdminProblem AdminProblemSupervisorNewCompany{adminProblemCompany=comp, adminProblemCompanyNew=newComp, adminProblemSupervisorReroute=rer} = return $ msgAdminProblem AdminProblemSupervisorNewCompany{adminProblemCompany=comp, adminProblemCompanyNew=newComp, adminProblemSupervisorReroute=rer} = return $
SomeMessages [SomeMessage $ MsgAdminProblemSupervisorNewCompany rer, text2message ": ", company2msg comp, text2message " -> ", company2msg newComp] SomeMessages [SomeMessage $ MsgAdminProblemSupervisorNewCompany rer, text2message ": ", company2msg comp, text2message " -> ", company2msg newComp]
msgAdminProblem AdminProblemSupervisorLeftCompany{adminProblemCompany=comp, adminProblemSupervisorReroute=rer} = return $ msgAdminProblem AdminProblemSupervisorLeftCompany{adminProblemCompany=comp, adminProblemSupervisorReroute=rer} = return $
SomeMessages [SomeMessage $ MsgAdminProblemSupervisorLeftCompany rer, text2message ": ", company2msg comp] SomeMessages [SomeMessage $ MsgAdminProblemSupervisorLeftCompany rer, text2message ": ", company2msg comp]
msgAdminProblem AdminProblemNewlyUnsupervised{adminProblemCompanyOld=comp, adminProblemCompanyNew=newComp} = return $ msgAdminProblem AdminProblemCompanySuperiorChange{adminProblemCompany=comp} = return $
SomeMessages [SomeMessage $ MsgAdminProblemCompanySuperiorChange, text2message ": ", company2msg comp]
msgAdminProblem AdminProblemNewlyUnsupervised{adminProblemCompanyOld=comp, adminProblemCompanyNew=newComp} = return $
SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp] SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp]
msgAdminProblem AdminProblemUnknown{adminProblemText=err} = return $ msgAdminProblem AdminProblemUnknown{adminProblemText=err} = return $
someMessages ["Problem: ", err] someMessages ["Problem: ", err]
updateAutomatic :: Bool -> Widget updateAutomatic :: Bool -> Widget
-- updateAutomatic = iconTooltip [whamlet|_{MsgNoAutomaticUpdateTip}|] (Just IconLocked) -- updateAutomatic = iconTooltip [whamlet|_{MsgNoAutomaticUpdateTip}|] (Just IconLocked)
@ -198,4 +204,3 @@ updateAutomatic True = mempty
updateAutomatic False = do updateAutomatic False = do
msg <- messageIconI Warning IconLocked MsgNoAutomaticUpdateTip msg <- messageIconI Warning IconLocked MsgNoAutomaticUpdateTip
messageTooltip msg messageTooltip msg

344
src/Handler/Utils/Avs.hs
View File

@ -14,7 +14,7 @@ module Handler.Utils.Avs
, upsertAvsUserById , upsertAvsUserById
, updateAvsUserByIds , updateAvsUserByIds
, linktoAvsUserByUIDs , linktoAvsUserByUIDs
, queueAvsUpdateByUID, queueAvsUpdateByAID , queueAvsUpdateByUID, queueAvsUpdateByAID
-- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface -- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
, AvsLicenceDifferences(..) , AvsLicenceDifferences(..)
, setLicence, setLicenceAvs, setLicencesAvs , setLicence, setLicenceAvs, setLicencesAvs
@ -26,9 +26,9 @@ module Handler.Utils.Avs
, AvsException(..) , AvsException(..)
, updateReceivers , updateReceivers
, AvsPersonIdMapPersonCard , AvsPersonIdMapPersonCard
-- CR3 -- CR3
, SomeAvsQuery(..) , SomeAvsQuery(..)
, queryAvsCardNo, queryAvsCardNos , queryAvsCardNo, queryAvsCardNos
) where ) where
import Import import Import
@ -106,14 +106,14 @@ catchAll2log = voidMaybe $ catchAVShandler True True False Nothing
catchAVShandler :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => Bool -> Bool -> Bool -> a -> m a -> m a catchAVShandler :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => Bool -> Bool -> Bool -> a -> m a -> m a
catchAVShandler allEx toLog toMsg dft act = act `catches` (avsHandlers <> allHandlers) catchAVShandler allEx toLog toMsg dft act = act `catches` (avsHandlers <> allHandlers)
where where
avsHandlers = avsHandlers =
[ Catch.Handler (\(exc::AvsException) -> liftHandler $ do [ Catch.Handler (\(exc::AvsException) -> liftHandler $ do
let txt = "AVS exception ignored: " <> tshow exc let txt = "AVS exception ignored: " <> tshow exc
when toLog $ $logErrorS "AVS" txt when toLog $ $logErrorS "AVS" txt
when toMsg $ addMessageI Warning exc when toMsg $ addMessageI Warning exc
return dft return dft
) )
, Catch.Handler (\(exc::ClientError ) -> liftHandler $ do , Catch.Handler (\(exc::ClientError ) -> liftHandler $ do
let txt = "AVS fatal communicaton failure: " <> tshow exc let txt = "AVS fatal communicaton failure: " <> tshow exc
when toLog $ $logErrorS "AVS" txt when toLog $ $logErrorS "AVS" txt
@ -139,8 +139,8 @@ catchAVShandler allEx toLog toMsg dft act = act `catches` (avsHandlers <> allHan
-- convenience wrapper for easy replacement with true status query -- convenience wrapper for easy replacement with true status query
queryAvsFullStatus :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => AvsPersonId -> m AvsResponseStatus queryAvsFullStatus :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => AvsPersonId -> m AvsResponseStatus
queryAvsFullStatus api = queryAvsFullStatus api =
lookupAvsUser api <&> \case lookupAvsUser api <&> \case
Just AvsDataPerson{avsPersonPersonCards=cards} Just AvsDataPerson{avsPersonPersonCards=cards}
| notNull cards -> AvsResponseStatus $ Set.singleton $ AvsStatusPerson api cards | notNull cards -> AvsResponseStatus $ Set.singleton $ AvsStatusPerson api cards
_otherwise -> AvsResponseStatus mempty _otherwise -> AvsResponseStatus mempty
@ -158,7 +158,7 @@ lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api)
-- Does not write to our own DB! -- Does not write to our own DB!
lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
Set AvsPersonId -> m (Map AvsPersonId AvsDataPerson) Set AvsPersonId -> m (Map AvsPersonId AvsDataPerson)
lookupAvsUsers apis = do lookupAvsUsers apis = do
AvsResponseStatus statuses <- avsQuery $ AvsQueryStatus apis AvsResponseStatus statuses <- avsQuery $ AvsQueryStatus apis
let forFoldlM = $(permuteFun [3,2,1]) foldlM let forFoldlM = $(permuteFun [3,2,1]) foldlM
forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} -> forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} ->
@ -171,15 +171,15 @@ lookupAvsUsers apis = do
updateReceivers :: UserId -> Handler (Entity User, [Entity User], Bool) updateReceivers :: UserId -> Handler (Entity User, [Entity User], Bool)
updateReceivers uid = do updateReceivers uid = do
-- First perform AVS update for receiver -- First perform AVS update for receiver
runDB (getBy (UniqueUserAvsUser uid)) >>= \case runDB (getBy (UniqueUserAvsUser uid)) >>= \case
Just Entity{entityVal=UserAvs{userAvsPersonId = apid}} -> catchAll2log $ upsertAvsUserById apid Just Entity{entityVal=UserAvs{userAvsPersonId = apid}} -> catchAll2log $ upsertAvsUserById apid
Nothing -> return () Nothing -> return ()
-- Retrieve updated user and supervisors now -- Retrieve updated user and supervisors now
(underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDB $ (,) (underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDB $ (,)
<$> getJustEntity uid <$> getJustEntity uid
<*> (E.select $ do <*> (E.select $ do
(usrSuper :& usrAvs) <- (usrSuper :& usrAvs) <-
E.from $ E.table @UserSupervisor E.from $ E.table @UserSupervisor
`E.leftJoin` E.table @UserAvs `E.leftJoin` E.table @UserAvs
`E.on` (\(usrSuper :& userAvs) -> usrSuper E.^. UserSupervisorSupervisor E.=?. userAvs E.?. UserAvsUser) `E.on` (\(usrSuper :& userAvs) -> usrSuper E.^. UserSupervisorSupervisor E.=?. userAvs E.?. UserAvsUser)
E.where_ $ (usrSuper E.^. UserSupervisorUser E.==. E.val uid) E.where_ $ (usrSuper E.^. UserSupervisorUser E.==. E.val uid)
@ -187,13 +187,13 @@ updateReceivers uid = do
pure (usrSuper E.^. UserSupervisorSupervisor, usrAvs E.?. UserAvsPersonId) pure (usrSuper E.^. UserSupervisorSupervisor, usrAvs E.?. UserAvsPersonId)
) )
let (superVs, avsIds) = unzip avsSupers let (superVs, avsIds) = unzip avsSupers
receiverIDs :: [UserId] = E.unValue <$> superVs receiverIDs :: [UserId] = E.unValue <$> superVs
toUpdate = Set.fromList $ mapMaybe E.unValue avsIds toUpdate = Set.fromList $ mapMaybe E.unValue avsIds
directResult = return (underling, pure underling, True) -- already contains updated address directResult = return (underling, pure underling, True) -- already contains updated address
forM_ toUpdate (catchAll2log . upsertAvsUserById) -- attempt to update postaddress from AVS forM_ toUpdate (catchAll2log . upsertAvsUserById) -- attempt to update postaddress from AVS
if null receiverIDs if null receiverIDs
then directResult then directResult
else do else do
receivers <- runDB $ selectList [UserId <-. receiverIDs] [] -- due to possible address updates, we must runDB once more and cannot join above receivers <- runDB $ selectList [UserId <-. receiverIDs] [] -- due to possible address updates, we must runDB once more and cannot join above
if null receivers if null receivers
then directResult then directResult
@ -205,8 +205,8 @@ updateReceivers uid = do
-- | `SomeAvsQuery` is an umbrella to unify usage of all AVS queries, since Servant required separate types to fit the existing AVS-VSM API -- | `SomeAvsQuery` is an umbrella to unify usage of all AVS queries, since Servant required separate types to fit the existing AVS-VSM API
class SomeAvsQuery q where class SomeAvsQuery q where
type SomeAvsResponse q :: Type type SomeAvsResponse q :: Type
pickQuery :: (MonadIO m) => AvsQuery -> q -> m (Either ClientError (SomeAvsResponse q)) pickQuery :: (MonadIO m) => AvsQuery -> q -> m (Either ClientError (SomeAvsResponse q))
-- | send query to AVS or maybe look it up within cache, depending on the type of the query -- | send query to AVS or maybe look it up within cache, depending on the type of the query
avsQuery :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q) avsQuery :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
@ -217,13 +217,13 @@ class SomeAvsQuery q where
avsQueryNoCacheDefault :: (SomeAvsQuery q avsQueryNoCacheDefault :: (SomeAvsQuery q
, MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q) , MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
avsQueryNoCacheDefault qry = do avsQueryNoCacheDefault qry = do
qfun <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ preview (_appAvsQuery . _Just . to pickQuery) qfun <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ preview (_appAvsQuery . _Just . to pickQuery)
throwLeftM $ qfun qry throwLeftM $ qfun qry
avsQueryCached :: (SomeAvsQuery q, Binary q, Binary (SomeAvsResponse q), Typeable (SomeAvsResponse q), NFData (SomeAvsResponse q) avsQueryCached :: (SomeAvsQuery q, Binary q, Binary (SomeAvsResponse q), Typeable (SomeAvsResponse q), NFData (SomeAvsResponse q)
, MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q) , MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
avsQueryCached qry = avsQueryCached qry =
getsYesod (preview $ _appAvsConf . _Just . _avsCacheExpiry) >>= \case getsYesod (preview $ _appAvsConf . _Just . _avsCacheExpiry) >>= \case
Just t | t > 1 -> memcachedBy (Just $ Right t) qry $ avsQueryNoCache qry Just t | t > 1 -> memcachedBy (Just $ Right t) qry $ avsQueryNoCache qry
_ -> avsQueryNoCache qry _ -> avsQueryNoCache qry
@ -232,7 +232,7 @@ instance SomeAvsQuery AvsQueryPerson where
type SomeAvsResponse AvsQueryPerson = AvsResponsePerson type SomeAvsResponse AvsQueryPerson = AvsResponsePerson
pickQuery = avsQueryPerson pickQuery = avsQueryPerson
avsQuery = avsQueryCached avsQuery = avsQueryCached
instance SomeAvsQuery AvsQueryStatus where instance SomeAvsQuery AvsQueryStatus where
type SomeAvsResponse AvsQueryStatus = AvsResponseStatus type SomeAvsResponse AvsQueryStatus = AvsResponseStatus
pickQuery = avsQueryStatus pickQuery = avsQueryStatus
@ -246,24 +246,24 @@ instance SomeAvsQuery AvsQueryContact where
instance SomeAvsQuery AvsQuerySetLicences where instance SomeAvsQuery AvsQuerySetLicences where
type SomeAvsResponse AvsQuerySetLicences = AvsResponseSetLicences type SomeAvsResponse AvsQuerySetLicences = AvsResponseSetLicences
pickQuery = avsQuerySetLicences pickQuery = avsQuerySetLicences
-- NOTE: avsQuery = avsQueryCached -- should not and indeed does not compile -- NOTE: avsQuery = avsQueryCached -- should not and indeed does not compile
avsQueryNoCache qry = avsQueryNoCacheDefault qry avsQueryNoCache qry = avsQueryNoCacheDefault qry
<* memcachedInvalidate (Proxy @AvsResponseContact) -- invalidate all AvsResponseContact which may contain RampLicence info, since keys may comprise several ids <* memcachedInvalidate (Proxy @AvsResponseContact) -- invalidate all AvsResponseContact which may contain RampLicence info, since keys may comprise several ids
instance SomeAvsQuery AvsQueryGetAllLicences where instance SomeAvsQuery AvsQueryGetAllLicences where
type SomeAvsResponse AvsQueryGetAllLicences = AvsResponseGetLicences type SomeAvsResponse AvsQueryGetAllLicences = AvsResponseGetLicences
pickQuery = const . avsQueryGetAllLicences pickQuery = const . avsQueryGetAllLicences
queryAvsCardNos :: Foldable t => t (Either AvsCardNo AvsFullCardNo) -> Handler (Set AvsPersonId) queryAvsCardNos :: Foldable t => t (Either AvsCardNo AvsFullCardNo) -> Handler (Set AvsPersonId)
queryAvsCardNos = foldMapM queryAvsCardNo queryAvsCardNos = foldMapM queryAvsCardNo
queryAvsCardNo :: Either AvsCardNo AvsFullCardNo -> Handler (Set AvsPersonId) queryAvsCardNo :: Either AvsCardNo AvsFullCardNo -> Handler (Set AvsPersonId)
queryAvsCardNo crd = do queryAvsCardNo crd = do
AvsResponsePerson adps <- avsQuery $ qry crd AvsResponsePerson adps <- avsQuery $ qry crd
return $ Set.map avsPersonPersonID adps return $ Set.map avsPersonPersonID adps
where where
qry (Left acno) = def{ avsPersonQueryCardNo = Just acno } qry (Left acno) = def{ avsPersonQueryCardNo = Just acno }
qry (Right AvsFullCardNo{..}) = def{ avsPersonQueryCardNo = Just avsFullCardNo qry (Right AvsFullCardNo{..}) = def{ avsPersonQueryCardNo = Just avsFullCardNo
, avsPersonQueryVersionNo = Just avsFullCardVersion , avsPersonQueryVersionNo = Just avsFullCardVersion
@ -271,7 +271,7 @@ queryAvsCardNo crd = do
-- | Queries AVS Status to retrieve primary card (heursitic) -- | Queries AVS Status to retrieve primary card (heursitic)
queryAvsPrimaryCard :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => AvsPersonId -> m (Maybe AvsDataPersonCard) queryAvsPrimaryCard :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => AvsPersonId -> m (Maybe AvsDataPersonCard)
queryAvsPrimaryCard api = runMaybeT $ do queryAvsPrimaryCard api = runMaybeT $ do
AvsResponseStatus res <- MaybeT . catchAVS2log . fmap Just . avsQuery . AvsQueryStatus $ Set.singleton api AvsResponseStatus res <- MaybeT . catchAVS2log . fmap Just . avsQuery . AvsQueryStatus $ Set.singleton api
pstatus <- hoistMaybe $ Set.lookupMax $ Set.filter ((api ==) . avsStatusPersonID) res pstatus <- hoistMaybe $ Set.lookupMax $ Set.filter ((api ==) . avsStatusPersonID) res
hoistMaybe $ Set.lookupMax $ avsStatusPersonCardStatus pstatus hoistMaybe $ Set.lookupMax $ avsStatusPersonCardStatus pstatus
@ -285,7 +285,7 @@ queryAvsFullCardNo = fmap (fmap getFullCardNo) . queryAvsPrimaryCard
-- | Like `updateAvsUserByIds`, but exceptions are not caught here to allow rollbacks -- | Like `updateAvsUserByIds`, but exceptions are not caught here to allow rollbacks
updateAvsUserById :: AvsPersonId -> DB (Maybe UserId) updateAvsUserById :: AvsPersonId -> DB (Maybe UserId)
updateAvsUserById apid = do updateAvsUserById apid = do
AvsResponseContact adcs <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId apid AvsResponseContact adcs <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId apid
let res = Set.filter ((== apid) . avsContactPersonID) adcs let res = Set.filter ((== apid) . avsContactPersonID) adcs
snd <<$>> traverseJoin updateAvsUserByADC (Set.lookupMax res) snd <<$>> traverseJoin updateAvsUserByADC (Set.lookupMax res)
@ -306,10 +306,10 @@ updateAvsUserByIds' apids = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
runDB $ updateWhere [UserAvsPersonId <-. missing] [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just "Avs contact info unknown for AvsPersonId"] -- all others were already marked as updated runDB $ updateWhere [UserAvsPersonId <-. missing] [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just "Avs contact info unknown for AvsPersonId"] -- all others were already marked as updated
return oks return oks
where where
procResp :: (Set (AvsPersonId, UserId), Set AvsPersonId) -> AvsDataContact -> Handler (Set (AvsPersonId, UserId), Set AvsPersonId) procResp :: (Set (AvsPersonId, UserId), Set AvsPersonId) -> AvsDataContact -> Handler (Set (AvsPersonId, UserId), Set AvsPersonId)
procResp (accOk, accBad) adc = do procResp (accOk, accBad) adc = do
let errHandler e = runDB $ do let errHandler e = runDB $ do
let apid = avsContactPersonID adc let apid = avsContactPersonID adc
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
updateBy (UniqueUserAvsId apid) [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just (tshow e)] updateBy (UniqueUserAvsId apid) [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just (tshow e)]
@ -319,19 +319,19 @@ updateAvsUserByIds' apids = do
res <- updateAvsUserByADC adc res <- updateAvsUserByADC adc
return (maybeInsert res accOk, accBad) return (maybeInsert res accOk, accBad)
catchAll (runDB updateAvsUserByADC') errHandler catchAll (runDB updateAvsUserByADC') errHandler
updateAvsUserByADC :: AvsDataContact -> DB (Maybe (AvsPersonId, UserId)) updateAvsUserByADC :: AvsDataContact -> DB (Maybe (AvsPersonId, UserId))
updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMaybeT $ do updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMaybeT $ do
(Entity uaId usravs) <- MaybeT $ getBy $ UniqueUserAvsId apid (Entity uaId usravs) <- MaybeT $ getBy $ UniqueUserAvsId apid
let usrId = userAvsUser usravs let usrId = userAvsUser usravs
usr <- MaybeT $ get usrId usr <- MaybeT $ get usrId
lift $ do -- maybeT no longer needed from here onwards lift $ do -- maybeT no longer needed from here onwards
let oldAvsPersonInfo = userAvsLastPersonInfo usravs -- Nothing is ok here let oldAvsPersonInfo = userAvsLastPersonInfo usravs -- Nothing is ok here
oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing is ok here oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing is ok here
oldAvsCardNo = userAvsLastCardNo usravs & fmap Just oldAvsCardNo = userAvsLastCardNo usravs & fmap Just
oldAvsDataContact = case (oldAvsPersonInfo, oldAvsFirmInfo) of oldAvsDataContact = case (oldAvsPersonInfo, oldAvsFirmInfo) of
(Just oapi, Just oafi) -> Just $ AvsDataContact apid oapi oafi (Just oapi, Just oafi) -> Just $ AvsDataContact apid oapi oafi
_ -> Nothing _ -> Nothing
newAvsCardNo <- queryAvsFullCardNo apid -- Nothing os ok here, does not throw newAvsCardNo <- queryAvsFullCardNo apid -- Nothing os ok here, does not throw
@ -339,10 +339,10 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
mbLdapExpire <- getsYesod $ views appSettings appSynchroniseLdapUsersExpire mbLdapExpire <- getsYesod $ views appSettings appSynchroniseLdapUsersExpire
ldap_ups <- if | Just ldapExpire <- mbLdapExpire ldap_ups <- if | Just ldapExpire <- mbLdapExpire
, maybe True (\lastLdapSync -> now > addUTCTime ldapExpire lastLdapSync) (userLastLdapSynchronisation usr) , maybe True (\lastLdapSync -> now > addUTCTime ldapExpire lastLdapSync) (userLastLdapSynchronisation usr)
, Just udep <- userCompanyDepartment usr , Just udep <- userCompanyDepartment usr
, let aipn = newAvsPersonInfo ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo , let aipn = newAvsPersonInfo ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
depKey = CompanyKey $ stripCI udep -- Shorthand is returned by LDAP depKey = CompanyKey $ stripCI udep -- Shorthand is returned by LDAP
-> do -- LDAP sync invalid/expired -> do -- LDAP sync invalid/expired
usrComp <- getBy $ UniqueUserCompany usrId depKey usrComp <- getBy $ UniqueUserCompany usrId depKey
whenIsJust usrComp $ \Entity{entityKey=ucKey, entityVal=UserCompany{userCompanySupervisor=isSuper, userCompanySupervisorReroute=rroute}} -> do whenIsJust usrComp $ \Entity{entityKey=ucKey, entityVal=UserCompany{userCompanySupervisor=isSuper, userCompanySupervisorReroute=rroute}} -> do
delete ucKey delete ucKey
@ -358,7 +358,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
[mkCheckUpdate CU_API_UserCompanyPersonalNumber] [mkCheckUpdate CU_API_UserCompanyPersonalNumber]
let per_ups = mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo . mkCheckUpdate) let per_ups = mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo . mkCheckUpdate)
[ CU_API_UserFirstName [ CU_API_UserFirstName
, CU_API_UserSurname , CU_API_UserSurname
, CU_API_UserDisplayName , CU_API_UserDisplayName
, CU_API_UserBirthday , CU_API_UserBirthday
, CU_API_UserMobile , CU_API_UserMobile
@ -377,17 +377,17 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
, UserAvsLastFirmInfo =. Just newAvsFirmInfo , UserAvsLastFirmInfo =. Just newAvsFirmInfo
, UserAvsLastCardNo =. newAvsCardNo , UserAvsLastCardNo =. newAvsCardNo
] ]
-- update company association & supervision -- update company association & supervision
Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo
primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId
let oldCompanyId = entityKey <$> oldCompanyEnt let oldCompanyId = entityKey <$> oldCompanyEnt
-- oldCompanyMb = entityVal <$> oldCompanyEnt -- oldCompanyMb = entityVal <$> oldCompanyEnt
-- pst_up = if -- pst_up = if
-- -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId -- refactor could replace next 4 lines -- -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId -- refactor could replace next 4 lines
-- -- -> mkUpdate' usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though) -- -- -> mkUpdate' usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
-- | isNothing oldCompanyMb -- | isNothing oldCompanyMb
-- -> mkUpdateDirect usr newCompany $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though) -- -> mkUpdateDirect usr newCompany $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
-- | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line -- | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line
-- -> mkUpdate usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference -- -> mkUpdate usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference
@ -395,38 +395,37 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
-- -> Nothing -- -> Nothing
superReasonComDef = tshow SupervisorReasonCompanyDefault superReasonComDef = tshow SupervisorReasonCompanyDefault
newUserComp = UserCompany usrId newCompanyId False False 1 True -- default value for new company insertion, if no update can be done newUserComp = UserCompany usrId newCompanyId False False 1 True -- default value for new company insertion, if no update can be done
usr_up2 <- case oldAvsFirmInfo of usr_up2 <- case oldAvsFirmInfo of
_ | Just newCompanyId == oldCompanyId -- company unchanged entirely _ | Just newCompanyId == oldCompanyId -- company unchanged entirely
-> return mempty -- => do nothing -> return mempty -- => do nothing
(Just oafi) | isJust (view _avsFirmPostAddressSimple oafi) (Just oafi) | isJust (view _avsFirmPostAddressSimple oafi)
&& ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- non-empty company address unchanged OR && ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- non-empty company address unchanged OR
|| isJust (view _avsFirmPrimaryEmail oafi) || isJust (view _avsFirmPrimaryEmail oafi)
&& ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- non-empty company primary email unchanged && ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- non-empty company primary email unchanged
-> do -- => just update user company association, keeping supervision privileges -> do -- => just update user company association, keeping supervision privileges
case oldCompanyId of case oldCompanyId of
Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists
Just ocid -> do Just ocid -> do
void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId) -- keep default supervisor settings void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId) -- keep default supervisor settings
void $ updateWhere [ UserSupervisorSupervisor ==. usrId -- update company-related supervisions void $ updateWhere [ UserSupervisorSupervisor ==. usrId -- update company-related supervisions
, UserSupervisorCompany ==. Just ocid -- to new company, regardless of , UserSupervisorCompany ==. Just ocid -- to new company, regardless of
, UserSupervisorReason ==. Just superReasonComDef] -- user , UserSupervisorReason ==. Just superReasonComDef] -- user
[ UserSupervisorCompany =. Just newCompanyId] [ UserSupervisorCompany =. Just newCompanyId]
return mempty return mempty
_ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company _ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company
-> do -> do
whenIsJust oldCompanyId $ \oldCid -> do whenIsJust oldCompanyId $ \oldCid -> do
deleteBy $ UniqueUserCompany usrId oldCid deleteBy $ UniqueUserCompany usrId oldCid
deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef) deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef)
return mempty return mempty
_ -- company changed completely _ -- company changed completely
-> do -> do
(pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId (pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId
mapM_ reportAdminProblem problems mapM_ reportAdminProblem problems
-- Following line does not type, hence additional parameter needed -- Following line does not type, hence additional parameter needed
-- return [ u | u@Update{updateField=f} <- pst_up, f /= UserPostAddress ] -- already computed in frm_up above, duplicate update must be prevented (version above accounts for legacy updates) -- return [ u | u@Update{updateField=f} <- pst_up, f /= UserPostAddress ] -- already computed in frm_up above, duplicate update must be prevented (version above accounts for legacy updates)
return pst_up return pst_up
-- SPECIALISED CODE, PROBABLY DEPRECATED -- SPECIALISED CODE, PROBABLY DEPRECATED
-- switch user company, keeping old priority -- switch user company, keeping old priority
-- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case -- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case
@ -443,8 +442,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
-- addCompanySupervisors newCompanyId usrId -- addCompanySupervisors newCompanyId usrId
-- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef) -- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
-- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId -- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
-- return pst_up -- return pst_up
repsertSuperiorSupervisor (Just newCompanyId) newAvsFirmInfo usrId -- ensure firmInfo superior is supervisor, must be executed after updating company default supervisors
update usrId $ usr_up2 <> usr_up1 -- update user eventually update usrId $ usr_up2 <> usr_up1 -- update user eventually
update uaId avs_ups -- update stored avsinfo for future updates update uaId avs_ups -- update stored avsinfo for future updates
return (apid, usrId) return (apid, usrId)
@ -452,7 +450,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
linktoAvsUserByUIDs :: Set UserId -> Handler () linktoAvsUserByUIDs :: Set UserId -> Handler ()
linktoAvsUserByUIDs uids = do linktoAvsUserByUIDs uids = do
ips <- runDB $ E.select $ do ips <- runDB $ E.select $ do
usr <- E.from $ E.table @User usr <- E.from $ E.table @User
let uid = usr E.^. UserId let uid = usr E.^. UserId
ipn = usr E.^. UserCompanyPersonalNumber ipn = usr E.^. UserCompanyPersonalNumber
@ -463,8 +461,8 @@ linktoAvsUserByUIDs uids = do
E.where_ $ uid E.==. usrAvs E.^. UserAvsUser E.where_ $ uid E.==. usrAvs E.^. UserAvsUser
) )
return (uid, ipn) return (uid, ipn)
mapM_ procUsr ips mapM_ procUsr ips
where where
procUsr (E.Value uid, E.Value (Just ipn)) = catchAll2log $ linktoAvsUserByUID uid $ mkAvsInternalPersonalNo ipn procUsr (E.Value uid, E.Value (Just ipn)) = catchAll2log $ linktoAvsUserByUID uid $ mkAvsInternalPersonalNo ipn
procUsr _ = return () procUsr _ = return ()
@ -481,7 +479,7 @@ linktoAvsUserByUID uid aipn = do
-- createAvsUserById :: Set AvsPersonId -> Handler (Set (AvsPersonId, UserId)) ??? -- createAvsUserById :: Set AvsPersonId -> Handler (Set (AvsPersonId, UserId)) ???
-- | Create new user from AVS-Id. Will throw an AvsException if this is not possible, e.g. due to Uniqueness Constraints -- | Create new user from AVS-Id. Will throw an AvsException if this is not possible, e.g. due to Uniqueness Constraints
createAvsUserById :: Maybe UserId -> AvsPersonId -> Handler UserId createAvsUserById :: Maybe UserId -> AvsPersonId -> Handler UserId
createAvsUserById muid api = do createAvsUserById muid api = do
AvsResponseContact contactRes <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId api AvsResponseContact contactRes <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId api
case Set.toList contactRes of case Set.toList contactRes of
[] -> throwM $ AvsUserUnknownByAvs api [] -> throwM $ AvsUserUnknownByAvs api
@ -491,14 +489,14 @@ createAvsUserById muid api = do
| otherwise -> do | otherwise -> do
-- check for matching existing user -- check for matching existing user
let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
oldUsr <- runDB $ do oldUsr <- runDB $ do
mbUid <- if isJust muid mbUid <- if isJust muid
then return muid then return muid
else firstJustM $ catMaybes else firstJustM $ catMaybes
[ internalPersNo <&> (\ipn -> getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn]) -- must ensure filter isnt ==. Nothing [ internalPersNo <&> (\ipn -> getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn]) -- must ensure filter isnt ==. Nothing
, persMail <&> guessUserByEmail , persMail <&> guessUserByEmail
] ]
mbUAvs <- (getBy . UniqueUserAvsUser) `traverseJoin` mbUid mbUAvs <- (getBy . UniqueUserAvsUser) `traverseJoin` mbUid
return (mbUid, mbUAvs) return (mbUid, mbUAvs)
usrCardNo <- queryAvsFullCardNo api usrCardNo <- queryAvsFullCardNo api
@ -512,11 +510,11 @@ createAvsUserById muid api = do
, userAvsLastPersonInfo = mbPersonInfo , userAvsLastPersonInfo = mbPersonInfo
, userAvsLastFirmInfo = mbFirmInfo , userAvsLastFirmInfo = mbFirmInfo
, userAvsLastCardNo = mbUsrCardNo , userAvsLastCardNo = mbUsrCardNo
} }
case oldUsr of case oldUsr of
(Nothing , Just _) -> throwM $ AvsUserUnknownByAvs api -- this case should never occur (Nothing , Just _) -> throwM $ AvsUserUnknownByAvs api -- this case should never occur
(Just uid, Just Entity{entityVal=UserAvs{userAvsPersonId=api',userAvsUser=uid'}}) (Just uid, Just Entity{entityVal=UserAvs{userAvsPersonId=api',userAvsUser=uid'}})
| api /= api' -> throwM $ AvsIdMismatch api api' | api /= api' -> throwM $ AvsIdMismatch api api'
| uid /= uid' -> throwM $ AvsUserAmbiguous api | uid /= uid' -> throwM $ AvsUserAmbiguous api
| otherwise -> return uid -- nothing to do | otherwise -> return uid -- nothing to do
(Just uid, Nothing) -> runDB $ do -- link with matching exisitng user (Just uid, Nothing) -> runDB $ do -- link with matching exisitng user
@ -524,17 +522,17 @@ createAvsUserById muid api = do
updRes <- updateAvsUserById api -- no loop, since updateAvsUserById does not call createAvsUserById updRes <- updateAvsUserById api -- no loop, since updateAvsUserById does not call createAvsUserById
case updRes of case updRes of
Nothing -> throwM $ AvsUserUnknownByAvs api Nothing -> throwM $ AvsUserUnknownByAvs api
Just uid' Just uid'
| uid /= uid' -> throwM $ AvsUserAmbiguous api | uid /= uid' -> throwM $ AvsUserAmbiguous api
| otherwise -> return uid | otherwise -> return uid
(Nothing, Nothing) -> do -- create fresh user (Nothing, Nothing) -> do -- create fresh user
Entity{entityKey=cid, entityVal=cmp} <- runDB $ upsertAvsCompany firmInfo Nothing -- individual runDB, since no need to rollback Entity{entityKey=cid, entityVal=cmp} <- runDB $ upsertAvsCompany firmInfo Nothing -- individual runDB, since no need to rollback
let pinPass = avsFullCardNo2pin <$> usrCardNo let pinPass = avsFullCardNo2pin <$> usrCardNo
newUserData = AddUserData newUserData = AddUserData
{ audTitle = Nothing { audTitle = Nothing
, audFirstName = cpi ^. _avsInfoFirstName & Text.strip , audFirstName = cpi ^. _avsInfoFirstName & Text.strip
, audSurname = cpi ^. _avsInfoLastName & Text.strip , audSurname = cpi ^. _avsInfoLastName & Text.strip
, audDisplayName = cpi ^. _avsInfoDisplayName , audDisplayName = cpi ^. _avsInfoDisplayName
, audDisplayEmail = persMail & fromMaybe mempty , audDisplayEmail = persMail & fromMaybe mempty
, audEmail = persMail & fromMaybe ("AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI) , audEmail = persMail & fromMaybe ("AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI)
, audIdent = persMail & fromMaybe ("AVSID:" <> ciShow api ) , audIdent = persMail & fromMaybe ("AVSID:" <> ciShow api )
@ -542,74 +540,23 @@ createAvsUserById muid api = do
, audMatriculation = cpi ^. _avsInfoPersonNo & Just . tshow , audMatriculation = cpi ^. _avsInfoPersonNo & Just . tshow
, audSex = Nothing , audSex = Nothing
, audBirthday = cpi ^. _avsInfoDateOfBirth , audBirthday = cpi ^. _avsInfoDateOfBirth
, audMobile = cpi ^. _avsInfoPersonMobilePhoneNo , audMobile = cpi ^. _avsInfoPersonMobilePhoneNo
, audTelephone = Nothing , audTelephone = Nothing
, audFPersonalNumber = internalPersNo , audFPersonalNumber = internalPersNo
, audFDepartment = toMaybe (isJust internalPersNo) (cmp ^. _companyShorthand . _CI) , audFDepartment = toMaybe (isJust internalPersNo) (cmp ^. _companyShorthand . _CI)
, audPostAddress = Nothing -- always use company address indirectly , audPostAddress = Nothing -- always use company address indirectly
, audPrefersPostal = cmp ^. _companyPrefersPostal , audPrefersPostal = cmp ^. _companyPrefersPostal
, audPinPassword = pinPass , audPinPassword = pinPass
} }
runDB $ do -- any failure must rollback all DB write transactions here runDB $ do -- any failure must rollback all DB write transactions here
uid <- maybeThrowM (AvsUserCreationFailed api) $ addNewUserDB newUserData uid <- maybeThrowM (AvsUserCreationFailed api) $ addNewUserDB newUserData
let userComp = UserCompany uid cid False False 1 True -- default value for new company insertion, if no update can be done let userComp = UserCompany uid cid False False 1 True -- default value for new company insertion, if no update can be done
void $ insertUnique userComp -- Nothing indicates that the user is already linked to the company (which is unlikely here) void $ insertUnique userComp -- Nothing indicates that the user is already linked to the company (which is unlikely here)
-- Supervision -- Supervision
addCompanySupervisors cid uid addCompanySupervisors cid uid
repsertSuperiorSupervisor (Just cid) firmInfo uid
-- Save AVS data for future updates -- Save AVS data for future updates
insert_ $ usrAvs uid (Just cpi) (Just firmInfo) usrCardNo -- unlikely that uid cannot be linked with avsid, but throw if it is not possible insert_ $ usrAvs uid (Just cpi) (Just firmInfo) usrCardNo -- unlikely that uid cannot be linked with avsid, but throw if it is not possible
return uid return uid
-- | upsert superior by eMail through LDAP only (currently no email search available in AVS)
repsertSuperiorSupervisor :: Maybe CompanyId -> AvsFirmInfo -> UserId -> DB ()
repsertSuperiorSupervisor cid afi uid =
whenIsJust (afi ^. _avsFirmEMailSuperior) $ \supemail -> forMM_
(altM (guessUserByEmail $ stripCI supemail)
(catchAVShandler True True False Nothing $ Just . entityKey <$> ldapLookupAndUpsert supemail)
) $ \supid -> do
let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
newSupervisor = UserSupervisor supid uid False cid reasonSuperior
deleteWhere [UserSupervisorUser ==. uid, UserSupervisorSupervisor !=. supid, UserSupervisorReason ==. reasonSuperior] -- delete previous superiors, if any
-- void $ upsertBy (UniqueUserSupervisor supid uid) newSupervisor [company =. cid, reason =. reasonSuperior] -- always update supervisor reason
void $ insertUnique $ UserSupervisor supid uid False cid reasonSuperior -- do not change existing supervisor relationship
-- TODO: CR3: user upsertCompanySuperior instead of repsertSuperiorSupervisor
-- upsert company supervisor from AvsFirmEMailSuperior
upsertCompanySuperior :: AvsFirmInfo -> Maybe AvsFirmInfo -> DB (Maybe (CompanyId, UserId))
upsertCompanySuperior newAfi mbOldAfi = runMaybeT $ do
supemail <- MaybeT . pure $ newAfi ^. _avsFirmEMailSuperior
supid <- MaybeT $ altM (guessUserByEmail $ stripCI supemail)
(catchAVShandler True True False Nothing $ Just . entityKey <$> ldapLookupAndUpsert supemail)
cid <- MaybeT $ getAvsCompanyId newAfi
lift $ do
void $ runMaybeT $ do -- remove old superior, if any
oldAfi <- MaybeT $ pure mbOldAfi
oldSeml <- MaybeT $ pure $ oldAfi ^. _avsFirmEMailSuperior
oldSup <- MaybeT $ guessUserByEmail $ stripCI oldSeml
oldCid <- MaybeT $ getAvsCompanyId oldAfi
when (oldCid == cid && oldSup /= supid) $ lift $ do
let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
deleteWhere [UserCompanyCompany ==. cid, UserCompanyUser ==. oldSup] -- remove old supervisor from company
-- switch supervison
-- updateWhere [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor ==. oldSup, UserSupervisorReason ==. reasonSuperior] [UserSupervisor =. supid] -- not safe, could violate uniqueness
E.update $ \usuper -> do
E.set usuper [ UserSupervisorSupervisor E.=. E.val supid ]
E.where_ $ usuper E.^. UserSupervisorSupervisor E.==. E.val oldSup
E.&&. usuper E.^. UserSupervisorCompany E.==. E.justVal cid
E.&&. usuper E.^. UserSupervisorReason E.==. E.val reasonSuperior
E.&&. E.notExists (do
newSuper <- E.from $ E.table @UserSupervisor
E.where_ $ newSuper E.^. UserSupervisorSupervisor E.==. E.val supid
E.&&. newSuper E.^. UserSupervisorUser E.==. newSuper E.^. UserSupervisorUser
)
deleteWhere [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor ==. oldSup, UserSupervisorReason ==. reasonSuperior] -- remove un-updateable remainders, if any
-- upsert new superior company supervisor
void $ upsertBy (UniqueUserCompany supid cid)
(UserCompany supid cid True False 1 True)
[UserCompanySupervisor =. True]
return (cid,supid)
getAvsCompanyId :: AvsFirmInfo -> DB (Maybe CompanyId) getAvsCompanyId :: AvsFirmInfo -> DB (Maybe CompanyId)
@ -617,7 +564,7 @@ getAvsCompanyId = fmap (fmap entityKey) . getAvsCompany
-- | Query DB from given AvsFirmInfo. Guarantees that all Uniqueness-Constraints are checked. Highly unlikely that Nothing is returned, since all AvsResponseContact always contains an AvsFirmInfo -- | Query DB from given AvsFirmInfo. Guarantees that all Uniqueness-Constraints are checked. Highly unlikely that Nothing is returned, since all AvsResponseContact always contains an AvsFirmInfo
getAvsCompany :: AvsFirmInfo -> DB (Maybe (Entity Company)) getAvsCompany :: AvsFirmInfo -> DB (Maybe (Entity Company))
getAvsCompany afi = getAvsCompany afi =
let compName :: CompanyName let compName :: CompanyName
compName = afi ^. _avsFirmFirm . from _CI compName = afi ^. _avsFirmFirm . from _CI
compShorthand :: CompanyShorthand compShorthand :: CompanyShorthand
@ -625,11 +572,11 @@ getAvsCompany afi =
compAvsId = afi ^. _avsFirmFirmNo compAvsId = afi ^. _avsFirmFirmNo
in firstJustM $ -- legacy treatment, only use UniqueCompnayAvsId in the future in firstJustM $ -- legacy treatment, only use UniqueCompnayAvsId in the future
guardMonoid (compAvsId > 0) guardMonoid (compAvsId > 0)
[ getBy $ UniqueCompanyAvsId compAvsId [ getBy $ UniqueCompanyAvsId compAvsId
, getEntity $ CompanyKey $ compShorthand <> "-" <> ciShow compAvsId , getEntity $ CompanyKey $ compShorthand <> "-" <> ciShow compAvsId
] <> ] <>
[ getByFilter [CompanyName ==. compName] [ getByFilter [CompanyName ==. compName]
, getEntity $ CompanyKey compShorthand , getEntity $ CompanyKey compShorthand
] ]
-- | insert a company from AVS firm info or update an existing one based on previous values -- | insert a company from AVS firm info or update an existing one based on previous values
@ -637,7 +584,7 @@ upsertAvsCompany :: AvsFirmInfo -> Maybe AvsFirmInfo -> DB (Entity Company)
upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
mbFirmEnt <- getAvsCompany newAvsFirmInfo -- primarily by AvsId, then Shorthand, then name mbFirmEnt <- getAvsCompany newAvsFirmInfo -- primarily by AvsId, then Shorthand, then name
$logInfoS "AVS" [st|upsertAvsCompany: old #{tshow mbFirmEnt} new #{tshow newAvsFirmInfo}|] $logInfoS "AVS" [st|upsertAvsCompany: old #{tshow mbFirmEnt} new #{tshow newAvsFirmInfo}|]
case (mbFirmEnt, mbOldAvsFirmInfo) of cmpEnt <- case (mbFirmEnt, mbOldAvsFirmInfo) of
(Nothing, _) -> do -- insert new company, neither AvsId nor Shorthand exist in DB (Nothing, _) -> do -- insert new company, neither AvsId nor Shorthand exist in DB
afn <- if 0 < newAvsFirmInfo ^. _avsFirmFirmNo afn <- if 0 < newAvsFirmInfo ^. _avsFirmFirmNo
then return $ newAvsFirmInfo ^. _avsFirmFirmNo then return $ newAvsFirmInfo ^. _avsFirmFirmNo
@ -653,19 +600,19 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
} }
cmp = foldl' upd dmy $ firmInfo2key : firmInfo2companyNo : firmInfo2company cmp = foldl' upd dmy $ firmInfo2key : firmInfo2companyNo : firmInfo2company
$logInfoS "AVS" $ "Insert new company: " <> tshow cmp $logInfoS "AVS" $ "Insert new company: " <> tshow cmp
newCmp <- insertEntity cmp newCmp <- insertEntity cmp
reportAdminProblem $ AdminProblemNewCompany $ entityKey newCmp reportAdminProblem $ AdminProblemNewCompany $ entityKey newCmp
$logInfoS "AVS" "Insert new company completed." $logInfoS "AVS" "Insert new company completed."
return newCmp return newCmp
(Just Entity{entityKey=firmid, entityVal=firm}, oldAvsFirmInfo) -> do -- possibly update existing company, if isJust oldAvsFirmInfo and changed occurred (Just Entity{entityKey=firmid, entityVal=firm}, oldAvsFirmInfo) -> do -- possibly update existing company, if isJust oldAvsFirmInfo and changed occurred
let cmp_ups = mapMaybe (mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company let cmp_ups = mapMaybe (mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company
key_ups = mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo firmInfo2key key_ups = mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo firmInfo2key
uniq_ups <- mkUpdateCheckUnique' firm newAvsFirmInfo oldAvsFirmInfo firmInfo2companyNo uniq_ups <- mkUpdateCheckUnique' firm newAvsFirmInfo oldAvsFirmInfo firmInfo2companyNo
$logInfoS "AVS" [st|Update company #{companyShorthand firm}: #{tshow (length cmp_ups)}, #{tshow (length key_ups)}, #{tshow (length uniq_ups)} for #{tshow oldAvsFirmInfo}|] $logInfoS "AVS" [st|Update company #{companyShorthand firm}: #{tshow (length cmp_ups)}, #{tshow (length key_ups)}, #{tshow (length uniq_ups)} for #{tshow oldAvsFirmInfo}|]
res_cmp <- updateGetEntity firmid $ mcons uniq_ups cmp_ups res_cmp <- updateGetEntity firmid $ mcons uniq_ups cmp_ups
let cmp_id = res_cmp ^. _entityVal . _companyAvsId let cmp_id = res_cmp ^. _entityVal . _companyAvsId
res_cmp2 <- case key_ups of res_cmp2 <- case key_ups of
Just key_up | cmp_id > 0 -> do Just key_up | cmp_id > 0 -> do
$logInfoS "AVS" $ "Updating CompanyShorthand from " <> ciOriginal (companyShorthand firm) <> " to " <> avsFirmAbbreviation newAvsFirmInfo <> " for AvsNo " <> tshow cmp_id $logInfoS "AVS" $ "Updating CompanyShorthand from " <> ciOriginal (companyShorthand firm) <> " to " <> avsFirmAbbreviation newAvsFirmInfo <> " for AvsNo " <> tshow cmp_id
let uniq_cmp = UniqueCompanyAvsId cmp_id let uniq_cmp = UniqueCompanyAvsId cmp_id
@ -676,22 +623,87 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
if | key_ok -> updateBy uniq_cmp [key_up] -- this is ok, since we have OnUpdateCascade on all CompanyId entries if | key_ok -> updateBy uniq_cmp [key_up] -- this is ok, since we have OnUpdateCascade on all CompanyId entries
| alt_ok -> updateBy uniq_cmp [CompanyShorthand =. alt_key] | alt_ok -> updateBy uniq_cmp [CompanyShorthand =. alt_key]
| otherwise -> $logInfoS "AVS" $ "Update company shorthand failed for " <> ciOriginal cmp_key <> " and " <> ciOriginal alt_key | otherwise -> $logInfoS "AVS" $ "Update company shorthand failed for " <> ciOriginal cmp_key <> " and " <> ciOriginal alt_key
maybeM (return res_cmp) return $ getBy uniq_cmp maybeM (return res_cmp) return $ getBy uniq_cmp
_otherwise -> return res_cmp _otherwise -> return res_cmp
$logInfoS "AVS" "Update company completed." $logInfoS "AVS" "Update company completed."
return res_cmp2 return res_cmp2
void $ upsertCompanySuperior (Just $ entityKey cmpEnt, newAvsFirmInfo) mbOldAvsFirmInfo -- ensure firmInfo superior is supervisor
return cmpEnt
where where
firmInfo2key = firmInfo2key =
CheckUpdate CompanyShorthand $ _avsFirmAbbreviation . from _CI -- Updating primary key works in principle thanks to OnUpdateCascade, but fails due to update get CheckUpdate CompanyShorthand $ _avsFirmAbbreviation . from _CI -- Updating primary key works in principle thanks to OnUpdateCascade, but fails due to update get
firmInfo2companyNo = firmInfo2companyNo =
CheckUpdate CompanyAvsId _avsFirmFirmNo -- Updating a unique needs special considerations; AVS does not update FirmNo, but for legacy reasons we might have companies without a number CheckUpdate CompanyAvsId _avsFirmFirmNo -- Updating a unique needs special considerations; AVS does not update FirmNo, but for legacy reasons we might have companies without a number
firmInfo2company = firmInfo2company =
[ CheckUpdate CompanyName $ _avsFirmFirm . from _CI [ CheckUpdate CompanyName $ _avsFirmFirm . from _CI
, CheckUpdate CompanyPostAddress _avsFirmPostAddress , CheckUpdate CompanyPostAddress _avsFirmPostAddress
, CheckUpdate CompanyEmail $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just , CheckUpdate CompanyEmail $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just
-- , CheckUpdate CompanyPrefersPostal _avsFirmPrefersPostal -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available -- , CheckUpdate CompanyPrefersPostal _avsFirmPrefersPostal -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available
] ]
-- upsert company supervisor from AvsFirmEMailSuperior
upsertCompanySuperior :: (Maybe CompanyId, AvsFirmInfo) -> Maybe AvsFirmInfo -> DB (Maybe (CompanyId, UserId))
upsertCompanySuperior (mbCid, newAfi) mbOldAfi = runMaybeT $ do
supemail <- MaybeT . pure $ newAfi ^. _avsFirmEMailSuperior
cid <- MaybeT $ altM (pure mbCid) (getAvsCompanyId newAfi)
supid <- MaybeT $ altM (guessUserByEmail $ stripCI supemail)
(catchAVShandler True True False Nothing $ Just . entityKey <$> ldapLookupAndUpsert supemail)
lift $ do
let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
oldChanges <- runMaybeT $ do -- remove old superior, if any
oldAfi <- MaybeT $ pure mbOldAfi
oldEml <- MaybeT $ pure $ oldAfi ^. _avsFirmEMailSuperior
oldCid <- MaybeT $ getAvsCompanyId oldAfi
oldSup <- MaybeT $ guessUserByEmail $ stripCI oldEml
let supChange = oldSup /= supid
when (supChange && oldCid == cid) $ lift $ do
-- deleteWhere [UserCompanyCompany ==. cid, UserCompanyUser ==. oldSup] -- remove old supervisor from company NOTE: we leave this to the oldSuperior's AVS update
-- switch supervison
-- updateWhere [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor ==. oldSup, UserSupervisorReason ==. reasonSuperior] [UserSupervisor =. supid] -- not safe, could violate uniqueness
E.update $ \usuper -> do
E.set usuper [ UserSupervisorSupervisor E.=. E.val supid ]
E.where_ $ usuper E.^. UserSupervisorSupervisor E.==. E.val oldSup
E.&&. usuper E.^. UserSupervisorCompany E.==. E.justVal cid
E.&&. usuper E.^. UserSupervisorReason E.==. E.val reasonSuperior
E.&&. E.notExists (do
newSuper <- E.from $ E.table @UserSupervisor
E.where_ $ newSuper E.^. UserSupervisorSupervisor E.==. E.val supid
E.&&. newSuper E.^. UserSupervisorUser E.==. newSuper E.^. UserSupervisorUser
)
deleteWhere [UserSupervisorSupervisor ==. oldSup, UserSupervisorCompany ==. Just cid, UserSupervisorReason ==. reasonSuperior] -- remove un-updateable remainders, if any
return (supChange, oldSup)
let supChange = fst <$> oldChanges
oldSup = snd <$> oldChanges
unless (supChange == Just False) $ do
-- upsert new superior company supervisor
suprEnt <- upsertBy (UniqueUserCompany supid cid)
(UserCompany supid cid True False 1 True)
[UserCompanySupervisor =. True]
E.insertSelectWithConflict UniqueUserSupervisor
(do
usr <- E.from $ E.table @UserCompany
E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
-- E.&&. E.notExists (do -- restrict to primary company only
-- othr <- E.from $ E.table @UserCompany
-- E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority
-- E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser
-- E.&&. othr E.^. UserCompanyCompany E.!=. E.val cid -- redundant due to > above, but likely performance improving
-- )
return $ UserSupervisor
E.<# E.val supid
E.<&> (usr E.^. UserCompanyUser)
E.<&> E.val (suprEnt ^. _entityVal . _userCompanySupervisorReroute)
E.<&> E.justVal cid
E.<&> E.val reasonSuperior
)
(\old new ->
[ UserSupervisorCompany E.=. E.coalesce [old E.^. UserSupervisorCompany, new E.^. UserSupervisorCompany]
, UserSupervisorReason E.=. E.coalesce [old E.^. UserSupervisorReason , new E.^. UserSupervisorReason ]
]
)
reportAdminProblem $ AdminProblemCompanySuperiorChange supid cid oldSup
return (cid,supid)
queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> DB Int64 queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> DB Int64
queueAvsUpdateByUID uids = queueAvsUpdateAux (E.table @User) (E.^. UserId) (\usr -> usr E.^. UserId `E.in_` E.vals uids) queueAvsUpdateByUID uids = queueAvsUpdateAux (E.table @User) (E.^. UserId) (\usr -> usr E.^. UserId `E.in_` E.vals uids)
@ -701,14 +713,14 @@ queueAvsUpdateByAID aids = queueAvsUpdateAux (E.table @UserAvs) (E.^. UserAvsUse
-- queueAvsUpdateAux :: E.From (E.SqlExpr (Entity ent)) -> (E.SqlExpr (Entity ent) -> E.SqlExpr (E.Value UserId)) -> (E.SqlExpr (Entity ent) -> E.SqlExpr (E.Value Bool)) -> Maybe Day -> DB Int64 -- queueAvsUpdateAux :: E.From (E.SqlExpr (Entity ent)) -> (E.SqlExpr (Entity ent) -> E.SqlExpr (E.Value UserId)) -> (E.SqlExpr (Entity ent) -> E.SqlExpr (E.Value Bool)) -> Maybe Day -> DB Int64
queueAvsUpdateAux :: E.From t -> (t -> E.SqlExpr (E.Value UserId)) -> (t -> E.SqlExpr (E.Value Bool)) -> Maybe Day -> DB Int64 queueAvsUpdateAux :: E.From t -> (t -> E.SqlExpr (E.Value UserId)) -> (t -> E.SqlExpr (E.Value Bool)) -> Maybe Day -> DB Int64
queueAvsUpdateAux tbl prj fltr pause = do queueAvsUpdateAux tbl prj fltr pause = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
n <- E.insertSelectWithConflictCount UniqueAvsSyncUser n <- E.insertSelectWithConflictCount UniqueAvsSyncUser
( do ( do
usr <- E.from tbl usr <- E.from tbl
E.where_ $ fltr usr E.where_ $ fltr usr
return (AvsSync E.<# prj usr E.<&> E.val now E.<&> E.val pause) return (AvsSync E.<# prj usr E.<&> E.val now E.<&> E.val pause)
) (\current excluded -> ) (\current excluded ->
[ AvsSyncCreationTime E.=. E.least (current E.^. AvsSyncCreationTime) (excluded E.^. AvsSyncCreationTime) [ AvsSyncCreationTime E.=. E.least (current E.^. AvsSyncCreationTime) (excluded E.^. AvsSyncCreationTime)
, AvsSyncPause E.=. E.greatest (current E.^. AvsSyncPause) (excluded E.^. AvsSyncPause) , AvsSyncPause E.=. E.greatest (current E.^. AvsSyncPause) (excluded E.^. AvsSyncPause)
] ]
@ -717,24 +729,24 @@ queueAvsUpdateAux tbl prj fltr pause = do
return n return n
-- | Find or upsert User by AvsCardId (with dot), Fraport PersonalNumber, Fraport Email-Address or by prefixed AvsId or prefixed AvsNo; -- | Find or upsert User by AvsCardId (with dot), Fraport PersonalNumber, Fraport Email-Address or by prefixed AvsId or prefixed AvsNo;
-- fail-safe, may or may not update existing users, may insert new users -- fail-safe, may or may not update existing users, may insert new users
-- If an existing User with internal number is found, an AVS update query is executed -- If an existing User with internal number is found, an AVS update query is executed
guessAvsUser :: Text -> Handler (Maybe UserId) guessAvsUser :: Text -> Handler (Maybe UserId)
guessAvsUser (Text.splitAt 6 -> (Text.toUpper -> prefix, readMay -> Just nr)) guessAvsUser (Text.splitAt 6 -> (Text.toUpper -> prefix, readMay -> Just nr))
| prefix=="AVSID:" = | prefix=="AVSID:" =
let avsid = AvsPersonId nr in let avsid = AvsPersonId nr in
runDB (getBy $ UniqueUserAvsId avsid) >>= \case runDB (getBy $ UniqueUserAvsId avsid) >>= \case
(Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> return $ Just uid (Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> return $ Just uid
Nothing -> catchAVS2message $ Just <$> upsertAvsUserById avsid Nothing -> catchAVS2message $ Just <$> upsertAvsUserById avsid
| prefix=="AVSNO:" = | prefix=="AVSNO:" =
runDB (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr]) runDB (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr])
guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) = guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) =
catchAVS2message $ upsertAvsUserByCard someavsid >>= \case catchAVS2message $ upsertAvsUserByCard someavsid >>= \case
Nothing | Left{} <- someavsid -> -- attempt to find PersonalNumber in DB Nothing | Left{} <- someavsid -> -- attempt to find PersonalNumber in DB
runDB (getKeyByFilter [UserCompanyPersonalNumber ==. Just someid]) runDB (getKeyByFilter [UserCompanyPersonalNumber ==. Just someid])
other -> return other other -> return other
guessAvsUser someid = do guessAvsUser someid = do
try (runDB $ ldapLookupAndUpsert someid) >>= \case try (runDB $ ldapLookupAndUpsert someid) >>= \case
Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> do -- ensure internal user is linked to avs, if possible Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> do -- ensure internal user is linked to avs, if possible
let ldapUid = Just uid let ldapUid = Just uid
@ -743,8 +755,8 @@ guessAvsUser someid = do
return ldapUid return ldapUid
Right Entity{entityKey=uid} -> return $ Just uid Right Entity{entityKey=uid} -> return $ Just uid
other -> do -- attempt to recover by trying other ids other -> do -- attempt to recover by trying other ids
whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all
runDB . runMaybeT $ runDB . runMaybeT $
MaybeT (guessUserByEmail $ stripCI someid) -- recall that monadic actions are only executed until first success here MaybeT (guessUserByEmail $ stripCI someid) -- recall that monadic actions are only executed until first success here
<|> MaybeT (getKeyByFilter [UserDisplayName ==. someid]) <|> MaybeT (getKeyByFilter [UserDisplayName ==. someid])
@ -756,8 +768,8 @@ upsertAvsUserByCard persNo = do
let qry = case persNo of let qry = case persNo of
Left fpn Left fpn
-> def{ avsPersonQueryInternalPersonalNo = Just fpn } -- recall: default has all fields set to nothing -> def{ avsPersonQueryInternalPersonalNo = Just fpn } -- recall: default has all fields set to nothing
Right AvsFullCardNo{..} Right AvsFullCardNo{..}
-> def{ avsPersonQueryCardNo = Just avsFullCardNo, avsPersonQueryVersionNo = Just avsFullCardVersion } -> def{ avsPersonQueryCardNo = Just avsFullCardNo, avsPersonQueryVersionNo = Just avsFullCardVersion }
-- NOTE: card validity might be outdated, so we must always check diretcly with avs and not within our DB! -- NOTE: card validity might be outdated, so we must always check diretcly with avs and not within our DB!
AvsResponsePerson adps <- avsQuery qry AvsResponsePerson adps <- avsQuery qry
case Set.elems adps of case Set.elems adps of
@ -780,11 +792,11 @@ setLicence :: (PersistUniqueRead backend, MonadThrow m,
MonadHandler m, HandlerSite m ~ UniWorX, MonadHandler m, HandlerSite m ~ UniWorX,
BaseBackend backend ~ SqlBackend) => BaseBackend backend ~ SqlBackend) =>
UserId -> AvsLicence -> ReaderT backend m Bool UserId -> AvsLicence -> ReaderT backend m Bool
setLicence uid lic = setLicence uid lic =
getBy (UniqueUserAvsUser uid) >>= \case getBy (UniqueUserAvsUser uid) >>= \case
Just Entity{entityVal=UserAvs{userAvsPersonId=api}} -> setLicenceAvs api lic Just Entity{entityVal=UserAvs{userAvsPersonId=api}} -> setLicenceAvs api lic
Nothing -> do Nothing -> do
uname <- userDisplayName <<$>> get uid uname <- userDisplayName <<$>> get uid
throwM $ AvsUserUnassociated $ fromMaybe "user id unknown" uname throwM $ AvsUserUnassociated $ fromMaybe "user id unknown" uname
setLicenceAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => setLicenceAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
@ -797,7 +809,7 @@ setLicenceAvs apid lic = do
--setLicencesAvs :: Set AvsPersonLicence -> Handler Bool --setLicencesAvs :: Set AvsPersonLicence -> Handler Bool
setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
Set AvsPersonLicence -> m Int Set AvsPersonLicence -> m Int
setLicencesAvs = aux 0 setLicencesAvs = aux 0
where where
aux batch0_ok pls aux batch0_ok pls
| Set.null pls = return batch0_ok | Set.null pls = return batch0_ok
@ -816,7 +828,7 @@ setLicencesAvs = aux 0
bad = Map.withoutKeys (setToMap avsResponsePersonID bad') ok_ids -- it is possible to receive an id multiple times, with only one success, but this is sufficient bad = Map.withoutKeys (setToMap avsResponsePersonID bad') ok_ids -- it is possible to receive an id multiple times, with only one success, but this is sufficient
batch1_ok = Set.size ok batch1_ok = Set.size ok
forM_ bad $ \AvsLicenceResponse { avsResponsePersonID=api, avsResponseMessage=msg} -> forM_ bad $ \AvsLicenceResponse { avsResponsePersonID=api, avsResponseMessage=msg} ->
$logErrorS "AVS" $ "Set AVS Licence failed for " <> tshow api <> " due to " <> cropText msg $logErrorS "AVS" $ "Set AVS Licence failed for " <> tshow api <> " due to " <> cropText msg
aux (batch0_ok + batch1_ok) batch2 -- yay for tail recursion (TODO: maybe refactor?) aux (batch0_ok + batch1_ok) batch2 -- yay for tail recursion (TODO: maybe refactor?)
{- NOT USED ANYWHERE: {- NOT USED ANYWHERE:
@ -846,13 +858,13 @@ data AvsLicenceDifferences = AvsLicenceDifferences
#ifndef DEVELOPMENT #ifndef DEVELOPMENT
-- avsLicenceDifferences2LicenceIds is not used in DEVELOPMENT build -- avsLicenceDifferences2LicenceIds is not used in DEVELOPMENT build
avsLicenceDifferences2LicenceIds :: AvsLicenceDifferences -> Set AvsPersonId avsLicenceDifferences2LicenceIds :: AvsLicenceDifferences -> Set AvsPersonId
avsLicenceDifferences2LicenceIds AvsLicenceDifferences{..} = Set.unions avsLicenceDifferences2LicenceIds AvsLicenceDifferences{..} = Set.unions
[ avsLicenceDiffRevokeAll [ avsLicenceDiffRevokeAll
, avsLicenceDiffGrantVorfeld , avsLicenceDiffGrantVorfeld
, avsLicenceDiffRevokeRollfeld , avsLicenceDiffRevokeRollfeld
, avsLicenceDiffGrantRollfeld , avsLicenceDiffGrantRollfeld
] ]
#endif #endif
avsLicenceDifferences2personLicences :: AvsLicenceDifferences -> Set AvsPersonLicence avsLicenceDifferences2personLicences :: AvsLicenceDifferences -> Set AvsPersonLicence
avsLicenceDifferences2personLicences AvsLicenceDifferences{..} = avsLicenceDifferences2personLicences AvsLicenceDifferences{..} =
@ -876,7 +888,7 @@ retrieveDifferingLicencesStatus :: Handler (AvsLicenceDifferences, AvsPersonIdMa
retrieveDifferingLicencesStatus = retrieveDifferingLicences' True retrieveDifferingLicencesStatus = retrieveDifferingLicences' True
retrieveDifferingLicences' :: Bool -> Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard) retrieveDifferingLicences' :: Bool -> Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard)
retrieveDifferingLicences' getStatus = do retrieveDifferingLicences' getStatus = do
#ifdef DEVELOPMENT #ifdef DEVELOPMENT
avsUsrs <- runDB $ selectList [] [LimitTo 444] avsUsrs <- runDB $ selectList [] [LimitTo 444]
let allLicences = AvsResponseGetLicences $ Set.fromList $ let allLicences = AvsResponseGetLicences $ Set.fromList $
@ -886,33 +898,33 @@ retrieveDifferingLicences' getStatus = do
, AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 2 -- AVS:1 FD:0 (ungültig) , AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 2 -- AVS:1 FD:0 (ungültig)
-- , AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 4 -- AVS:1 FD:1 -- , AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 4 -- AVS:1 FD:1
] ++ [AvsPersonLicence AvsLicenceVorfeld avsid | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs] ] ++ [AvsPersonLicence AvsLicenceVorfeld avsid | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs]
#else #else
allLicences <- avsQuery AvsQueryGetAllLicences allLicences <- avsQuery AvsQueryGetAllLicences
#endif #endif
lDiff <- getDifferingLicences allLicences lDiff <- getDifferingLicences allLicences
#ifdef DEVELOPMENT #ifdef DEVELOPMENT
let mkAdpc valid color = AvsDataPersonCard valid Nothing Nothing color (Set.singleton 'F') Nothing Nothing Nothing Nothing (AvsCardNo "1234") "5" let mkAdpc valid color = AvsDataPersonCard valid Nothing Nothing color (Set.singleton 'F') Nothing Nothing Nothing Nothing (AvsCardNo "1234") "5"
lStat = AvsResponseStatus $ bool mempty fakes getStatus -- not really needed, but avoids unused variable error lStat = AvsResponseStatus $ bool mempty fakes getStatus -- not really needed, but avoids unused variable error
fakes = Set.fromList $ fakes = Set.fromList $
[ AvsStatusPerson (AvsPersonId 77 ) $ Set.singleton $ mkAdpc True AvsCardColorGelb [ AvsStatusPerson (AvsPersonId 77 ) $ Set.singleton $ mkAdpc True AvsCardColorGelb
, AvsStatusPerson (AvsPersonId 12345678) $ Set.fromList [mkAdpc False AvsCardColorGrün, mkAdpc True AvsCardColorGelb, mkAdpc False AvsCardColorBlau, mkAdpc True AvsCardColorRot, mkAdpc True $ AvsCardColorMisc "Violett"] , AvsStatusPerson (AvsPersonId 12345678) $ Set.fromList [mkAdpc False AvsCardColorGrün, mkAdpc True AvsCardColorGelb, mkAdpc False AvsCardColorBlau, mkAdpc True AvsCardColorRot, mkAdpc True $ AvsCardColorMisc "Violett"]
, AvsStatusPerson (AvsPersonId 5 ) $ Set.fromList [mkAdpc True AvsCardColorGrün, mkAdpc False AvsCardColorGelb, mkAdpc True AvsCardColorBlau, mkAdpc False AvsCardColorRot, mkAdpc True $ AvsCardColorMisc "Pink"] , AvsStatusPerson (AvsPersonId 5 ) $ Set.fromList [mkAdpc True AvsCardColorGrün, mkAdpc False AvsCardColorGelb, mkAdpc True AvsCardColorBlau, mkAdpc False AvsCardColorRot, mkAdpc True $ AvsCardColorMisc "Pink"]
, AvsStatusPerson (AvsPersonId 2 ) $ Set.singleton $ mkAdpc True AvsCardColorGrün , AvsStatusPerson (AvsPersonId 2 ) $ Set.singleton $ mkAdpc True AvsCardColorGrün
] <> ] <>
[ AvsStatusPerson avsid $ Set.singleton $ mkAdpc (even $ avsPersonId avsid) AvsCardColorGelb | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs ] [ AvsStatusPerson avsid $ Set.singleton $ mkAdpc (even $ avsPersonId avsid) AvsCardColorGelb | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs ]
#else #else
let statQry = avsLicenceDifferences2LicenceIds lDiff let statQry = avsLicenceDifferences2LicenceIds lDiff
lStat <- if getStatus && notNull statQry lStat <- if getStatus && notNull statQry
then avsQueryNoCache (AvsQueryStatus statQry) then avsQueryNoCache (AvsQueryStatus statQry)
-- `catch` handler -- `catch` handler
-- let handler _exception = do -- let handler _exception = do
-- addMessage Error $ toHtml $ "avsQueryStatus failed for " <> tshow (length statQry) <> " requests with: \n" <> tshow err <> "\nREQUEST:\n" <> tshow statQry -- addMessage Error $ toHtml $ "avsQueryStatus failed for " <> tshow (length statQry) <> " requests with: \n" <> tshow err <> "\nREQUEST:\n" <> tshow statQry
-- return $ AvsResponseStatus mempty -- return $ AvsResponseStatus mempty
else return $ AvsResponseStatus mempty -- avoid unnecessary avs calls else return $ AvsResponseStatus mempty -- avoid unnecessary avs calls
#endif #endif
return (lDiff, avsResponseStatusMap lStat) return (lDiff, avsResponseStatusMap lStat)
getDifferingLicences :: AvsResponseGetLicences -> Handler AvsLicenceDifferences getDifferingLicences :: AvsResponseGetLicences -> Handler AvsLicenceDifferences
getDifferingLicences (AvsResponseGetLicences licences) = do getDifferingLicences (AvsResponseGetLicences licences) = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
@ -934,7 +946,7 @@ getDifferingLicences (AvsResponseGetLicences licences) = do
(quali E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification) (quali E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification)
-- NOTE: filters on the innerJoin must be part of ON-condition in order for anti-join to work! -- NOTE: filters on the innerJoin must be part of ON-condition in order for anti-join to work!
E.&&. (quali E.^. QualificationAvsLicence E.==. E.justVal lic) -- correct type of licence E.&&. (quali E.^. QualificationAvsLicence E.==. E.justVal lic) -- correct type of licence
E.&&. (now `validQualification` qualUser) -- currently valid and not blocked E.&&. (now `validQualification` qualUser) -- currently valid and not blocked
) )
`E.innerJoin` E.table @UserAvs `E.innerJoin` E.table @UserAvs
`E.on` (\(_ :& qualUser :& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser) `E.on` (\(_ :& qualUser :& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser)
@ -953,16 +965,16 @@ getDifferingLicences (AvsResponseGetLicences licences) = do
((vorfGrant, vorfRevoke), (rollGrant, rollRevoke)) <- runDB $ (,) ((vorfGrant, vorfRevoke), (rollGrant, rollRevoke)) <- runDB $ (,)
<$> antijoinAvsLicences AvsLicenceVorfeld vorORrollfeld <$> antijoinAvsLicences AvsLicenceVorfeld vorORrollfeld
<*> antijoinAvsLicences AvsLicenceRollfeld rollfeld <*> antijoinAvsLicences AvsLicenceRollfeld rollfeld
let setTo0 = vorfRevoke -- revoke driving licences let setTo0 = vorfRevoke -- revoke driving licences
setTo1up = vorfGrant Set.\\ rollGrant -- grant apron driving licence setTo1up = vorfGrant Set.\\ rollGrant -- grant apron driving licence
setTo1down = rollRevoke Set.\\ vorfRevoke -- revoke maneuvering area licence, but retain apron driving licence setTo1down = rollRevoke Set.\\ vorfRevoke -- revoke maneuvering area licence, but retain apron driving licence
setTo2 = (rollGrant Set.\\ vorfRevoke) `Set.intersection` (vorfGrant `Set.union` vorORrollfeld) -- grant maneuvering driving licence setTo2 = (rollGrant Set.\\ vorfRevoke) `Set.intersection` (vorfGrant `Set.union` vorORrollfeld) -- grant maneuvering driving licence
return AvsLicenceDifferences return AvsLicenceDifferences
{ avsLicenceDiffRevokeAll = setTo0 { avsLicenceDiffRevokeAll = setTo0
, avsLicenceDiffGrantVorfeld = setTo1up , avsLicenceDiffGrantVorfeld = setTo1up
, avsLicenceDiffRevokeRollfeld = setTo1down , avsLicenceDiffRevokeRollfeld = setTo1down
, avsLicenceDiffGrantRollfeld = setTo2 , avsLicenceDiffGrantRollfeld = setTo2
} }
{- Cases to consider (AVS_Licence,has_valid_F, has_valid_R) -> (vorfeld@(toset,unset), rollfeld@(toset,unset)) : {- Cases to consider (AVS_Licence,has_valid_F, has_valid_R) -> (vorfeld@(toset,unset), rollfeld@(toset,unset)) :
A (0,0,0) -> ((_,_),(_,_)) : nop; avs_id not returned from queries, no problem A (0,0,0) -> ((_,_),(_,_)) : nop; avs_id not returned from queries, no problem
B (0,0,1) -> ((_,_),(x,_)) : nop; do nothing -- CHECK since id is returned by roll-query B (0,0,1) -> ((_,_),(x,_)) : nop; do nothing -- CHECK since id is returned by roll-query

39
src/Handler/Utils/Company.hs
View File

@ -26,14 +26,14 @@ company2msg = text2message . ciOriginal . unCompanyKey
wgtCompanies :: UserId -> DB (Maybe Widget) wgtCompanies :: UserId -> DB (Maybe Widget)
wgtCompanies = \uid -> do wgtCompanies = \uid -> do
companies <- E.select $ do companies <- E.select $ do
(usrComp :& comp) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @Company (usrComp :& comp) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @Company
`E.on` (\(usrComp :& comp) -> usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId) `E.on` (\(usrComp :& comp) -> usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId)
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
E.orderBy [E.asc (comp E.^. CompanyName)] E.orderBy [E.asc (comp E.^. CompanyName)]
return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor, usrComp E.^. UserCompanyPriority) return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor, usrComp E.^. UserCompanyPriority)
let (mPri, topCmp, otherCmp) = procCmp mPri companies let (mPri, topCmp, otherCmp) = procCmp mPri companies
resWgt = resWgt =
[whamlet| [whamlet|
$forall c <- topCmp $forall c <- topCmp
<p> <p>
@ -43,7 +43,7 @@ wgtCompanies = \uid -> do
#{c} #{c}
|] |]
return $ toMaybe (notNull topCmp) resWgt return $ toMaybe (notNull topCmp) resWgt
where where
procCmp _ [] = (0, [],[]) procCmp _ [] = (0, [],[])
procCmp maxPri ((E.Value cmpSh, E.Value cmpName, E.Value cmpSpr, E.Value cmpPrio) : cs) = procCmp maxPri ((E.Value cmpSh, E.Value cmpName, E.Value cmpSpr, E.Value cmpPrio) : cs) =
let cmpWgt = companyWidget (cmpSh, cmpName, cmpSpr) let cmpWgt = companyWidget (cmpSh, cmpName, cmpSpr)
@ -53,15 +53,22 @@ wgtCompanies = \uid -> do
-- TODO: use this function in company view Handler.Firm #157 -- TODO: use this function in company view Handler.Firm #157
-- | add all company supervisors for a given users -- | add all company supervisors for a given users
addCompanySupervisors :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryWrite backend, PersistUniqueWrite backend) addCompanySupervisors :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryWrite backend, PersistUniqueWrite backend)
=> Key Company -> Key User -> ReaderT backend m () => Key Company -> Key User -> ReaderT backend m ()
addCompanySupervisors cid uid = addCompanySupervisors cid uid =
E.insertSelectWithConflict E.insertSelectWithConflict
UniqueUserSupervisor UniqueUserSupervisor
( do ( do
userCompany <- E.from $ E.table @UserCompany userCompany <- E.from $ E.table @UserCompany
E.where_ $ userCompany E.^. UserCompanyCompany E.==. E.val cid E.where_ $ userCompany E.^. UserCompanyCompany E.==. E.val cid
E.&&. userCompany E.^. UserCompanySupervisor E.&&. userCompany E.^. UserCompanySupervisor
-- E.&&. E.notExists (do -- restrict to primary company only
-- othr <- E.from $ E.table @UserCompany
-- E.where_ $ othr E.^. UserCompanyPriority E.>. userCompany E.^. UserCompanyPriority
-- E.&&. othr E.^. UserCompanyUser E.==. userCompany E.^. UserCompanyUser
-- E.&&. othr E.^. UserCompanyCompany E.!=. E.val cid -- redundant due to > above, but likely performance improving
-- )
return $ UserSupervisor return $ UserSupervisor
E.<# (userCompany E.^. UserCompanyUser) E.<# (userCompany E.^. UserCompanyUser)
E.<&> E.val uid E.<&> E.val uid
@ -72,7 +79,7 @@ addCompanySupervisors cid uid =
(\current excluded -> -- Supervision between chosen individuals exists already; keep old reason and company, if exists (\current excluded -> -- Supervision between chosen individuals exists already; keep old reason and company, if exists
[ UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] -- do we want this? Ok, since we delete unconditionally first?! [ UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] -- do we want this? Ok, since we delete unconditionally first?!
, UserSupervisorReason E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason ] , UserSupervisorReason E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason ]
] ]
) )
@ -80,7 +87,7 @@ addCompanySupervisors cid uid =
switchAvsUserCompany :: Bool -> Bool -> UserId -> CompanyId -> DB ([Update User], [AdminProblem]) switchAvsUserCompany :: Bool -> Bool -> UserId -> CompanyId -> DB ([Update User], [AdminProblem])
switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = do switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = do
usrRec <- get404 uid usrRec <- get404 uid
newCompany <- get404 newCompanyId newCompany <- get404 newCompanyId
mbUsrComp <- getUserPrimaryCompany uid mbUsrComp <- getUserPrimaryCompany uid
mbOldComp <- (get . userCompanyCompany) `traverseJoin` mbUsrComp mbOldComp <- (get . userCompanyCompany) `traverseJoin` mbUsrComp
mbUsrAvs <- if usrPostEmailUpds then getBy (UniqueUserAvsUser uid) else return Nothing mbUsrAvs <- if usrPostEmailUpds then getBy (UniqueUserAvsUser uid) else return Nothing
@ -89,14 +96,14 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
usrPostUp = toMaybe (usrPostEmailUpds && fromMaybe False (liftA2 isSimilarMarkup usrPostAddr avsPostAddr)) usrPostUp = toMaybe (usrPostEmailUpds && fromMaybe False (liftA2 isSimilarMarkup usrPostAddr avsPostAddr))
(UserPostAddress =. Nothing) -- use company address indirectly instead (UserPostAddress =. Nothing) -- use company address indirectly instead
usrPrefPost = userPrefersPostal usrRec usrPrefPost = userPrefersPostal usrRec
usrPrefPostUp = toMaybe (Just usrPrefPost == (mbOldComp ^? _Just . _companyPrefersPostal)) usrPrefPostUp = toMaybe (Just usrPrefPost == (mbOldComp ^? _Just . _companyPrefersPostal))
(UserPrefersPostal =. companyPrefersPostal newCompany) (UserPrefersPostal =. companyPrefersPostal newCompany)
usrEmail :: UserEmail = userDisplayEmail usrRec usrEmail :: UserEmail = userDisplayEmail usrRec
avsEmail :: Maybe UserEmail = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPrimaryEmail . _Just . from _CI avsEmail :: Maybe UserEmail = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPrimaryEmail . _Just . from _CI
usrEmailUp = toMaybe (usrPostEmailUpds && avsEmail == Just usrEmail) (UserDisplayEmail =. "") usrEmailUp = toMaybe (usrPostEmailUpds && avsEmail == Just usrEmail) (UserDisplayEmail =. "")
usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrEmailUp] usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrEmailUp]
-- [UserPostAddress =. Nothing, UserPrefersPostal =. companyPrefersPostal newCompany] -- unconditional -- [UserPostAddress =. Nothing, UserPrefersPostal =. companyPrefersPostal newCompany] -- unconditional
-- update uid usrUpdate -- update uid usrUpdate
-- repsertSuperiorSupervisor is not called here, since the Superior is indepentent of the actual company association -- repsertSuperiorSupervisor is not called here, since the Superior is indepentent of the actual company association
case mbUsrComp of case mbUsrComp of
Nothing -> do -- create company user Nothing -> do -- create company user
@ -105,10 +112,10 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
return (usrUpdate, mempty) return (usrUpdate, mempty)
Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute} Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute}
| newCompanyId == oldCompanyId -> return mempty -- nothing to do | newCompanyId == oldCompanyId -> return mempty -- nothing to do
| otherwise -> do -- switch company | otherwise -> do -- switch company
void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp
[UserCompanyPriority =. succ oldPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True] [UserCompanyPriority =. succ oldPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True]
-- supervised by uid -- supervised by uid
supervisees :: [(Entity UserSupervisor, E.Value Bool)] <- E.select $ do supervisees :: [(Entity UserSupervisor, E.Value Bool)] <- E.select $ do
usrSup <- E.from $ E.table @UserSupervisor usrSup <- E.from $ E.table @UserSupervisor
E.where_ $ usrSup E.^. UserSupervisorSupervisor E.==. E.val uid E.where_ $ usrSup E.^. UserSupervisorSupervisor E.==. E.val uid
@ -118,14 +125,14 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
othSup <- E.from $ E.table @UserSupervisor othSup <- E.from $ E.table @UserSupervisor
E.where_ $ usrSup E.^. UserSupervisorUser E.==. othSup E.^. UserSupervisorUser E.where_ $ usrSup E.^. UserSupervisorUser E.==. othSup E.^. UserSupervisorUser
E.&&. othSup E.^. UserSupervisorCompany E.~=. E.val oldCompanyId E.&&. othSup E.^. UserSupervisorCompany E.~=. E.val oldCompanyId
E.&&. othSup E.^. UserSupervisorReason E.~=. E.val superReasonComDef E.&&. othSup E.^. UserSupervisorReason E.~=. E.val superReasonComDef
return (usrSup, singleSup) return (usrSup, singleSup)
newlyUnsupervised <- guardMonoidM (notNull supervisees) $ do newlyUnsupervised <- guardMonoidM (notNull supervisees) $ do
E.delete $ do E.delete $ do
usrSup <- E.from $ E.table @UserSupervisor usrSup <- E.from $ E.table @UserSupervisor
E.where_ $ usrSup E.^. UserSupervisorId `E.in_` E.vals (fmap (entityKey . fst) supervisees) E.where_ $ usrSup E.^. UserSupervisorId `E.in_` E.vals (fmap (entityKey . fst) supervisees)
return $ [ AdminProblemSupervisorLeftCompany subid oldCompanyId oldSuperReroute return $ [ AdminProblemSupervisorLeftCompany subid oldCompanyId oldSuperReroute
| (Entity{entityVal=UserSupervisor{userSupervisorUser=subid}}, E.Value True) <- supervisees ] | (Entity{entityVal=UserSupervisor{userSupervisorUser=subid}}, E.Value True) <- supervisees ]
-- supervisors of uid -- supervisors of uid
let superDeftFltr = (UserSupervisorUser ==. uid) : (UserSupervisorReason ~=. superReasonComDef) let superDeftFltr = (UserSupervisorUser ==. uid) : (UserSupervisorReason ~=. superReasonComDef)
oldSubFltr = (UserSupervisorCompany ~=. oldCompanyId) <> superDeftFltr oldSubFltr = (UserSupervisorCompany ~=. oldCompanyId) <> superDeftFltr
@ -139,6 +146,6 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
$ bcons isNoLongerSupervised (AdminProblemNewlyUnsupervised uid (Just oldCompanyId) newCompanyId) $ bcons isNoLongerSupervised (AdminProblemNewlyUnsupervised uid (Just oldCompanyId) newCompanyId)
newlyUnsupervised newlyUnsupervised
return (usrUpdate ,problems) return (usrUpdate ,problems)
where where
newUserComp = UserCompany uid newCompanyId False False 1 True -- default value for new company insertion, if no update can be done newUserComp = UserCompany uid newCompanyId False False 1 True -- default value for new company insertion, if no update can be done
superReasonComDef = tshow SupervisorReasonCompanyDefault superReasonComDef = tshow SupervisorReasonCompanyDefault

18
src/Handler/Utils/Widgets.hs
View File

@ -61,11 +61,18 @@ nameWidget displayName surname = toWidget $ nameHtml displayName surname
userWidget :: HasUser c => c -> Widget userWidget :: HasUser c => c -> Widget
userWidget x = nameWidget (x ^. _userDisplayName) (x ^._userSurname) userWidget x = nameWidget (x ^. _userDisplayName) (x ^._userSurname)
userIdWidget :: UserId -> Widget
userIdWidget uid = maybeM (msg2widget MsgUserUnknown) userWidget (liftHandler $ runDB $ get uid)
linkUserWidget :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> Entity User -> Widget linkUserWidget :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> Entity User -> Widget
linkUserWidget lnk (Entity uid usr) = do linkUserWidget lnk (Entity uid usr) = do
uuid <- encrypt uid uuid <- encrypt uid
simpleLink (userWidget usr) (lnk uuid) simpleLink (userWidget usr) (lnk uuid)
-- | like linkUserWidget, but on Id only. Requires DB access, use with caution
linkUserIdWidget :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> UserId -> Widget
linkUserIdWidget lnk uid = maybeM (msg2widget MsgUserUnknown) (linkUserWidget lnk . Entity uid) (liftHandler $ runDB $ get uid)
userEmailWidget :: HasUser c => c -> Widget userEmailWidget :: HasUser c => c -> Widget
userEmailWidget x = nameEmailWidget (x ^. _userDisplayEmail) (x ^. _userDisplayName) (x ^. _userSurname) userEmailWidget x = nameEmailWidget (x ^. _userDisplayEmail) (x ^. _userDisplayName) (x ^. _userSurname)
@ -139,7 +146,7 @@ companyWidget (csh, cname, isSupervisor) = simpleLink (toWgt name) curl
where where
curl = FirmUsersR csh curl = FirmUsersR csh
corg = ciOriginal cname corg = ciOriginal cname
name name
| isSupervisor = text2markup (corg <> " ") <> icon IconSupervisor | isSupervisor = text2markup (corg <> " ") <> icon IconSupervisor
| otherwise = text2markup corg | otherwise = text2markup corg
@ -260,15 +267,15 @@ roomReferenceWidget RoomReferenceLink{..} = $(widgetFile "widgets/room-reference
-- Data.Aeson.Encode.Pretty.encodePretty did not render in Html properly, hence jsonWidget -- Data.Aeson.Encode.Pretty.encodePretty did not render in Html properly, hence jsonWidget
jsonWidget :: ToJSON a => a -> Widget jsonWidget :: ToJSON a => a -> Widget
jsonWidget x = jsonWidgetAux $ toJSON x jsonWidget x = jsonWidgetAux $ toJSON x
where where
jsonWidgetAux :: Value -> Widget jsonWidgetAux :: Value -> Widget
jsonWidgetAux Null = [whamlet|Null|] jsonWidgetAux Null = [whamlet|Null|]
jsonWidgetAux (Bool b) = toWidget $ boolSymbol b jsonWidgetAux (Bool b) = toWidget $ boolSymbol b
jsonWidgetAux (String s) = [whamlet|#{s}|] jsonWidgetAux (String s) = [whamlet|#{s}|]
jsonWidgetAux (Number n) jsonWidgetAux (Number n)
| isInteger n = [whamlet|#{formatScientific Fixed (Just 0) n}|] | isInteger n = [whamlet|#{formatScientific Fixed (Just 0) n}|]
| otherwise = [whamlet|#{formatScientific Generic Nothing n}|] | otherwise = [whamlet|#{formatScientific Generic Nothing n}|]
jsonWidgetAux (Array l) jsonWidgetAux (Array l)
| 1 >= length l = foldMap jsonWidgetAux l -- empty arrays don't show | 1 >= length l = foldMap jsonWidgetAux l -- empty arrays don't show
| otherwise = | otherwise =
[whamlet| [whamlet|
@ -285,4 +292,3 @@ jsonWidget x = jsonWidgetAux $ toJSON x
<dt .deflist__dt>#{k} <dt .deflist__dt>#{k}
<dd .deflist__dd>^{jsonWidgetAux v} <dd .deflist__dd>^{jsonWidgetAux v}
|] |]

161
src/Utils.hs
View File

@ -11,7 +11,7 @@ import ClassyPrelude.Yesod hiding (foldlM, Proxy, handle, catch, bracket)
-- import Data.Double.Conversion.Text -- faster implementation for textPercent? -- import Data.Double.Conversion.Text -- faster implementation for textPercent?
import qualified Data.Foldable as Fold import qualified Data.Foldable as Fold
import qualified Data.Traversable as Trav import qualified Data.Traversable as Trav
import Data.Foldable as Utils (foldlM, foldrM) import Data.Foldable as Utils (foldlM, foldrM)
import Data.Monoid (First, Sum(..), Endo) import Data.Monoid (First, Sum(..), Endo)
import Data.Proxy import Data.Proxy
@ -265,7 +265,7 @@ addAttrsClass cl attrs = ("class", cl') : noClAttrs
where where
(clAttrs, noClAttrs) = partition (views _1 $ (== "class") . CI.mk) attrs (clAttrs, noClAttrs) = partition (views _1 $ (== "class") . CI.mk) attrs
cl' = Text.intercalate " " . nubOrd . filter (not . null) $ cl : (views _2 (Text.splitOn " ") =<< clAttrs) cl' = Text.intercalate " " . nubOrd . filter (not . null) $ cl : (views _2 (Text.splitOn " ") =<< clAttrs)
--------------------- ---------------------
-- Text and String -- -- Text and String --
--------------------- ---------------------
@ -289,11 +289,11 @@ stripAll = Text.filter (not . isSpace)
-- | Strips an optional prefix. Like `Data.Text.stripPrefix` but returns input text if the prefix is not matched, micking the behaviour of `dropPrefix` for `Data.Text` -- | Strips an optional prefix. Like `Data.Text.stripPrefix` but returns input text if the prefix is not matched, micking the behaviour of `dropPrefix` for `Data.Text`
dropPrefixText :: Text -> Text -> Text dropPrefixText :: Text -> Text -> Text
-- dropPrefixText p t = fromMaybe t $ stripPrefix p t -- dropPrefixText p t = fromMaybe t $ stripPrefix p t
dropPrefixText p (stripPrefix p -> Just t) = t dropPrefixText p (stripPrefix p -> Just t) = t
dropPrefixText _ other = other dropPrefixText _ other = other
-- | take first line, only -- | take first line, only
cropText :: Text -> Text cropText :: Text -> Text
cropText (Text.take 255 -> t) = headDef t $ Text.lines t cropText (Text.take 255 -> t) = headDef t $ Text.lines t
@ -302,39 +302,39 @@ tshowCrop = cropText . tshow
-- | strip leading and trailing whitespace and make case insensitive -- | strip leading and trailing whitespace and make case insensitive
-- also helps to avoid the need to import just for CI.mk -- also helps to avoid the need to import just for CI.mk
stripCI :: Text -> CI Text stripCI :: Text -> CI Text
stripCI = CI.mk . Text.strip stripCI = CI.mk . Text.strip
-- | Instead of CI.mk, this still allows use of Text.isInfixOf, etc. -- | Instead of CI.mk, this still allows use of Text.isInfixOf, etc.
stripFold :: Text -> Text stripFold :: Text -> Text
stripFold = Text.toCaseFold . Text.strip stripFold = Text.toCaseFold . Text.strip
-- | just to avoid adding an import for this -- | just to avoid adding an import for this
ciOriginal :: CI Text -> Text ciOriginal :: CI Text -> Text
ciOriginal = CI.original ciOriginal = CI.original
ciShow :: Show a => a -> CI Text ciShow :: Show a => a -> CI Text
ciShow = CI.mk . tshow ciShow = CI.mk . tshow
citext2lower :: CI Text -> Text citext2lower :: CI Text -> Text
citext2lower = Text.toLower . CI.original citext2lower = Text.toLower . CI.original
-- avoids unnecessary imports -- avoids unnecessary imports
citext2string :: CI Text -> String citext2string :: CI Text -> String
citext2string = Text.unpack . CI.original citext2string = Text.unpack . CI.original
string2citext :: String -> CI Text string2citext :: String -> CI Text
string2citext = CI.mk . Text.pack string2citext = CI.mk . Text.pack
text2AlphaNumPlus :: [Char] -> Text -> Text text2AlphaNumPlus :: [Char] -> Text -> Text
text2AlphaNumPlus = text2AlphaNumPlus =
let alphaNum = Set.fromAscList $ ['0'..'9'] <> ['A'..'Z'] <> ['a'..'z'] let alphaNum = Set.fromAscList $ ['0'..'9'] <> ['A'..'Z'] <> ['a'..'z']
in \oks -> in \oks ->
let aNumPlus = Set.fromList oks <> alphaNum let aNumPlus = Set.fromList oks <> alphaNum
in Text.filter (`Set.member` aNumPlus) in Text.filter (`Set.member` aNumPlus)
-- | Convert or remove all non-ascii characters, e.g. for filenames -- | Convert or remove all non-ascii characters, e.g. for filenames
text2asciiAlphaNum :: Text -> Text text2asciiAlphaNum :: Text -> Text
text2asciiAlphaNum = text2AlphaNumPlus ['-','_'] text2asciiAlphaNum = text2AlphaNumPlus ['-','_']
. Text.replace "ä" "ae" . Text.replace "ä" "ae"
@ -348,9 +348,9 @@ text2asciiAlphaNum = text2AlphaNumPlus ['-','_']
. Text.replace "á" "a" . Text.replace "á" "a"
. Text.replace "Ö" "Oe" . Text.replace "Ö" "Oe"
. Text.replace "ö" "oe" . Text.replace "ö" "oe"
. Text.replace "œ" "oe" . Text.replace "œ" "oe"
. Text.replace "Ø" "Oe" . Text.replace "Ø" "Oe"
. Text.replace "ø" "oe" . Text.replace "ø" "oe"
. Text.replace "ò" "o" . Text.replace "ò" "o"
. Text.replace "ò" "o" . Text.replace "ò" "o"
. Text.replace "ò" "o" . Text.replace "ò" "o"
@ -359,7 +359,7 @@ text2asciiAlphaNum = text2AlphaNumPlus ['-','_']
. Text.replace "ü" "ue" . Text.replace "ü" "ue"
. Text.replace "ù" "u" . Text.replace "ù" "u"
. Text.replace "ú" "u" . Text.replace "ú" "u"
. Text.replace "û" "u" . Text.replace "û" "u"
. Text.replace "ë" "e" . Text.replace "ë" "e"
. Text.replace "ê" "e" . Text.replace "ê" "e"
. Text.replace "è" "e" . Text.replace "è" "e"
@ -368,7 +368,7 @@ text2asciiAlphaNum = text2AlphaNumPlus ['-','_']
. Text.replace "î" "i" . Text.replace "î" "i"
. Text.replace "ì" "i" . Text.replace "ì" "i"
. Text.replace "í" "i" . Text.replace "í" "i"
. Text.replace "ß" "ss" . Text.replace "ß" "ss"
. Text.replace "ç" "c" . Text.replace "ç" "c"
. Text.replace "ş" "s" . Text.replace "ş" "s"
. Text.replace "ğ" "g" . Text.replace "ğ" "g"
@ -380,10 +380,10 @@ text2Html :: Text -> Html
text2Html = toHtml text2Html = toHtml
citext2Html :: CI Text -> Html citext2Html :: CI Text -> Html
citext2Html = toHtml . CI.original citext2Html = toHtml . CI.original
char2Text :: Char -> Text char2Text :: Char -> Text
char2Text c char2Text c
| isSpace c = "<Space>" | isSpace c = "<Space>"
| otherwise = Text.singleton c | otherwise = Text.singleton c
@ -425,16 +425,16 @@ withFragment :: Monad m => MForm m (a, WidgetFor site ()) -> Markup -> MForm m (
withFragment form html = flip fmap form $ over _2 (toWidget html >>) withFragment form html = flip fmap form $ over _2 (toWidget html >>)
-- | Burst Text into an unordered set of letters -- | Burst Text into an unordered set of letters
charSet :: Text -> Set Char charSet :: Text -> Set Char
charSet = Text.foldl (flip Set.insert) mempty charSet = Text.foldl (flip Set.insert) mempty
-- | Returns Nothing iff both texts are identical, -- | Returns Nothing iff both texts are identical,
-- otherwise a differing character is returned, preferable from the first argument -- otherwise a differing character is returned, preferable from the first argument
textDiff :: Text -> Text -> Maybe Char textDiff :: Text -> Text -> Maybe Char
textDiff (Text.uncons -> xs) (Text.uncons -> ys) textDiff (Text.uncons -> xs) (Text.uncons -> ys)
| Just (x,xt) <- xs | Just (x,xt) <- xs
, Just (y,yt) <- ys , Just (y,yt) <- ys
= if x == y = if x == y
then textDiff xt yt then textDiff xt yt
else Just x else Just x
| otherwise | otherwise
@ -515,17 +515,17 @@ fromText :: (IsString a, Textual t) => t -> a
fromText = fromString . unpack fromText = fromString . unpack
{- {-
-- | Captialize the first character and leave all others as they were -- | Captialize the first character and leave all others as they were
textToCapital :: Text -> Text textToCapital :: Text -> Text
textToCapital s textToCapital s
| Just (h,t) <- Text.uncons s | Just (h,t) <- Text.uncons s
= Text.Cons (Char.toUpper h) t = Text.Cons (Char.toUpper h) t
| otherwise = s | otherwise = s
snakecase2camelcase :: Text -> Text snakecase2camelcase :: Text -> Text
snakecase2camelcase t = Text.concat $ map textToCapital words snakecase2camelcase t = Text.concat $ map textToCapital words
where where
words = Text.splitOn '_' t words = Text.splitOn '_' t
-} -}
-- | Unlike @Data.Text.unlines, there is no trailing LF at the end -- | Unlike @Data.Text.unlines, there is no trailing LF at the end
@ -606,7 +606,7 @@ roundDiv digits numerator denominator
-- | @cutOffCoPercent offset full achieved@ returns a value between 0 and 1, measuring how close @achieved@ is to @full@; 0 meaning very and 1 meaning not at all -- | @cutOffCoPercent offset full achieved@ returns a value between 0 and 1, measuring how close @achieved@ is to @full@; 0 meaning very and 1 meaning not at all
-- --
-- @offset@ specifies minimum result value, unless the @full@ is equal to @achieved@ -- @offset@ specifies minimum result value, unless the @full@ is equal to @achieved@
-- --
-- Useful for heat maps, with offset giving a visual step between completed and not yet completed -- Useful for heat maps, with offset giving a visual step between completed and not yet completed
cutOffCoPercent :: Rational -> Rational -> Rational -> Rational cutOffCoPercent :: Rational -> Rational -> Rational -> Rational
cutOffCoPercent (abs -> offset) (abs -> full) (abs -> achieved) cutOffCoPercent (abs -> offset) (abs -> full) (abs -> achieved)
@ -621,7 +621,7 @@ cutOffCoPercent (abs -> offset) (abs -> full) (abs -> achieved)
-- | @cutOffPercent offset full achieved@ returns a value between 0 and 1, measuring how close @achieved@ is to @full@@; 1 meaning very and 0 meaning not at all -- | @cutOffPercent offset full achieved@ returns a value between 0 and 1, measuring how close @achieved@ is to @full@@; 1 meaning very and 0 meaning not at all
-- --
-- @offset@ specifies minimum result value, unless @achieved@ is zero -- @offset@ specifies minimum result value, unless @achieved@ is zero
-- --
-- Useful for heat maps, with offset giving a visual step between zero and nonzero -- Useful for heat maps, with offset giving a visual step between zero and nonzero
cutOffPercent :: Rational -> Rational -> Rational -> Rational cutOffPercent :: Rational -> Rational -> Rational -> Rational
cutOffPercent (abs -> offset) (abs -> full) (abs -> achieved) cutOffPercent (abs -> offset) (abs -> full) (abs -> achieved)
@ -686,7 +686,7 @@ mapBoth f ~(a,b) = (f a, f b)
notNull :: MonoFoldable mono => mono -> Bool notNull :: MonoFoldable mono => mono -> Bool
notNull = not . null notNull = not . null
headDef :: a -> [a] -> a headDef :: a -> [a] -> a
headDef _ (h:_) = h headDef _ (h:_) = h
headDef d _ = d headDef d _ = d
@ -725,7 +725,7 @@ insertAttr attr valu = aux
| attr==a = (a, Text.append valu $ Text.cons ' ' v) : t | attr==a = (a, Text.append valu $ Text.cons ' ' v) : t
| otherwise = p : aux t | otherwise = p : aux t
-- Could be implemented using updateAssoc like so, but would add superfluous space at the end: -- Could be implemented using updateAssoc like so, but would add superfluous space at the end:
-- insertAttr attr valu = adjustAssoc (Text.append valu . Text.cons ' ') attr -- insertAttr attr valu = adjustAssoc (Text.append valu . Text.cons ' ') attr
-- | Insert key-value pair into association list. -- | Insert key-value pair into association list.
-- If the new value is null/mempty, the first occurrence of the key is removed. (Unlike Data.Map.insert) -- If the new value is null/mempty, the first occurrence of the key is removed. (Unlike Data.Map.insert)
@ -733,13 +733,13 @@ insertAttr attr valu = aux
-- Note: Avoid association lists, if possible. See GHC.Data.List.SetOps -- Note: Avoid association lists, if possible. See GHC.Data.List.SetOps
-- Some of our libraries use association lists for very few keys. -- Some of our libraries use association lists for very few keys.
insertAssoc :: (Eq k, MonoFoldable v) => k -> v -> [(k,v)] -> [(k,v)] insertAssoc :: (Eq k, MonoFoldable v) => k -> v -> [(k,v)] -> [(k,v)]
insertAssoc key val = aux insertAssoc key val = aux
where where
aux [] = mbcons [] aux [] = mbcons []
aux (p@(k,_) : t) aux (p@(k,_) : t)
| key == k = mbcons t | key == k = mbcons t
| otherwise = p : aux t | otherwise = p : aux t
mbcons t mbcons t
| onull val = t | onull val = t
| otherwise = (key,val) : t | otherwise = (key,val) : t
@ -804,7 +804,7 @@ withoutSubsequenceBy cmp = go []
pattern NonEmpty :: forall a. a -> [a] -> NonEmpty a pattern NonEmpty :: forall a. a -> [a] -> NonEmpty a
pattern NonEmpty x xs = x :| xs pattern NonEmpty x xs = x :| xs
{-# COMPLETE NonEmpty #-} {-# COMPLETE NonEmpty #-}
checkAsc :: Ord a => [a] -> Bool checkAsc :: Ord a => [a] -> Bool
checkAsc (x:r@(y:_)) = x<=y && checkAsc r checkAsc (x:r@(y:_)) = x<=y && checkAsc r
checkAsc _ = True checkAsc _ = True
@ -825,7 +825,7 @@ infixl 5 !!!
(!!!) m k = fromMaybe mempty $ Map.lookup k m (!!!) m k = fromMaybe mempty $ Map.lookup k m
lookupSome :: (Monad m, Ord k, Monoid (m v)) => Map k (m v) -> m k -> m v lookupSome :: (Monad m, Ord k, Monoid (m v)) => Map k (m v) -> m k -> m v
-- lookupSome :: Ord k => Map k [v] -> [k] -> [v] -- lookupSome :: Ord k => Map k [v] -> [k] -> [v]
-- lookupSome m ks = ks >>= (m !!!) -- lookupSome m ks = ks >>= (m !!!)
lookupSome = (=<<) . (!!!) lookupSome = (=<<) . (!!!)
@ -842,7 +842,7 @@ maybeMap :: IsMap p => ContainerKey p -> Maybe (MapValue p) -> p
maybeMap k = foldMap (singletonMap k) maybeMap k = foldMap (singletonMap k)
maybeMapWith :: IsMap p => (t -> MapValue p) -> ContainerKey p -> Maybe t -> p maybeMapWith :: IsMap p => (t -> MapValue p) -> ContainerKey p -> Maybe t -> p
maybeMapWith f k = foldMap $ singletonMap k . f maybeMapWith f k = foldMap $ singletonMap k . f
-- | Counts how often a value appears in a map (not derived from invertMap for efficiency reasons) -- | Counts how often a value appears in a map (not derived from invertMap for efficiency reasons)
countMapElems :: (Ord v) => Map k v -> Map v Int countMapElems :: (Ord v) => Map k v -> Map v Int
@ -905,7 +905,7 @@ toNothingS = const Nothing
eq2nothing :: Eq a => (Maybe a, Maybe a) -> (Maybe a, Maybe a) eq2nothing :: Eq a => (Maybe a, Maybe a) -> (Maybe a, Maybe a)
eq2nothing (mx@(Just x), Just y) | x==y = (mx, Nothing) eq2nothing (mx@(Just x), Just y) | x==y = (mx, Nothing)
eq2nothing p = p eq2nothing p = p
-- replaced by a more general formulation, see canonical -- replaced by a more general formulation, see canonical
-- null2nothing :: MonoFoldable a => Maybe a -> Maybe a -- null2nothing :: MonoFoldable a => Maybe a -> Maybe a
-- null2nothing (Just x) | null x = Nothing -- null2nothing (Just x) | null x = Nothing
@ -963,6 +963,7 @@ maybeT x m = runMaybeT m >>= maybe x return
maybeT_ :: Monad m => MaybeT m () -> m () maybeT_ :: Monad m => MaybeT m () -> m ()
maybeT_ = void . runMaybeT maybeT_ = void . runMaybeT
-- Note: for MaybeT, hoistMaybe is more general than the equivalent MaybeT . pure, but also leads to much worse error messages
hoistMaybe :: MonadPlus m => Maybe a -> m a hoistMaybe :: MonadPlus m => Maybe a -> m a
-- ^ `hoist` regarding `Maybe` as if identical to @MaybeT Identity@ -- ^ `hoist` regarding `Maybe` as if identical to @MaybeT Identity@
hoistMaybe = maybe mzero return hoistMaybe = maybe mzero return
@ -1020,7 +1021,7 @@ maybeThrowM = fromMaybeM . throwM
maybeMapM :: Applicative m => (a -> m (Maybe b)) -> [a] -> m [b] maybeMapM :: Applicative m => (a -> m (Maybe b)) -> [a] -> m [b]
maybeMapM f = foldr go (pure []) maybeMapM f = foldr go (pure [])
where where
go = liftA2 (maybe id (:)) . f go = liftA2 (maybe id (:)) . f
mapMaybeM :: ( Monad m mapMaybeM :: ( Monad m
@ -1039,14 +1040,14 @@ forMaybeM = flip mapMaybeM
-- | Only execute second action if the first does not produce a result -- | Only execute second action if the first does not produce a result
altM :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a) altM :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)
altM ma mb = ma >>= \case altM ma mb = ma >>= \case
Nothing -> mb Nothing -> mb
res -> return res res -> return res
-- | Map f and get the first Just -- | Map f and get the first Just
firstJust :: MonoFoldable mono => (Element mono -> Maybe a) -> mono -> Maybe a firstJust :: MonoFoldable mono => (Element mono -> Maybe a) -> mono -> Maybe a
firstJust f = foldr go Nothing firstJust f = foldr go Nothing
where where
-- go :: a -> Maybe b -> Maybe b -- go :: a -> Maybe b -> Maybe b
go x Nothing = f x go x Nothing = f x
go _ res = res go _ res = res
@ -1057,7 +1058,7 @@ firstJust f = foldr go Nothing
-- Copied from GHC.Data.Maybe, which could not be imported somehow. -- Copied from GHC.Data.Maybe, which could not be imported somehow.
-- HOWEVER, this function counterintuitively forces the entire foldable! -- HOWEVER, this function counterintuitively forces the entire foldable!
-- firstJustM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a) -- firstJustM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a)
-- firstJustM = foldlM go Nothing -- firstJustM = foldlM go Nothing
-- where -- where
-- go :: Monad m => Maybe a -> m (Maybe a) -> m (Maybe a) -- go :: Monad m => Maybe a -> m (Maybe a) -> m (Maybe a)
-- go Nothing action = action -- go Nothing action = action
@ -1068,28 +1069,28 @@ firstJustM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a)
firstJustM = Fold.foldr go (return Nothing) firstJustM = Fold.foldr go (return Nothing)
where where
go :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a) go :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)
go n p = n >>= \case {Nothing -> p; res -> return res} go n p = n >>= \case {Nothing -> p; res -> return res}
-- firstJustM1 :: (Monad m, MonoFoldable mono, Element mono ~ m (Maybe a)) => mono -> m (Maybe a) -- firstJustM1 :: (Monad m, MonoFoldable mono, Element mono ~ m (Maybe a)) => mono -> m (Maybe a)
-- firstJustM1 = foldr go (return Nothing) -- firstJustM1 = foldr go (return Nothing)
-- where -- where
-- go n p = n >>= \case {Nothing -> p; res -> return res} -- go n p = n >>= \case {Nothing -> p; res -> return res}
-- | Run the maybe computation repeatedly until the first Just is returned -- | Run the maybe computation repeatedly until the first Just is returned
-- or the number of maximum retries is exhausted. -- or the number of maximum retries is exhausted.
-- So like Control.Monad.Loops.untilJust, but with a maximum number of attempts. -- So like Control.Monad.Loops.untilJust, but with a maximum number of attempts.
untilJustMaxM :: Monad m => Int -> m (Maybe a) -> m (Maybe a) untilJustMaxM :: Monad m => Int -> m (Maybe a) -> m (Maybe a)
untilJustMaxM nmax act = go 0 untilJustMaxM nmax act = go 0
where where
go n | n >= nmax = return Nothing go n | n >= nmax = return Nothing
| otherwise = do | otherwise = do
x <- act x <- act
case x of case x of
Nothing -> go $ succ n Nothing -> go $ succ n
res@(Just _) -> return res res@(Just _) -> return res
------------ ------------
-- Either -- -- Either --
------------ ------------
@ -1111,8 +1112,8 @@ whenIsRight (Right x) f = f x
whenIsRight (Left _) _ = pure () whenIsRight (Left _) _ = pure ()
{- Just a reminder for Steffen: {- Just a reminder for Steffen:
mapLeft :: (a -> c) -> Either a b -> Either c b mapLeft :: (a -> c) -> Either a b -> Either c b
mapLeft = over _Left mapLeft = over _Left
-} -}
throwLeft :: (MonadThrow m, Exception exc) => Either exc a -> m a throwLeft :: (MonadThrow m, Exception exc) => Either exc a -> m a
@ -1137,20 +1138,20 @@ actRight (Right y) f = f y
-- maybeCatchAll :: MonadCatch m => m a -> m (Maybe a) -- maybeCatchAll :: MonadCatch m => m a -> m (Maybe a)
-- maybeCatchAll act = catch (Just <$> act) ignore -- maybeCatchAll act = catch (Just <$> act) ignore
-- where -- where
-- ignore :: Monad m => SomeException -> m (Maybe a) -- ignore :: Monad m => SomeException -> m (Maybe a)
-- ignore _ = return Nothing -- ignore _ = return Nothing
-- | Ignore all errors by returning Nothing. (Not sure if this function is a good idea) -- | Ignore all errors by returning Nothing. (Not sure if this function is a good idea)
maybeCatchAll :: MonadCatch m => m (Maybe a) -> m (Maybe a) maybeCatchAll :: MonadCatch m => m (Maybe a) -> m (Maybe a)
maybeCatchAll act = catch act ignore maybeCatchAll act = catch act ignore
where where
ignore :: Monad m => SomeException -> m (Maybe a) ignore :: Monad m => SomeException -> m (Maybe a)
ignore _ = return Nothing ignore _ = return Nothing
maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b
maybeExceptT err act = lift act >>= maybe (throwE err) return maybeExceptT err act = lift act >>= maybe (throwE err) return
maybeExceptT' :: Monad m => e -> Maybe b -> ExceptT e m b maybeExceptT' :: Monad m => e -> Maybe b -> ExceptT e m b
maybeExceptT' err = maybe (throwE err) return maybeExceptT' err = maybe (throwE err) return
@ -1299,10 +1300,10 @@ continueJust (Just x) f = f x
continueJust Nothing _ = pure mempty continueJust Nothing _ = pure mempty
maybeContinue :: (Monoid b, Monad m) => m (Maybe a) -> (a -> m b) -> m b maybeContinue :: (Monoid b, Monad m) => m (Maybe a) -> (a -> m b) -> m b
maybeContinue mx f = mx >>= \case maybeContinue mx f = mx >>= \case
Nothing -> return mempty Nothing -> return mempty
Just x -> f x Just x -> f x
-} -}
ifoldMapM :: (FoldableWithIndex i f, Monad m, Monoid b) => (i -> a -> m b) -> f a -> m b ifoldMapM :: (FoldableWithIndex i f, Monad m, Monoid b) => (i -> a -> m b) -> f a -> m b
ifoldMapM f = ifoldrM (\i x xs -> (<> xs) <$> f i x) mempty ifoldMapM f = ifoldrM (\i x xs -> (<> xs) <$> f i x) mempty
@ -1437,13 +1438,13 @@ tellM = tell <=< lift
tellPoint :: forall mono m. (MonadWriter mono m, MonoPointed mono) => Element mono -> m () tellPoint :: forall mono m. (MonadWriter mono m, MonoPointed mono) => Element mono -> m ()
tellPoint = tell . opoint tellPoint = tell . opoint
tellMPoint :: (MonadTrans t, MonadWriter mono (t m), Monad m, MonoPointed mono) => m (Element mono) -> t m () tellMPoint :: (MonadTrans t, MonadWriter mono (t m), Monad m, MonoPointed mono) => m (Element mono) -> t m ()
tellMPoint = tellM . fmap opoint tellMPoint = tellM . fmap opoint
class IsWriterT t where class IsWriterT t where
runWriterT' :: (Monad m, Monoid w) => t w m a -> m (a, w) runWriterT' :: (Monad m, Monoid w) => t w m a -> m (a, w)
mapWriterT' :: (m (a, w) -> n (b, w')) -> t w m a -> t w' n b mapWriterT' :: (m (a, w) -> n (b, w')) -> t w m a -> t w' n b
instance IsWriterT Strict.WriterT where instance IsWriterT Strict.WriterT where
runWriterT' = Strict.runWriterT runWriterT' = Strict.runWriterT
mapWriterT' = Strict.mapWriterT mapWriterT' = Strict.mapWriterT
@ -1549,7 +1550,7 @@ data CustomHeader
| HeaderAlerts | HeaderAlerts
| HeaderDBTableCanonicalURL | HeaderDBTableCanonicalURL
| HeaderDryRun | HeaderDryRun
| HeaderUploadToken | HeaderUploadToken
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe CustomHeader instance Universe CustomHeader
@ -1872,8 +1873,8 @@ pickBetter x y crit
| cx == cy = Nothing | cx == cy = Nothing
| cx = Just x | cx = Just x
| otherwise = Just y | otherwise = Just y
where where
cx = crit x cx = crit x
cy = crit y cy = crit y
reverseOrdering :: Ordering -> Ordering reverseOrdering :: Ordering -> Ordering
@ -1940,7 +1941,7 @@ makePrisms ''MergeHashMap
makeWrapped ''MergeHashMap makeWrapped ''MergeHashMap
type instance Element (MergeHashMap k v) = v type instance Element (MergeHashMap k v) = v
instance MonoFoldable (MergeHashMap k v) instance MonoFoldable (MergeHashMap k v)
instance MonoFunctor (MergeHashMap k v) instance MonoFunctor (MergeHashMap k v)
instance MonoTraversable (MergeHashMap k v) instance MonoTraversable (MergeHashMap k v)
@ -1994,7 +1995,7 @@ makePrisms ''MergeMap
makeWrapped ''MergeMap makeWrapped ''MergeMap
type instance Element (MergeMap k v) = v type instance Element (MergeMap k v) = v
instance MonoFoldable (MergeMap k v) instance MonoFoldable (MergeMap k v)
instance MonoFunctor (MergeMap k v) instance MonoFunctor (MergeMap k v)
instance MonoTraversable (MergeMap k v) instance MonoTraversable (MergeMap k v)
@ -2035,7 +2036,7 @@ instance (Ord k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON (MergeMap k
parseJSONElemAtIndex :: (Value -> Aeson.Parser a) -> Int -> Vector Value -> Aeson.Parser a parseJSONElemAtIndex :: (Value -> Aeson.Parser a) -> Int -> Vector Value -> Aeson.Parser a
parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) Aeson.<?> Aeson.Index idx parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) Aeson.<?> Aeson.Index idx
-------------- --------------
-- FilePath -- -- FilePath --
-------------- --------------
@ -2061,7 +2062,7 @@ makePrisms ''ExitCase
--------------- ---------------
-- | Bad hack class for datatypes that have multiple inequal representations which ought to be identical, i.e. Just "" ~= Nothing -- | Bad hack class for datatypes that have multiple inequal representations which ought to be identical, i.e. Just "" ~= Nothing
class Canonical a where class Canonical a where
canonical :: a -> a canonical :: a -> a
@ -2071,8 +2072,8 @@ instance {-# OVERLAPPABLE #-} MonoFoldable mono => Canonical (Maybe mono) where
{- {-
instance {-# OVERLAPPABLE #-} (Canonical mono, MonoFoldable mono, Eq mono) => Canonical (Maybe mono) where instance {-# OVERLAPPABLE #-} (Canonical mono, MonoFoldable mono, Eq mono) => Canonical (Maybe mono) where
canonical r@(Just t) = let c = canonical t canonical r@(Just t) = let c = canonical t
in if null c then Nothing else in if null c then Nothing else
if t==c then r else Just c if t==c then r else Just c
canonical other = other canonical other = other
-} -}

28
test/Database/Fill.hs
View File

@ -66,7 +66,7 @@ fillDb = do
n_day n = addBDays n $ utctDay now n_day n = addBDays n $ utctDay now
n_day' n = now { utctDay = n_day n } n_day' n = now { utctDay = n_day n }
(currentYear, _currentMonth, _currentDay) = toGregorian $ utctDay now (currentYear, _currentMonth, _currentDay) = toGregorian $ utctDay now
currentTerm = TermIdentifier currentYear currentTerm = TermIdentifier currentYear
nextTerm n = toEnum . (+n) $ fromEnum currentTerm nextTerm n = toEnum . (+n) $ fromEnum currentTerm
termTime :: TermIdentifier -- ^ Term termTime :: TermIdentifier -- ^ Term
@ -572,13 +572,13 @@ fillDb = do
Just middleName' -> repack [st|#{firstName}.#{middleName'}.#{userSurname}@example.invalid|] Just middleName' -> repack [st|#{firstName}.#{middleName'}.#{userSurname}@example.invalid|]
Nothing -> repack [st|#{firstName}.#{userSurname}@example.invalid|] Nothing -> repack [st|#{firstName}.#{userSurname}@example.invalid|]
userEmail' :: CI Text userEmail' :: CI Text
userEmail' = CI.mk $ case firstName of userEmail' = CI.mk $ case firstName of
"James" -> userIdent "James" -> userIdent
"John" -> userIdent "John" -> userIdent
"Elizabeth" -> "AVSID:" <> userMatrikelnummer' "Elizabeth" -> "AVSID:" <> userMatrikelnummer'
_ -> "E" <> userMatrikelnummer' <> "@fraport.de" _ -> "E" <> userMatrikelnummer' <> "@fraport.de"
userDisplayEmail' :: CI Text userDisplayEmail' :: CI Text
userDisplayEmail' = CI.mk $ case userSurname of userDisplayEmail' = CI.mk $ case userSurname of
"Walker" -> "AVSNO:" <> userMatrikelnummer' "Walker" -> "AVSNO:" <> userMatrikelnummer'
"Clark" -> "E" <> userMatrikelnummer' <> "@fraport.de" "Clark" -> "E" <> userMatrikelnummer' <> "@fraport.de"
"Jackson" -> "" "Jackson" -> ""
@ -591,12 +591,12 @@ fillDb = do
-- | otherwise -- | otherwise
-- = [] -- = []
-- matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int) -- matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int)
baseMatrikel <- getRandomR (10000 :: Int, 999999 :: Int) baseMatrikel <- getRandomR (10000 :: Int, 999999 :: Int)
let matrikel = tshow <$> [baseMatrikel..] List.\\ [6969, 669966, 996699] let matrikel = tshow <$> [baseMatrikel..] List.\\ [6969, 669966, 996699]
manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel
matUsers <- selectList [UserMatrikelnummer !=. Nothing] [] matUsers <- selectList [UserMatrikelnummer !=. Nothing] []
insertMany_ [UserAvs (AvsPersonId n) uid n now Nothing Nothing Nothing Nothing | Entity uid User{userMatrikelnummer = fmap readMay -> Just (Just n)} <- matUsers] insertMany_ [UserAvs (AvsPersonId n) uid n now Nothing Nothing Nothing Nothing | Entity uid User{userMatrikelnummer = fmap readMay -> Just (Just n)} <- matUsers]
let tmin = -1 let tmin = -1
tmax = 2 tmax = 2
trange = [tmin..tmax] trange = [tmin..tmax]
@ -692,26 +692,26 @@ fillDb = do
, UserSupervisor gkleen fhamann False (Just fraGround) (Just "Staff") , UserSupervisor gkleen fhamann False (Just fraGround) (Just "Staff")
, UserSupervisor gkleen gkleen True (Just fraGround) (Just "Staff") , UserSupervisor gkleen gkleen True (Just fraGround) (Just "Staff")
, UserSupervisor tinaTester tinaTester False Nothing (Just "Staff") , UserSupervisor tinaTester tinaTester False Nothing (Just "Staff")
] ]
++ take 444 [ UserSupervisor fhamann uid True Nothing (Just $ tshow SupervisorReasonCompanyDefault) | Entity uid _ <- matUsers, uid /= jost] ++ take 444 [ UserSupervisor fhamann uid True Nothing (Just $ tshow SupervisorReasonCompanyDefault) | Entity uid _ <- matUsers, uid /= jost]
++ take 123 [ UserSupervisor gkleen uid True Nothing Nothing | Entity uid _ <- drop 369 matUsers ] ++ take 123 [ UserSupervisor gkleen uid True Nothing Nothing | Entity uid _ <- drop 369 matUsers ]
++ take 11 [ UserSupervisor jost uid False Nothing (Just $ tshow SupervisorReasonCompanyDefault) | Entity uid _ <- drop 501 matUsers ] ++ take 11 [ UserSupervisor jost uid False Nothing (Just $ tshow SupervisorReasonCompanyDefault) | Entity uid _ <- drop 501 matUsers ]
upsertManyWhere supvs [] [] [] upsertManyWhere supvs [] [] []
-- insertMany_ supvs -- NOTE: multiple calls like this throw a runtime error! -- insertMany_ supvs -- NOTE: multiple calls like this throw a runtime error!
-- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok -- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok
-- upsertManyWhere (supvs ++ take 5 (drop 12 [ UserSupervisor jost uid False | Entity uid _ <- drop 501 matUsers ])) -- no duplicates within first argument allowed! (runtime error: ON CONFLICT DO UPDATE command cannot affect row a second time) -- upsertManyWhere (supvs ++ take 5 (drop 12 [ UserSupervisor jost uid False | Entity uid _ <- drop 501 matUsers ])) -- no duplicates within first argument allowed! (runtime error: ON CONFLICT DO UPDATE command cannot affect row a second time)
-- [copyField UserSupervisorRerouteNotifications] [UserSupervisorRerouteNotifications =. True] [UserSupervisorSupervisor ==. jost, UserSupervisorUser <-. [uid | Entity uid _ <- take 3 $ drop 504 matUsers ]] -- does not work! -- [copyField UserSupervisorRerouteNotifications] [UserSupervisorRerouteNotifications =. True] [UserSupervisorSupervisor ==. jost, UserSupervisorUser <-. [uid | Entity uid _ <- take 3 $ drop 504 matUsers ]] -- does not work!
-- let changeSome usr@(UserSupervisor s u _) -- let changeSome usr@(UserSupervisor s u _)
-- | s == jost, u `elem` take 14 [ uid | Entity uid _ <- drop 501 matUsers ] = UserSupervisor s u True -- | s == jost, u `elem` take 14 [ uid | Entity uid _ <- drop 501 matUsers ] = UserSupervisor s u True
-- | otherwise = usr -- | otherwise = usr
-- upsertManyWhere (changeSome <$> (supvs ++ take 5 (drop 12 [ UserSupervisor jost uid False | Entity uid _ <- drop 501 matUsers ]))) -- no duplicates within first argument allowed! (runtime error: ON CONFLICT DO UPDATE command cannot affect row a second time) -- upsertManyWhere (changeSome <$> (supvs ++ take 5 (drop 12 [ UserSupervisor jost uid False | Entity uid _ <- drop 501 matUsers ]))) -- no duplicates within first argument allowed! (runtime error: ON CONFLICT DO UPDATE command cannot affect row a second time)
-- [copyField UserSupervisorRerouteNotifications] [] [UserSupervisorSupervisor ==. jost, UserSupervisorUser <-. [uid | Entity uid _ <- take 3 $ drop 504 matUsers ]] -- probably does the same as the above -- [copyField UserSupervisorRerouteNotifications] [] [UserSupervisorSupervisor ==. jost, UserSupervisorUser <-. [uid | Entity uid _ <- take 3 $ drop 504 matUsers ]] -- probably does the same as the above
-- OBSERVATIONS: -- OBSERVATIONS:
-- - use the 2. argument with `copyField` to overwrite an existing field with the new record value provided in the 1. argument in case of an update -- - use the 2. argument with `copyField` to overwrite an existing field with the new record value provided in the 1. argument in case of an update
-- - use the 3. argument to update a field indepently from the provided records or for computations involving previous values, eg. +=. -- - use the 3. argument to update a field indepently from the provided records or for computations involving previous values, eg. +=.
-- - use the 4. argument to filter both the application of the 2. and 3. argument -- - use the 4. argument to filter both the application of the 2. and 3. argument
ifi <- insert' $ School "Institut für Informatik" "IfI" (Just $ 14 * nominalDay) (Just $ 10 * nominalDay) True (ExamModeDNF predDNFFalse) (ExamCloseOnFinished True) SchoolAuthorshipStatementModeOptional (Just ifiAuthorshipStatement) True SchoolAuthorshipStatementModeRequired (Just ifiAuthorshipStatement) False ifi <- insert' $ School "Institut für Informatik" "IfI" (Just $ 14 * nominalDay) (Just $ 10 * nominalDay) True (ExamModeDNF predDNFFalse) (ExamCloseOnFinished True) SchoolAuthorshipStatementModeOptional (Just ifiAuthorshipStatement) True SchoolAuthorshipStatementModeRequired (Just ifiAuthorshipStatement) False
mi <- insert' $ School "Institut für Mathematik" "MI" Nothing Nothing False (ExamModeDNF predDNFFalse) (ExamCloseOnFinished False) SchoolAuthorshipStatementModeNone Nothing True SchoolAuthorshipStatementModeOptional Nothing True mi <- insert' $ School "Institut für Mathematik" "MI" Nothing Nothing False (ExamModeDNF predDNFFalse) (ExamCloseOnFinished False) SchoolAuthorshipStatementModeNone Nothing True SchoolAuthorshipStatementModeOptional Nothing True
@ -719,13 +719,13 @@ fillDb = do
void . insert' $ UserFunction jost avn SchoolAdmin void . insert' $ UserFunction jost avn SchoolAdmin
void . insert' $ UserFunction gkleen ifi SchoolAdmin void . insert' $ UserFunction gkleen ifi SchoolAdmin
void . insert' $ UserFunction gkleen mi SchoolAdmin void . insert' $ UserFunction gkleen mi SchoolAdmin
-- void . insert' $ UserFunction fhamann ifi SchoolAdmin -- goto-example for non-admin supervisor -- void . insert' $ UserFunction fhamann ifi SchoolAdmin -- goto-example for non-admin supervisor
void . insert' $ UserFunction jost ifi SchoolAdmin void . insert' $ UserFunction jost ifi SchoolAdmin
void . insert' $ UserFunction jost mi SchoolAdmin void . insert' $ UserFunction jost mi SchoolAdmin
void . insert' $ UserFunction svaupel ifi SchoolAdmin void . insert' $ UserFunction svaupel ifi SchoolAdmin
void . insert' $ UserFunction svaupel mi SchoolAdmin void . insert' $ UserFunction svaupel mi SchoolAdmin
void . insert' $ UserFunction gkleen ifi SchoolLecturer void . insert' $ UserFunction gkleen ifi SchoolLecturer
-- void . insert' $ UserFunction fhamann ifi SchoolLecturer -- goto-example for non-admin supervisor -- void . insert' $ UserFunction fhamann ifi SchoolLecturer -- goto-example for non-admin supervisor
void . insert' $ UserFunction jost ifi SchoolLecturer void . insert' $ UserFunction jost ifi SchoolLecturer
void . insert' $ UserFunction svaupel ifi SchoolLecturer void . insert' $ UserFunction svaupel ifi SchoolLecturer
void . insert' $ UserFunction sbarth ifi SchoolLecturer void . insert' $ UserFunction sbarth ifi SchoolLecturer
@ -802,6 +802,8 @@ fillDb = do
insert_ $ ProblemLog now (toJSON $ AdminProblemNewCompany ffacil ) 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 fhamann fraportAg ffacil True ) Nothing Nothing
insert_ $ ProblemLog now (toJSON $ AdminProblemSupervisorNewCompany gkleen ffacil fraGround False) Nothing Nothing insert_ $ ProblemLog now (toJSON $ AdminProblemSupervisorNewCompany gkleen ffacil fraGround False) Nothing Nothing
insert_ $ ProblemLog now (toJSON $ AdminProblemCompanySuperiorChange jost fraportAg (Just gkleen)) Nothing Nothing
insert_ $ ProblemLog now (toJSON $ AdminProblemCompanySuperiorChange fhamann fraGround Nothing) Nothing Nothing
insert_ $ ProblemLog now (toJSON $ AdminProblemUnknown "This is a test problem only.") Nothing Nothing insert_ $ ProblemLog now (toJSON $ AdminProblemUnknown "This is a test problem only.") Nothing Nothing
let let
@ -1024,7 +1026,7 @@ fillDb = do
, courseDeregisterUntil = jtt TermDayLectureStart 5 (Just Monday) toMidnight , courseDeregisterUntil = jtt TermDayLectureStart 5 (Just Monday) toMidnight
, courseRegisterSecret = Nothing , courseRegisterSecret = Nothing
, courseMaterialFree = True , courseMaterialFree = True
} }
insert_ $ CourseEdit jost now c insert_ $ CourseEdit jost now c
when (tyear >= currentYear) $ insert_ $ CourseQualification c qid_f 2 when (tyear >= currentYear) $ insert_ $ CourseQualification c qid_f 2
when (tyear >= succ currentYear) $ insert_ $ CourseQualification c qid_r 3 when (tyear >= succ currentYear) $ insert_ $ CourseQualification c qid_r 3