fraport/fradrive
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
BearerTokenOverrideStartTip: Wird kein Startzeitpunkt angegeben, wird bei Verwendung des Tokens nur der Ablaufzeitpunkt überprüft.
HeadingAdminTokens: Tokens ausstellen
UserUnknown: Unbekannter Benutzer:in
#templates adminFeautures
StudyFeaturesDegrees: Abschlüsse
@ -127,9 +128,11 @@ AdminProblemCreated: Erkannt
AdminProblemInfo: Problembeschreibung
AdminProblemsSolved n@Int: #{pluralDEeN n "Admin Problem"} als erledigt markiert
AdminProblemsReopened n@Int: #{pluralDEeN n "Admin Problem"} erneut eröffnet
AdminProblemNewCompany: Neue Firma aus AVS automatisch erstellt; prüfen und ggf. Standardansprechpartner eintragen
AdminProblemSupervisorNewCompany b@Bool: Dieser Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} wechselte zu neuer Firma
AdminProblemNewCompany: Neue Firma über AVS automatisch erstellt; prüfen und ggf. Standardansprechpartner eintragen
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
AdminProblemCompanySuperiorChange: Neuer firmenweiter Vorgesetzer.
AdminProblemCompanySuperiorPrevious: Ehemaliger Vorgesetzer:
AdminProblemNewlyUnsupervised: Fahrer hat keinen Firmenansprechpartner mehr nach AVS Firmenwechsel zu Firma
AdminProblemUser: Betroffener
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
BearerTokenOverrideStartTip: If no start time is given, only the expiration time will be checked when the token is used.
HeadingAdminTokens: Issue tokens
UserUnknown: User unknown
#templates adminfeatures
StudyFeaturesDegrees: Degrees
@ -128,8 +129,10 @@ AdminProblemInfo: Problem
AdminProblemsSolved n: #{pluralENsN n "admin problem"} marked as solved
AdminProblemsReopened n: #{pluralENsN n "admin problem"} reopened
AdminProblemNewCompany: New company from AVS; verify and add default supervisors
AdminProblemSupervisorNewCompany b: 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
AdminProblemCompanySuperiorChange: New company wide superior.
AdminProblemCompanySuperiorPrevious: Previous superior:
AdminProblemNewlyUnsupervised: Driver has no longer a company default supervisor after AVS update at new company
AdminProblemUser: Affected
ProblemTableMarkSolved: Mark done

15
src/Audit/Types.hs
View File

@ -185,7 +185,7 @@ data Transaction
}
| TransactionLmsStart
{ transactionQualification :: QualificationId
, transactionLmsIdent :: LmsIdent
, transactionLmsIdent :: LmsIdent
, transactionLmsUser :: UserId
, transactionLmsUserKey :: LmsUserId
}
@ -216,7 +216,7 @@ data Transaction
| TransactionQualificationUserEdit -- Note that a renewal always entails unblocking as well!
{ transactionUser :: UserId -- qualification holder that is updated
, transactionQualificationUser :: QualificationUserId -- not really necessary, maybe remove?
, transactionQualification :: QualificationId
, transactionQualification :: QualificationId
, transactionQualificationValidUntil :: Day
, transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration)
, transactionNote :: Maybe Text
@ -265,7 +265,7 @@ data AdminProblem
= AdminProblemNewCompany -- new company was noticed, presumably without supervisors
{ adminProblemCompany :: CompanyId
}
| AdminProblemSupervisorNewCompany
| AdminProblemSupervisorNewCompany
{ adminProblemUser :: UserId -- a default supervisor has changed company
, adminProblemCompany :: CompanyId -- old company where the user had default supervisor rights
, adminProblemCompanyNew :: CompanyId -- new company of the user
@ -276,13 +276,18 @@ data AdminProblem
, adminProblemCompany :: CompanyId -- old company
, 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
, adminProblemCompanyOld :: Maybe CompanyId -- old company
, adminProblemCompanyNew :: CompanyId -- new company of the user
}
| AdminProblemUnknown -- miscellanous problem, just displaying text
{ adminProblemText :: Text
{ adminProblemText :: Text
}
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)
-- Handlers
-- Handlers
getAdminR :: Handler Html
getAdminR = redirect AdminProblemsR
@ -63,7 +63,7 @@ getAdminProblemsR, postAdminProblemsR :: Handler Html
getAdminProblemsR = handleAdminProblems Nothing
handleAdminProblems :: Maybe Widget -> Handler Html
handleAdminProblems mbProblemTable = do
handleAdminProblems mbProblemTable = do
now <- liftIO getCurrentTime
let nowaday = utctDay now
cutOffOldDays = 1
@ -75,21 +75,21 @@ handleAdminProblems mbProblemTable = do
msgErrorTooltip <- messageI Error MsgMessageError
let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip
flagWarning = messageTooltip . bool msgWarningTooltip msgSuccessTooltip
flagWarning = messageTooltip . bool msgWarningTooltip msgSuccessTooltip
flagNonZero :: Int -> Widget
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 $ (,,,,,)
<$> areAllUsersReachable
<$> areAllUsersReachable
<*> allDriversHaveAvsId now
<*> allRDriversHaveFs now
<*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <. cutOffOldTime])
<*> (not <$> exists [PrintAcknowledgeProcessed ==. False])
<*> mkInterfaceLogTable flagError mempty
<*> (not <$> exists [PrintAcknowledgeProcessed ==. False])
<*> mkInterfaceLogTable flagError mempty
let interfacesBadNr = length $ filter (not . snd) interfaceOks
-- interfacesOk = all snd interfaceOks
-- interfacesOk = all snd interfaceOks
diffLics <- try retrieveDifferingLicences >>= \case
-- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received"
(Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException)
@ -118,13 +118,13 @@ handleAdminProblems mbProblemTable = do
setTitleI MsgProblemsHeading
$(widgetFile "admin-problems")
postAdminProblemsR = do
(problemLogRes, problemLogTable) <- runDB mkProblemLogTable
postAdminProblemsR = do
(problemLogRes, problemLogTable) <- runDB mkProblemLogTable
formResult problemLogRes procProblems
handleAdminProblems $ Just problemLogTable
where
procProblems :: (ProblemTableActionData, Set ProblemLogId) -> Handler ()
procProblems (ProblemTableMarkSolvedData , pids) = actUpdate True pids
procProblems (ProblemTableMarkSolvedData , pids) = actUpdate True pids
procProblems (ProblemTableMarkUnsolvedData, pids) = actUpdate False pids
actUpdate markdone pids = do
@ -146,7 +146,7 @@ getProblemUnreachableR = do
setTitleI MsgProblemsUnreachableHeading
[whamlet|
<section>
#{length unreachables} _{MsgProblemsUnreachableBody}
#{length unreachables} _{MsgProblemsUnreachableBody}
<ul>
$forall usr <- unreachables
<li>
@ -154,8 +154,8 @@ getProblemUnreachableR = do
|]
getProblemFbutNoR :: Handler Html
getProblemFbutNoR = do
now <- liftIO getCurrentTime
getProblemFbutNoR = do
now <- liftIO getCurrentTime
rnofs <- runDB $ E.select $ retrieveDriversRWithoutF now
siteLayoutMsg MsgProblemsRWithoutFHeading $ do
setTitleI MsgProblemsRWithoutFHeading
@ -169,8 +169,8 @@ getProblemFbutNoR = do
|]
getProblemWithoutAvsId :: Handler Html
getProblemWithoutAvsId = do
now <- liftIO getCurrentTime
getProblemWithoutAvsId = do
now <- liftIO getCurrentTime
rnofs <- runDB $ E.select $ retrieveDriversWithoutAvsId now
siteLayoutMsg MsgProblemsNoAvsIdHeading $ do
setTitleI MsgProblemsNoAvsIdHeading
@ -185,40 +185,40 @@ getProblemWithoutAvsId = do
{-
mkUnreachableUsersTable = do
let dbtSQLQuery user -> do
let dbtSQLQuery user -> do
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
dbtRowKey = (E.^. UserId)
dbtProj = dbtProjId
dbtColonnade =
dbtColonnade =
-}
areAllUsersReachable :: DB Bool
-- areAllUsersReachable = isNothing <$> E.selectOne retrieveUnreachableUsers'
-- areAllUsersReachable = E.selectNotExists retrieveUnreachableUsers'
areAllUsersReachable = null <$> retrieveUnreachableUsers
-- retrieveUnreachableUsers' :: E.SqlQuery (E.SqlExpr (Entity User))
-- retrieveUnreachableUsers' = do
-- retrieveUnreachableUsers' = do
-- user <- E.from $ E.table @User
-- E.where_ $ E.isNothing (user E.^. UserPostAddress)
-- 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.^. UserEmail) `E.like` E.val "%@%.%")
-- return user
-- return user
retrieveUnreachableUsers :: DB [Entity User]
retrieveUnreachableUsers = do
emailOnlyUsers <- E.select $ do
retrieveUnreachableUsers = do
emailOnlyUsers <- E.select $ do
user <- E.from $ E.table @User
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
filterM hasInvalidEmail emailOnlyUsers
where
filterM hasInvalidEmail emailOnlyUsers
where
hasInvalidEmail = fmap isNothing . getUserEmail
allDriversHaveAvsId :: UTCTime -> DB Bool
-- 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
retrieveDriversWithoutAvsId' :: Day -> E.SqlQuery (E.SqlExpr (Entity User))
retrieveDriversWithoutAvsId' nowaday = do
retrieveDriversWithoutAvsId' nowaday = do
(usr :& qualUsr :& qual) <- E.from $ E.table @User
`E.innerJoin` E.table @QualificationUser
`E.on` (\(usr :& qualUsr) -> usr E.^. UserId E.==. qualUsr E.^. QualificationUserUser)
`E.innerJoin` E.table @Qualification
`E.on` (\(_usr :& qualUsr :& qual) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification)
`E.innerJoin` E.table @Qualification
`E.on` (\(_usr :& qualUsr :& qual) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification)
E.where_ $ -- is avs licence
E.isJust (qual E.^. QualificationAvsLicence)
E.&&. (qualUsr & validQualification nowaday)
E.&&. -- AvsId is unknown
E.notExists (do
E.notExists (do
avsUsr <- E.from $ E.table @UserAvs
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
retrieveDriversWithoutAvsId :: UTCTime -> E.SqlQuery (E.SqlExpr (Entity User))
retrieveDriversWithoutAvsId now = do
retrieveDriversWithoutAvsId now = do
usr <- E.from $ E.table @User
E.where_ $
E.exists (do -- a valid avs licence
(qual :& qualUsr) <- E.from (E.table @Qualification
E.where_ $
E.exists (do -- a valid avs licence
(qual :& qualUsr) <- E.from (E.table @Qualification
`E.innerJoin` E.table @QualificationUser
`E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification))
E.where_ $ -- is avs licence
E.isJust (qual E.^. QualificationAvsLicence)
E.&&. (qualUsr & validQualification now) -- currently valid
E.&&. -- matches user
E.&&. -- matches user
(qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId)
)
E.&&.
E.&&.
E.notExists (do -- a known AvsId
avsUsr <- E.from $ E.table @UserAvs
E.where_ $ avsUsr E.^. UserAvsUser E.==. usr E.^. UserId
@ -268,20 +268,20 @@ retrieveDriversWithoutAvsId now = do
allRDriversHaveFs :: UTCTime -> DB Bool
-- allRDriversHaveFs = fmap isNothing . E.selectOne . retrieveDriversRWithoutF
allRDriversHaveFs = E.selectNotExists . retrieveDriversRWithoutF
-- allRDriversHaveFs = fmap isNothing . E.selectOne . retrieveDriversRWithoutF
allRDriversHaveFs = E.selectNotExists . retrieveDriversRWithoutF
-- | 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 now = do
retrieveDriversRWithoutF now = do
usr <- E.from $ E.table @User
let hasValidQual lic = do
(qual :& qualUsr) <- E.from (E.table @Qualification
(qual :& qualUsr) <- E.from (E.table @Qualification
`E.innerJoin` E.table @QualificationUser
`E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification))
E.where_ $ (qual E.^. QualificationAvsLicence E.==. E.justVal lic) -- matches licence
E.&&. (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId) -- matches user
E.&&. (qualUsr & validQualification now) -- currently valid
E.where_ $ (qual E.^. QualificationAvsLicence E.==. E.justVal lic) -- matches licence
E.&&. (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId) -- matches user
E.&&. (qualUsr & validQualification now) -- currently valid
E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld)
E.&&. E.notExists (hasValidQual AvsLicenceVorfeld)
return usr
@ -375,28 +375,5 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
return (act, usrSet)
-- adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a
-- -- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns
-- 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]
-- adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a -- moved to Handler.Utils
-- msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX) -- moved to Handler.Utils

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
reloadKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
reloadKeepGetParams r = liftHandler $ do
reloadKeepGetParams r = liftHandler $ do
getps <- reqGetParams <$> getRequest
route <- fromMaybe r <$> getCurrentRoute
-- addMessage Info $ toHtml (show getps) -- DEBUG ONLY
-- 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
redirectKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
redirectKeepGetParams route = liftHandler $ do
getps <- reqGetParams <$> getRequest
redirect (route, getps)
redirectKeepGetParams route = liftHandler $ do
getps <- reqGetParams <$> getRequest
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
adminProblemCell AdminProblemNewCompany{}
adminProblemCell AdminProblemNewCompany{}
= i18nCell MsgAdminProblemNewCompany
adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute}
adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute}
= i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew
adminProblemCell AdminProblemSupervisorLeftCompany{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
adminProblemCell AdminProblemUnknown{adminProblemText}
adminProblemCell AdminProblemUnknown{adminProblemText}
= textCell $ "Problem: " <> adminProblemText
company2msg :: CompanyId -> SomeMessage UniWorX
company2msg = text2message . ciOriginal . unCompanyKey
msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX)
msgAdminProblem AdminProblemNewCompany{adminProblemCompany=comp} = return $
msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX)
msgAdminProblem AdminProblemNewCompany{adminProblemCompany=comp} = return $
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]
msgAdminProblem AdminProblemSupervisorLeftCompany{adminProblemCompany=comp, adminProblemSupervisorReroute=rer} = return $
msgAdminProblem AdminProblemSupervisorLeftCompany{adminProblemCompany=comp, adminProblemSupervisorReroute=rer} = return $
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]
msgAdminProblem AdminProblemUnknown{adminProblemText=err} = return $
someMessages ["Problem: ", err]
someMessages ["Problem: ", err]
updateAutomatic :: Bool -> Widget
-- updateAutomatic = iconTooltip [whamlet|_{MsgNoAutomaticUpdateTip}|] (Just IconLocked)
@ -198,4 +204,3 @@ updateAutomatic True = mempty
updateAutomatic False = do
msg <- messageIconI Warning IconLocked MsgNoAutomaticUpdateTip
messageTooltip msg

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

@ -14,7 +14,7 @@ module Handler.Utils.Avs
, upsertAvsUserById
, updateAvsUserByIds
, linktoAvsUserByUIDs
, queueAvsUpdateByUID, queueAvsUpdateByAID
, queueAvsUpdateByUID, queueAvsUpdateByAID
-- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
, AvsLicenceDifferences(..)
, setLicence, setLicenceAvs, setLicencesAvs
@ -26,9 +26,9 @@ module Handler.Utils.Avs
, AvsException(..)
, updateReceivers
, AvsPersonIdMapPersonCard
-- CR3
-- CR3
, SomeAvsQuery(..)
, queryAvsCardNo, queryAvsCardNos
, queryAvsCardNo, queryAvsCardNos
) where
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 allEx toLog toMsg dft act = act `catches` (avsHandlers <> allHandlers)
where
avsHandlers =
[ Catch.Handler (\(exc::AvsException) -> liftHandler $ do
avsHandlers =
[ Catch.Handler (\(exc::AvsException) -> liftHandler $ do
let txt = "AVS exception ignored: " <> tshow exc
when toLog $ $logErrorS "AVS" txt
when toMsg $ addMessageI Warning exc
return dft
)
, Catch.Handler (\(exc::ClientError ) -> liftHandler $ do
let txt = "AVS fatal communicaton failure: " <> tshow exc
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
queryAvsFullStatus :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => AvsPersonId -> m AvsResponseStatus
queryAvsFullStatus api =
lookupAvsUser api <&> \case
Just AvsDataPerson{avsPersonPersonCards=cards}
lookupAvsUser api <&> \case
Just AvsDataPerson{avsPersonPersonCards=cards}
| notNull cards -> AvsResponseStatus $ Set.singleton $ AvsStatusPerson api cards
_otherwise -> AvsResponseStatus mempty
@ -158,7 +158,7 @@ lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api)
-- Does not write to our own DB!
lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
Set AvsPersonId -> m (Map AvsPersonId AvsDataPerson)
lookupAvsUsers apis = do
lookupAvsUsers apis = do
AvsResponseStatus statuses <- avsQuery $ AvsQueryStatus apis
let forFoldlM = $(permuteFun [3,2,1]) foldlM
forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} ->
@ -171,15 +171,15 @@ lookupAvsUsers apis = do
updateReceivers :: UserId -> Handler (Entity User, [Entity User], Bool)
updateReceivers uid = do
-- 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
Nothing -> return ()
Nothing -> return ()
-- Retrieve updated user and supervisors now
(underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDB $ (,)
<$> getJustEntity uid
<$> getJustEntity uid
<*> (E.select $ do
(usrSuper :& usrAvs) <-
E.from $ E.table @UserSupervisor
E.from $ E.table @UserSupervisor
`E.leftJoin` E.table @UserAvs
`E.on` (\(usrSuper :& userAvs) -> usrSuper E.^. UserSupervisorSupervisor E.=?. userAvs E.?. UserAvsUser)
E.where_ $ (usrSuper E.^. UserSupervisorUser E.==. E.val uid)
@ -187,13 +187,13 @@ updateReceivers uid = do
pure (usrSuper E.^. UserSupervisorSupervisor, usrAvs E.?. UserAvsPersonId)
)
let (superVs, avsIds) = unzip avsSupers
receiverIDs :: [UserId] = E.unValue <$> superVs
receiverIDs :: [UserId] = E.unValue <$> superVs
toUpdate = Set.fromList $ mapMaybe E.unValue avsIds
directResult = return (underling, pure underling, True) -- already contains updated address
forM_ toUpdate (catchAll2log . upsertAvsUserById) -- attempt to update postaddress from AVS
if null receiverIDs
if null receiverIDs
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
if null receivers
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
class SomeAvsQuery q where
type SomeAvsResponse q :: Type
class SomeAvsQuery q where
type SomeAvsResponse q :: Type
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
avsQuery :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
@ -217,13 +217,13 @@ class SomeAvsQuery q where
avsQueryNoCacheDefault :: (SomeAvsQuery 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)
throwLeftM $ qfun qry
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)
avsQueryCached qry =
avsQueryCached qry =
getsYesod (preview $ _appAvsConf . _Just . _avsCacheExpiry) >>= \case
Just t | t > 1 -> memcachedBy (Just $ Right t) qry $ avsQueryNoCache qry
_ -> avsQueryNoCache qry
@ -232,7 +232,7 @@ instance SomeAvsQuery AvsQueryPerson where
type SomeAvsResponse AvsQueryPerson = AvsResponsePerson
pickQuery = avsQueryPerson
avsQuery = avsQueryCached
instance SomeAvsQuery AvsQueryStatus where
type SomeAvsResponse AvsQueryStatus = AvsResponseStatus
pickQuery = avsQueryStatus
@ -246,24 +246,24 @@ instance SomeAvsQuery AvsQueryContact where
instance SomeAvsQuery AvsQuerySetLicences where
type SomeAvsResponse AvsQuerySetLicences = AvsResponseSetLicences
pickQuery = avsQuerySetLicences
-- NOTE: avsQuery = avsQueryCached -- should not and indeed does not compile
avsQueryNoCache qry = avsQueryNoCacheDefault qry
-- NOTE: avsQuery = avsQueryCached -- should not and indeed does not compile
avsQueryNoCache qry = avsQueryNoCacheDefault qry
<* memcachedInvalidate (Proxy @AvsResponseContact) -- invalidate all AvsResponseContact which may contain RampLicence info, since keys may comprise several ids
instance SomeAvsQuery AvsQueryGetAllLicences where
type SomeAvsResponse AvsQueryGetAllLicences = AvsResponseGetLicences
pickQuery = const . avsQueryGetAllLicences
queryAvsCardNos :: Foldable t => t (Either AvsCardNo AvsFullCardNo) -> Handler (Set AvsPersonId)
queryAvsCardNos = foldMapM queryAvsCardNo
queryAvsCardNo :: Either AvsCardNo AvsFullCardNo -> Handler (Set AvsPersonId)
queryAvsCardNo crd = do
queryAvsCardNo crd = do
AvsResponsePerson adps <- avsQuery $ qry crd
return $ Set.map avsPersonPersonID adps
where
where
qry (Left acno) = def{ avsPersonQueryCardNo = Just acno }
qry (Right AvsFullCardNo{..}) = def{ avsPersonQueryCardNo = Just avsFullCardNo
, avsPersonQueryVersionNo = Just avsFullCardVersion
@ -271,7 +271,7 @@ queryAvsCardNo crd = do
-- | Queries AVS Status to retrieve primary card (heursitic)
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
pstatus <- hoistMaybe $ Set.lookupMax $ Set.filter ((api ==) . avsStatusPersonID) res
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
updateAvsUserById :: AvsPersonId -> DB (Maybe UserId)
updateAvsUserById apid = do
updateAvsUserById apid = do
AvsResponseContact adcs <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId apid
let res = Set.filter ((== apid) . avsContactPersonID) adcs
snd <<$>> traverseJoin updateAvsUserByADC (Set.lookupMax res)
@ -306,10 +306,10 @@ updateAvsUserByIds' apids = do
now <- liftIO getCurrentTime
runDB $ updateWhere [UserAvsPersonId <-. missing] [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just "Avs contact info unknown for AvsPersonId"] -- all others were already marked as updated
return oks
where
where
procResp :: (Set (AvsPersonId, UserId), Set AvsPersonId) -> AvsDataContact -> Handler (Set (AvsPersonId, UserId), Set AvsPersonId)
procResp (accOk, accBad) adc = do
let errHandler e = runDB $ do
let errHandler e = runDB $ do
let apid = avsContactPersonID adc
now <- liftIO getCurrentTime
updateBy (UniqueUserAvsId apid) [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just (tshow e)]
@ -319,19 +319,19 @@ updateAvsUserByIds' apids = do
res <- updateAvsUserByADC adc
return (maybeInsert res accOk, accBad)
catchAll (runDB updateAvsUserByADC') errHandler
updateAvsUserByADC :: AvsDataContact -> DB (Maybe (AvsPersonId, UserId))
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
usr <- MaybeT $ get usrId
lift $ do -- maybeT no longer needed from here onwards
let oldAvsPersonInfo = userAvsLastPersonInfo usravs -- Nothing is ok here
oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing is ok here
oldAvsCardNo = userAvsLastCardNo usravs & fmap Just
oldAvsDataContact = case (oldAvsPersonInfo, oldAvsFirmInfo) of
oldAvsDataContact = case (oldAvsPersonInfo, oldAvsFirmInfo) of
(Just oapi, Just oafi) -> Just $ AvsDataContact apid oapi oafi
_ -> Nothing
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
ldap_ups <- if | Just ldapExpire <- mbLdapExpire
, maybe True (\lastLdapSync -> now > addUTCTime ldapExpire lastLdapSync) (userLastLdapSynchronisation usr)
, Just udep <- userCompanyDepartment usr
, Just udep <- userCompanyDepartment usr
, let aipn = newAvsPersonInfo ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
depKey = CompanyKey $ stripCI udep -- Shorthand is returned by LDAP
-> do -- LDAP sync invalid/expired
-> do -- LDAP sync invalid/expired
usrComp <- getBy $ UniqueUserCompany usrId depKey
whenIsJust usrComp $ \Entity{entityKey=ucKey, entityVal=UserCompany{userCompanySupervisor=isSuper, userCompanySupervisorReroute=rroute}} -> do
delete ucKey
@ -358,7 +358,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
[mkCheckUpdate CU_API_UserCompanyPersonalNumber]
let per_ups = mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo . mkCheckUpdate)
[ CU_API_UserFirstName
, CU_API_UserSurname
, CU_API_UserSurname
, CU_API_UserDisplayName
, CU_API_UserBirthday
, CU_API_UserMobile
@ -377,17 +377,17 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
, UserAvsLastFirmInfo =. Just newAvsFirmInfo
, UserAvsLastCardNo =. newAvsCardNo
]
-- update company association & supervision
Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo
primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId
let oldCompanyId = entityKey <$> oldCompanyEnt
-- oldCompanyMb = entityVal <$> oldCompanyEnt
-- pst_up = if
-- pst_up = if
-- -- | 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)
-- | isNothing oldCompanyMb
-- | isNothing oldCompanyMb
-- -> 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
-- -> mkUpdate usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference
@ -395,38 +395,37 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
-- -> Nothing
superReasonComDef = tshow SupervisorReasonCompanyDefault
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
-> 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
|| isJust (view _avsFirmPrimaryEmail oafi)
&& ((==) `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
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 $ updateWhere [ UserSupervisorSupervisor ==. usrId -- update company-related supervisions
, UserSupervisorCompany ==. Just ocid -- to new company, regardless of
, UserSupervisorReason ==. Just superReasonComDef] -- user
, UserSupervisorCompany ==. Just ocid -- to new company, regardless of
, UserSupervisorReason ==. Just superReasonComDef] -- user
[ UserSupervisorCompany =. Just newCompanyId]
return mempty
_ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company
-> do
whenIsJust oldCompanyId $ \oldCid -> do
whenIsJust oldCompanyId $ \oldCid -> do
deleteBy $ UniqueUserCompany usrId oldCid
deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef)
return mempty
_ -- company changed completely
-> do
_ -- company changed completely
-> do
(pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId
mapM_ reportAdminProblem problems
-- 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 pst_up
-- 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
-- SPECIALISED CODE, PROBABLY DEPRECATED
-- switch user company, keeping old priority
-- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case
@ -443,8 +442,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
-- addCompanySupervisors newCompanyId usrId
-- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
-- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
-- return pst_up
repsertSuperiorSupervisor (Just newCompanyId) newAvsFirmInfo usrId -- ensure firmInfo superior is supervisor, must be executed after updating company default supervisors
-- return pst_up
update usrId $ usr_up2 <> usr_up1 -- update user eventually
update uaId avs_ups -- update stored avsinfo for future updates
return (apid, usrId)
@ -452,7 +450,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
linktoAvsUserByUIDs :: Set UserId -> Handler ()
linktoAvsUserByUIDs uids = do
ips <- runDB $ E.select $ do
ips <- runDB $ E.select $ do
usr <- E.from $ E.table @User
let uid = usr E.^. UserId
ipn = usr E.^. UserCompanyPersonalNumber
@ -463,8 +461,8 @@ linktoAvsUserByUIDs uids = do
E.where_ $ uid E.==. usrAvs E.^. UserAvsUser
)
return (uid, ipn)
mapM_ procUsr ips
where
mapM_ procUsr ips
where
procUsr (E.Value uid, E.Value (Just ipn)) = catchAll2log $ linktoAvsUserByUID uid $ mkAvsInternalPersonalNo ipn
procUsr _ = return ()
@ -481,7 +479,7 @@ linktoAvsUserByUID uid aipn = do
-- 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
createAvsUserById :: Maybe UserId -> AvsPersonId -> Handler UserId
createAvsUserById muid api = do
createAvsUserById muid api = do
AvsResponseContact contactRes <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId api
case Set.toList contactRes of
[] -> throwM $ AvsUserUnknownByAvs api
@ -491,14 +489,14 @@ createAvsUserById muid api = do
| otherwise -> do
-- check for matching existing user
let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
oldUsr <- runDB $ do
persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
oldUsr <- runDB $ do
mbUid <- if isJust muid
then return muid
else firstJustM $ catMaybes
[ internalPersNo <&> (\ipn -> getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn]) -- must ensure filter isnt ==. Nothing
, persMail <&> guessUserByEmail
]
]
mbUAvs <- (getBy . UniqueUserAvsUser) `traverseJoin` mbUid
return (mbUid, mbUAvs)
usrCardNo <- queryAvsFullCardNo api
@ -512,11 +510,11 @@ createAvsUserById muid api = do
, userAvsLastPersonInfo = mbPersonInfo
, userAvsLastFirmInfo = mbFirmInfo
, userAvsLastCardNo = mbUsrCardNo
}
case oldUsr of
}
case oldUsr of
(Nothing , Just _) -> throwM $ AvsUserUnknownByAvs api -- this case should never occur
(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
| otherwise -> return uid -- nothing to do
(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
case updRes of
Nothing -> throwM $ AvsUserUnknownByAvs api
Just uid'
Just uid'
| uid /= uid' -> throwM $ AvsUserAmbiguous api
| otherwise -> return uid
(Nothing, Nothing) -> do -- create fresh user
Entity{entityKey=cid, entityVal=cmp} <- runDB $ upsertAvsCompany firmInfo Nothing -- individual runDB, since no need to rollback
let pinPass = avsFullCardNo2pin <$> usrCardNo
newUserData = AddUserData
{ audTitle = Nothing
{ audTitle = Nothing
, audFirstName = cpi ^. _avsInfoFirstName & Text.strip
, audSurname = cpi ^. _avsInfoLastName & Text.strip
, audDisplayName = cpi ^. _avsInfoDisplayName
, audDisplayName = cpi ^. _avsInfoDisplayName
, audDisplayEmail = persMail & fromMaybe mempty
, audEmail = persMail & fromMaybe ("AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI)
, audIdent = persMail & fromMaybe ("AVSID:" <> ciShow api )
@ -542,74 +540,23 @@ createAvsUserById muid api = do
, audMatriculation = cpi ^. _avsInfoPersonNo & Just . tshow
, audSex = Nothing
, audBirthday = cpi ^. _avsInfoDateOfBirth
, audMobile = cpi ^. _avsInfoPersonMobilePhoneNo
, audMobile = cpi ^. _avsInfoPersonMobilePhoneNo
, audTelephone = Nothing
, audFPersonalNumber = internalPersNo
, audFDepartment = toMaybe (isJust internalPersNo) (cmp ^. _companyShorthand . _CI)
, audFDepartment = toMaybe (isJust internalPersNo) (cmp ^. _companyShorthand . _CI)
, audPostAddress = Nothing -- always use company address indirectly
, audPrefersPostal = cmp ^. _companyPrefersPostal
, audPinPassword = pinPass
}
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
void $ insertUnique userComp -- Nothing indicates that the user is already linked to the company (which is unlikely here)
-- Supervision
addCompanySupervisors cid uid
repsertSuperiorSupervisor (Just cid) firmInfo uid
-- 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
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)
@ -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
getAvsCompany :: AvsFirmInfo -> DB (Maybe (Entity Company))
getAvsCompany afi =
getAvsCompany afi =
let compName :: CompanyName
compName = afi ^. _avsFirmFirm . from _CI
compShorthand :: CompanyShorthand
@ -625,11 +572,11 @@ getAvsCompany afi =
compAvsId = afi ^. _avsFirmFirmNo
in firstJustM $ -- legacy treatment, only use UniqueCompnayAvsId in the future
guardMonoid (compAvsId > 0)
[ getBy $ UniqueCompanyAvsId compAvsId
[ getBy $ UniqueCompanyAvsId compAvsId
, getEntity $ CompanyKey $ compShorthand <> "-" <> ciShow compAvsId
] <>
[ 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
@ -637,7 +584,7 @@ upsertAvsCompany :: AvsFirmInfo -> Maybe AvsFirmInfo -> DB (Entity Company)
upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
mbFirmEnt <- getAvsCompany newAvsFirmInfo -- primarily by AvsId, then Shorthand, then name
$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
afn <- if 0 < newAvsFirmInfo ^. _avsFirmFirmNo
then return $ newAvsFirmInfo ^. _avsFirmFirmNo
@ -653,19 +600,19 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
}
cmp = foldl' upd dmy $ firmInfo2key : firmInfo2companyNo : firmInfo2company
$logInfoS "AVS" $ "Insert new company: " <> tshow cmp
newCmp <- insertEntity cmp
newCmp <- insertEntity cmp
reportAdminProblem $ AdminProblemNewCompany $ entityKey newCmp
$logInfoS "AVS" "Insert new company completed."
return newCmp
(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
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}|]
res_cmp <- updateGetEntity firmid $ mcons uniq_ups cmp_ups
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
$logInfoS "AVS" $ "Updating CompanyShorthand from " <> ciOriginal (companyShorthand firm) <> " to " <> avsFirmAbbreviation newAvsFirmInfo <> " for AvsNo " <> tshow 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
| alt_ok -> updateBy uniq_cmp [CompanyShorthand =. 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
$logInfoS "AVS" "Update company completed."
return res_cmp2
void $ upsertCompanySuperior (Just $ entityKey cmpEnt, newAvsFirmInfo) mbOldAvsFirmInfo -- ensure firmInfo superior is supervisor
return cmpEnt
where
firmInfo2key =
firmInfo2key =
CheckUpdate CompanyShorthand $ _avsFirmAbbreviation . from _CI -- Updating primary key works in principle thanks to OnUpdateCascade, but fails due to update get
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
firmInfo2company =
[ CheckUpdate CompanyName $ _avsFirmFirm . from _CI
firmInfo2company =
[ CheckUpdate CompanyName $ _avsFirmFirm . from _CI
, CheckUpdate CompanyPostAddress _avsFirmPostAddress
, 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
]
-- 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 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 t -> (t -> E.SqlExpr (E.Value UserId)) -> (t -> E.SqlExpr (E.Value Bool)) -> Maybe Day -> DB Int64
queueAvsUpdateAux tbl prj fltr pause = do
now <- liftIO getCurrentTime
queueAvsUpdateAux tbl prj fltr pause = do
now <- liftIO getCurrentTime
n <- E.insertSelectWithConflictCount UniqueAvsSyncUser
( do
usr <- E.from tbl
E.where_ $ fltr usr
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)
, AvsSyncPause E.=. E.greatest (current E.^. AvsSyncPause) (excluded E.^. AvsSyncPause)
]
@ -717,24 +729,24 @@ queueAvsUpdateAux tbl prj fltr pause = do
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
-- If an existing User with internal number is found, an AVS update query is executed
guessAvsUser :: Text -> Handler (Maybe UserId)
guessAvsUser (Text.splitAt 6 -> (Text.toUpper -> prefix, readMay -> Just nr))
| prefix=="AVSID:" =
let avsid = AvsPersonId nr in
| prefix=="AVSID:" =
let avsid = AvsPersonId nr in
runDB (getBy $ UniqueUserAvsId avsid) >>= \case
(Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> return $ Just uid
Nothing -> catchAVS2message $ Just <$> upsertAvsUserById avsid
| prefix=="AVSNO:" =
Nothing -> catchAVS2message $ Just <$> upsertAvsUserById avsid
| prefix=="AVSNO:" =
runDB (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr])
guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) =
guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) =
catchAVS2message $ upsertAvsUserByCard someavsid >>= \case
Nothing | Left{} <- someavsid -> -- attempt to find PersonalNumber in DB
runDB (getKeyByFilter [UserCompanyPersonalNumber ==. Just someid])
other -> return other
guessAvsUser someid = do
guessAvsUser someid = do
try (runDB $ ldapLookupAndUpsert someid) >>= \case
Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> do -- ensure internal user is linked to avs, if possible
let ldapUid = Just uid
@ -743,8 +755,8 @@ guessAvsUser someid = do
return ldapUid
Right Entity{entityKey=uid} -> return $ Just uid
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
runDB . runMaybeT $
whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all
runDB . runMaybeT $
MaybeT (guessUserByEmail $ stripCI someid) -- recall that monadic actions are only executed until first success here
<|> MaybeT (getKeyByFilter [UserDisplayName ==. someid])
@ -756,8 +768,8 @@ upsertAvsUserByCard persNo = do
let qry = case persNo of
Left fpn
-> def{ avsPersonQueryInternalPersonalNo = Just fpn } -- recall: default has all fields set to nothing
Right AvsFullCardNo{..}
-> def{ avsPersonQueryCardNo = Just avsFullCardNo, avsPersonQueryVersionNo = Just avsFullCardVersion }
Right AvsFullCardNo{..}
-> 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!
AvsResponsePerson adps <- avsQuery qry
case Set.elems adps of
@ -780,11 +792,11 @@ setLicence :: (PersistUniqueRead backend, MonadThrow m,
MonadHandler m, HandlerSite m ~ UniWorX,
BaseBackend backend ~ SqlBackend) =>
UserId -> AvsLicence -> ReaderT backend m Bool
setLicence uid lic =
setLicence uid lic =
getBy (UniqueUserAvsUser uid) >>= \case
Just Entity{entityVal=UserAvs{userAvsPersonId=api}} -> setLicenceAvs api lic
Nothing -> do
uname <- userDisplayName <<$>> get uid
uname <- userDisplayName <<$>> get uid
throwM $ AvsUserUnassociated $ fromMaybe "user id unknown" uname
setLicenceAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
@ -797,7 +809,7 @@ setLicenceAvs apid lic = do
--setLicencesAvs :: Set AvsPersonLicence -> Handler Bool
setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
Set AvsPersonLicence -> m Int
setLicencesAvs = aux 0
setLicencesAvs = aux 0
where
aux batch0_ok pls
| 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
batch1_ok = Set.size ok
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?)
{- NOT USED ANYWHERE:
@ -846,13 +858,13 @@ data AvsLicenceDifferences = AvsLicenceDifferences
#ifndef DEVELOPMENT
-- avsLicenceDifferences2LicenceIds is not used in DEVELOPMENT build
avsLicenceDifferences2LicenceIds :: AvsLicenceDifferences -> Set AvsPersonId
avsLicenceDifferences2LicenceIds AvsLicenceDifferences{..} = Set.unions
[ avsLicenceDiffRevokeAll
, avsLicenceDiffGrantVorfeld
avsLicenceDifferences2LicenceIds AvsLicenceDifferences{..} = Set.unions
[ avsLicenceDiffRevokeAll
, avsLicenceDiffGrantVorfeld
, avsLicenceDiffRevokeRollfeld
, avsLicenceDiffGrantRollfeld
, avsLicenceDiffGrantRollfeld
]
#endif
#endif
avsLicenceDifferences2personLicences :: AvsLicenceDifferences -> Set AvsPersonLicence
avsLicenceDifferences2personLicences AvsLicenceDifferences{..} =
@ -876,7 +888,7 @@ retrieveDifferingLicencesStatus :: Handler (AvsLicenceDifferences, AvsPersonIdMa
retrieveDifferingLicencesStatus = retrieveDifferingLicences' True
retrieveDifferingLicences' :: Bool -> Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard)
retrieveDifferingLicences' getStatus = do
retrieveDifferingLicences' getStatus = do
#ifdef DEVELOPMENT
avsUsrs <- runDB $ selectList [] [LimitTo 444]
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 4 -- AVS:1 FD:1
] ++ [AvsPersonLicence AvsLicenceVorfeld avsid | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs]
#else
#else
allLicences <- avsQuery AvsQueryGetAllLicences
#endif
lDiff <- getDifferingLicences allLicences
lDiff <- getDifferingLicences allLicences
#ifdef DEVELOPMENT
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
fakes = Set.fromList $
fakes = Set.fromList $
[ 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 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 avsid $ Set.singleton $ mkAdpc (even $ avsPersonId avsid) AvsCardColorGelb | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs ]
#else
let statQry = avsLicenceDifferences2LicenceIds lDiff
lStat <- if getStatus && notNull statQry
lStat <- if getStatus && notNull statQry
then avsQueryNoCache (AvsQueryStatus statQry)
-- `catch` handler
-- let handler _exception = do
-- 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
#endif
return (lDiff, avsResponseStatusMap lStat)
getDifferingLicences :: AvsResponseGetLicences -> Handler AvsLicenceDifferences
getDifferingLicences (AvsResponseGetLicences licences) = do
now <- liftIO getCurrentTime
@ -934,7 +946,7 @@ getDifferingLicences (AvsResponseGetLicences licences) = do
(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!
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.on` (\(_ :& qualUser :& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser)
@ -953,16 +965,16 @@ getDifferingLicences (AvsResponseGetLicences licences) = do
((vorfGrant, vorfRevoke), (rollGrant, rollRevoke)) <- runDB $ (,)
<$> antijoinAvsLicences AvsLicenceVorfeld vorORrollfeld
<*> antijoinAvsLicences AvsLicenceRollfeld rollfeld
let setTo0 = vorfRevoke -- revoke driving licences
let setTo0 = vorfRevoke -- revoke driving licences
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
return AvsLicenceDifferences
{ avsLicenceDiffRevokeAll = setTo0
, avsLicenceDiffGrantVorfeld = setTo1up
, avsLicenceDiffRevokeRollfeld = setTo1down
, avsLicenceDiffGrantRollfeld = setTo2
}
}
{- 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
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 = \uid -> do
companies <- E.select $ do
companies <- E.select $ do
(usrComp :& comp) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @Company
`E.on` (\(usrComp :& comp) -> usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId)
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
E.orderBy [E.asc (comp E.^. CompanyName)]
return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor, usrComp E.^. UserCompanyPriority)
let (mPri, topCmp, otherCmp) = procCmp mPri companies
resWgt =
resWgt =
[whamlet|
$forall c <- topCmp
<p>
@ -43,7 +43,7 @@ wgtCompanies = \uid -> do
#{c}
|]
return $ toMaybe (notNull topCmp) resWgt
where
where
procCmp _ [] = (0, [],[])
procCmp maxPri ((E.Value cmpSh, E.Value cmpName, E.Value cmpSpr, E.Value cmpPrio) : cs) =
let cmpWgt = companyWidget (cmpSh, cmpName, cmpSpr)
@ -53,15 +53,22 @@ wgtCompanies = \uid -> do
-- TODO: use this function in company view Handler.Firm #157
-- | 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 ()
addCompanySupervisors cid uid =
addCompanySupervisors cid uid =
E.insertSelectWithConflict
UniqueUserSupervisor
( do
( do
userCompany <- E.from $ E.table @UserCompany
E.where_ $ userCompany E.^. UserCompanyCompany E.==. E.val cid
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
E.<# (userCompany E.^. UserCompanyUser)
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
[ 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 ]
]
]
)
@ -80,7 +87,7 @@ addCompanySupervisors cid uid =
switchAvsUserCompany :: Bool -> Bool -> UserId -> CompanyId -> DB ([Update User], [AdminProblem])
switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = do
usrRec <- get404 uid
newCompany <- get404 newCompanyId
newCompany <- get404 newCompanyId
mbUsrComp <- getUserPrimaryCompany uid
mbOldComp <- (get . userCompanyCompany) `traverseJoin` mbUsrComp
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))
(UserPostAddress =. Nothing) -- use company address indirectly instead
usrPrefPost = userPrefersPostal usrRec
usrPrefPostUp = toMaybe (Just usrPrefPost == (mbOldComp ^? _Just . _companyPrefersPostal))
usrPrefPostUp = toMaybe (Just usrPrefPost == (mbOldComp ^? _Just . _companyPrefersPostal))
(UserPrefersPostal =. companyPrefersPostal newCompany)
usrEmail :: UserEmail = userDisplayEmail usrRec
avsEmail :: Maybe UserEmail = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPrimaryEmail . _Just . from _CI
usrEmailUp = toMaybe (usrPostEmailUpds && avsEmail == Just usrEmail) (UserDisplayEmail =. "")
usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrEmailUp]
-- [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
case mbUsrComp of
Nothing -> do -- create company user
@ -105,10 +112,10 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
return (usrUpdate, mempty)
Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute}
| newCompanyId == oldCompanyId -> return mempty -- nothing to do
| otherwise -> do -- switch company
| otherwise -> do -- switch company
void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp
[UserCompanyPriority =. succ oldPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True]
-- supervised by uid
-- supervised by uid
supervisees :: [(Entity UserSupervisor, E.Value Bool)] <- E.select $ do
usrSup <- E.from $ E.table @UserSupervisor
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
E.where_ $ usrSup E.^. UserSupervisorUser E.==. othSup E.^. UserSupervisorUser
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)
newlyUnsupervised <- guardMonoidM (notNull supervisees) $ do
E.delete $ do
E.delete $ do
usrSup <- E.from $ E.table @UserSupervisor
E.where_ $ usrSup E.^. UserSupervisorId `E.in_` E.vals (fmap (entityKey . fst) supervisees)
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
let superDeftFltr = (UserSupervisorUser ==. uid) : (UserSupervisorReason ~=. superReasonComDef)
oldSubFltr = (UserSupervisorCompany ~=. oldCompanyId) <> superDeftFltr
@ -139,6 +146,6 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
$ bcons isNoLongerSupervised (AdminProblemNewlyUnsupervised uid (Just oldCompanyId) newCompanyId)
newlyUnsupervised
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
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 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 lnk (Entity uid usr) = do
linkUserWidget lnk (Entity uid usr) = do
uuid <- encrypt uid
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 x = nameEmailWidget (x ^. _userDisplayEmail) (x ^. _userDisplayName) (x ^. _userSurname)
@ -139,7 +146,7 @@ companyWidget (csh, cname, isSupervisor) = simpleLink (toWgt name) curl
where
curl = FirmUsersR csh
corg = ciOriginal cname
name
name
| isSupervisor = text2markup (corg <> " ") <> icon IconSupervisor
| 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
jsonWidget :: ToJSON a => a -> Widget
jsonWidget x = jsonWidgetAux $ toJSON x
where
where
jsonWidgetAux :: Value -> Widget
jsonWidgetAux Null = [whamlet|Null|]
jsonWidgetAux (Bool b) = toWidget $ boolSymbol b
jsonWidgetAux (String s) = [whamlet|#{s}|]
jsonWidgetAux (Number n)
jsonWidgetAux (Number n)
| isInteger n = [whamlet|#{formatScientific Fixed (Just 0) n}|]
| otherwise = [whamlet|#{formatScientific Generic Nothing n}|]
jsonWidgetAux (Array l)
jsonWidgetAux (Array l)
| 1 >= length l = foldMap jsonWidgetAux l -- empty arrays don't show
| otherwise =
[whamlet|
@ -285,4 +292,3 @@ jsonWidget x = jsonWidgetAux $ toJSON x
<dt .deflist__dt>#{k}
<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 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.Monoid (First, Sum(..), Endo)
import Data.Proxy
@ -265,7 +265,7 @@ addAttrsClass cl attrs = ("class", cl') : noClAttrs
where
(clAttrs, noClAttrs) = partition (views _1 $ (== "class") . CI.mk) attrs
cl' = Text.intercalate " " . nubOrd . filter (not . null) $ cl : (views _2 (Text.splitOn " ") =<< clAttrs)
---------------------
-- 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`
dropPrefixText :: Text -> Text -> Text
-- dropPrefixText p t = fromMaybe t $ stripPrefix p t
dropPrefixText p (stripPrefix p -> Just t) = t
dropPrefixText _ other = other
-- dropPrefixText p t = fromMaybe t $ stripPrefix p t
dropPrefixText p (stripPrefix p -> Just t) = t
dropPrefixText _ other = other
-- | take first line, only
-- | take first line, only
cropText :: Text -> Text
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
-- 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
-- | Instead of CI.mk, this still allows use of Text.isInfixOf, etc.
stripFold :: Text -> Text
stripFold :: Text -> Text
stripFold = Text.toCaseFold . Text.strip
-- | just to avoid adding an import for this
ciOriginal :: CI Text -> Text
ciOriginal :: CI Text -> Text
ciOriginal = CI.original
ciShow :: Show a => a -> CI Text
ciShow = CI.mk . tshow
citext2lower :: CI Text -> Text
citext2lower :: CI Text -> Text
citext2lower = Text.toLower . CI.original
-- avoids unnecessary imports
citext2string :: CI Text -> String
citext2string :: CI Text -> String
citext2string = Text.unpack . CI.original
string2citext :: String -> CI Text
string2citext = CI.mk . Text.pack
text2AlphaNumPlus :: [Char] -> Text -> Text
text2AlphaNumPlus =
text2AlphaNumPlus =
let alphaNum = Set.fromAscList $ ['0'..'9'] <> ['A'..'Z'] <> ['a'..'z']
in \oks ->
in \oks ->
let aNumPlus = Set.fromList oks <> alphaNum
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 = text2AlphaNumPlus ['-','_']
. Text.replace "ä" "ae"
@ -348,9 +348,9 @@ text2asciiAlphaNum = text2AlphaNumPlus ['-','_']
. 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 "ò" "o"
. Text.replace "ò" "o"
. Text.replace "ò" "o"
@ -359,7 +359,7 @@ text2asciiAlphaNum = text2AlphaNumPlus ['-','_']
. Text.replace "ü" "ue"
. Text.replace "ù" "u"
. Text.replace "ú" "u"
. Text.replace "û" "u"
. Text.replace "û" "u"
. 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 "ß" "ss"
. Text.replace "ß" "ss"
. Text.replace "ç" "c"
. Text.replace "ş" "s"
. Text.replace "ğ" "g"
@ -380,10 +380,10 @@ text2Html :: Text -> Html
text2Html = toHtml
citext2Html :: CI Text -> Html
citext2Html = toHtml . CI.original
citext2Html = toHtml . CI.original
char2Text :: Char -> Text
char2Text c
char2Text c
| isSpace c = "<Space>"
| 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 >>)
-- | Burst Text into an unordered set of letters
charSet :: Text -> Set Char
charSet = Text.foldl (flip Set.insert) mempty
charSet :: Text -> Set Char
charSet = Text.foldl (flip Set.insert) mempty
-- | Returns Nothing iff both texts are identical,
-- otherwise a differing character is returned, preferable from the first argument
textDiff :: Text -> Text -> Maybe Char
textDiff (Text.uncons -> xs) (Text.uncons -> ys)
| Just (x,xt) <- xs
, Just (y,yt) <- ys
= if x == y
| Just (x,xt) <- xs
, Just (y,yt) <- ys
= if x == y
then textDiff xt yt
else Just x
| otherwise
@ -515,17 +515,17 @@ fromText :: (IsString a, Textual t) => t -> a
fromText = fromString . unpack
{-
-- | Captialize the first character and leave all others as they were
textToCapital :: Text -> Text
textToCapital s
| Just (h,t) <- Text.uncons s
= Text.Cons (Char.toUpper h) t
-- | Captialize the first character and leave all others as they were
textToCapital :: Text -> Text
textToCapital s
| Just (h,t) <- Text.uncons s
= Text.Cons (Char.toUpper h) t
| otherwise = s
snakecase2camelcase :: Text -> Text
snakecase2camelcase t = Text.concat $ map textToCapital words
where
words = Text.splitOn '_' t
where
words = Text.splitOn '_' t
-}
-- | 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
--
-- @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
cutOffCoPercent :: Rational -> Rational -> Rational -> Rational
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
--
-- @offset@ specifies minimum result value, unless @achieved@ is zero
--
--
-- Useful for heat maps, with offset giving a visual step between zero and nonzero
cutOffPercent :: Rational -> Rational -> Rational -> Rational
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 = not . null
headDef :: a -> [a] -> a
headDef :: a -> [a] -> a
headDef _ (h:_) = h
headDef d _ = d
@ -725,7 +725,7 @@ insertAttr attr valu = aux
| attr==a = (a, Text.append valu $ Text.cons ' ' v) : t
| otherwise = p : aux t
-- 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.
-- 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
-- Some of our libraries use association lists for very few keys.
insertAssoc :: (Eq k, MonoFoldable v) => k -> v -> [(k,v)] -> [(k,v)]
insertAssoc key val = aux
where
insertAssoc key val = aux
where
aux [] = mbcons []
aux (p@(k,_) : t)
aux (p@(k,_) : t)
| key == k = mbcons t
| otherwise = p : aux t
mbcons t
| otherwise = p : aux t
mbcons t
| onull val = t
| otherwise = (key,val) : t
@ -804,7 +804,7 @@ withoutSubsequenceBy cmp = go []
pattern NonEmpty :: forall a. a -> [a] -> NonEmpty a
pattern NonEmpty x xs = x :| xs
{-# COMPLETE NonEmpty #-}
checkAsc :: Ord a => [a] -> Bool
checkAsc (x:r@(y:_)) = x<=y && checkAsc r
checkAsc _ = True
@ -825,7 +825,7 @@ infixl 5 !!!
(!!!) 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 :: Ord k => Map k [v] -> [k] -> [v]
-- lookupSome :: Ord k => Map k [v] -> [k] -> [v]
-- lookupSome m ks = ks >>= (m !!!)
lookupSome = (=<<) . (!!!)
@ -842,7 +842,7 @@ maybeMap :: IsMap p => ContainerKey p -> Maybe (MapValue p) -> p
maybeMap k = foldMap (singletonMap k)
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)
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 (mx@(Just x), Just y) | x==y = (mx, Nothing)
eq2nothing p = p
-- replaced by a more general formulation, see canonical
-- null2nothing :: MonoFoldable a => Maybe a -> Maybe a
-- 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_ = 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
-- ^ `hoist` regarding `Maybe` as if identical to @MaybeT Identity@
hoistMaybe = maybe mzero return
@ -1020,7 +1021,7 @@ maybeThrowM = fromMaybeM . throwM
maybeMapM :: Applicative m => (a -> m (Maybe b)) -> [a] -> m [b]
maybeMapM f = foldr go (pure [])
where
where
go = liftA2 (maybe id (:)) . f
mapMaybeM :: ( Monad m
@ -1039,14 +1040,14 @@ forMaybeM = flip mapMaybeM
-- | 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 ma mb = ma >>= \case
altM ma mb = ma >>= \case
Nothing -> mb
res -> return res
-- | Map f and get the first Just
firstJust :: MonoFoldable mono => (Element mono -> Maybe a) -> mono -> Maybe a
firstJust f = foldr go Nothing
where
where
-- go :: a -> Maybe b -> Maybe b
go x Nothing = f x
go _ res = res
@ -1057,7 +1058,7 @@ firstJust f = foldr go Nothing
-- Copied from GHC.Data.Maybe, which could not be imported somehow.
-- HOWEVER, this function counterintuitively forces the entire foldable!
-- firstJustM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a)
-- firstJustM = foldlM go Nothing
-- firstJustM = foldlM go Nothing
-- where
-- go :: Monad m => Maybe a -> m (Maybe a) -> m (Maybe a)
-- 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)
where
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 = foldr go (return Nothing)
-- where
-- go n p = n >>= \case {Nothing -> p; res -> return res}
-- where
-- go n p = n >>= \case {Nothing -> p; res -> return res}
-- | Run the maybe computation repeatedly until the first Just is returned
-- or the number of maximum retries is exhausted.
-- So like Control.Monad.Loops.untilJust, but with a maximum number of attempts.
untilJustMaxM :: Monad m => Int -> m (Maybe a) -> m (Maybe a)
untilJustMaxM nmax act = go 0
where
go n | n >= nmax = return Nothing
untilJustMaxM nmax act = go 0
where
go n | n >= nmax = return Nothing
| otherwise = do
x <- act
case x of
Nothing -> go $ succ n
res@(Just _) -> return res
x <- act
case x of
Nothing -> go $ succ n
res@(Just _) -> return res
------------
-- Either --
------------
@ -1111,8 +1112,8 @@ whenIsRight (Right x) f = f x
whenIsRight (Left _) _ = pure ()
{- Just a reminder for Steffen:
mapLeft :: (a -> c) -> Either a b -> Either c b
mapLeft = over _Left
mapLeft :: (a -> c) -> Either a b -> Either c b
mapLeft = over _Left
-}
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 act = catch (Just <$> act) ignore
-- where
-- where
-- ignore :: Monad m => SomeException -> m (Maybe a)
-- ignore _ = return Nothing
-- | 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 act = catch act ignore
where
where
ignore :: Monad m => SomeException -> m (Maybe a)
ignore _ = return Nothing
maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b
maybeExceptT err act = lift act >>= maybe (throwE err) return
maybeExceptT' :: Monad m => e -> Maybe b -> ExceptT e m b
maybeExceptT' err = maybe (throwE err) return
@ -1299,10 +1300,10 @@ continueJust (Just x) f = f x
continueJust Nothing _ = pure mempty
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
Just x -> f x
-}
-}
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
@ -1437,13 +1438,13 @@ tellM = tell <=< lift
tellPoint :: forall mono m. (MonadWriter mono m, MonoPointed mono) => Element mono -> m ()
tellPoint = tell . opoint
tellMPoint :: (MonadTrans t, MonadWriter mono (t m), Monad m, MonoPointed mono) => m (Element mono) -> t m ()
tellMPoint = tellM . fmap opoint
class IsWriterT t where
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
runWriterT' = Strict.runWriterT
mapWriterT' = Strict.mapWriterT
@ -1549,7 +1550,7 @@ data CustomHeader
| HeaderAlerts
| HeaderDBTableCanonicalURL
| HeaderDryRun
| HeaderUploadToken
| HeaderUploadToken
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe CustomHeader
@ -1872,8 +1873,8 @@ pickBetter x y crit
| cx == cy = Nothing
| cx = Just x
| otherwise = Just y
where
cx = crit x
where
cx = crit x
cy = crit y
reverseOrdering :: Ordering -> Ordering
@ -1940,7 +1941,7 @@ makePrisms ''MergeHashMap
makeWrapped ''MergeHashMap
type instance Element (MergeHashMap k v) = v
instance MonoFoldable (MergeHashMap k v)
instance MonoFunctor (MergeHashMap k v)
instance MonoTraversable (MergeHashMap k v)
@ -1994,7 +1995,7 @@ makePrisms ''MergeMap
makeWrapped ''MergeMap
type instance Element (MergeMap k v) = v
instance MonoFoldable (MergeMap k v)
instance MonoFunctor (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 p idx ary = p (V.unsafeIndex ary idx) Aeson.<?> Aeson.Index idx
--------------
-- 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
class Canonical a where
class Canonical a where
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
canonical r@(Just t) = let c = canonical t
in if null c then Nothing else
canonical r@(Just t) = let c = canonical t
in if null c then Nothing else
if t==c then r else Just c
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 = now { utctDay = n_day n }
(currentYear, _currentMonth, _currentDay) = toGregorian $ utctDay now
currentTerm = TermIdentifier currentYear
currentTerm = TermIdentifier currentYear
nextTerm n = toEnum . (+n) $ fromEnum currentTerm
termTime :: TermIdentifier -- ^ Term
@ -572,13 +572,13 @@ fillDb = do
Just middleName' -> repack [st|#{firstName}.#{middleName'}.#{userSurname}@example.invalid|]
Nothing -> repack [st|#{firstName}.#{userSurname}@example.invalid|]
userEmail' :: CI Text
userEmail' = CI.mk $ case firstName of
userEmail' = CI.mk $ case firstName of
"James" -> userIdent
"John" -> userIdent
"Elizabeth" -> "AVSID:" <> userMatrikelnummer'
_ -> "E" <> userMatrikelnummer' <> "@fraport.de"
userDisplayEmail' :: CI Text
userDisplayEmail' = CI.mk $ case userSurname of
userDisplayEmail' = CI.mk $ case userSurname of
"Walker" -> "AVSNO:" <> userMatrikelnummer'
"Clark" -> "E" <> userMatrikelnummer' <> "@fraport.de"
"Jackson" -> ""
@ -591,12 +591,12 @@ fillDb = do
-- | otherwise
-- = []
-- 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]
manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel
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]
let tmin = -1
tmax = 2
trange = [tmin..tmax]
@ -692,26 +692,26 @@ fillDb = do
, UserSupervisor gkleen fhamann False (Just fraGround) (Just "Staff")
, UserSupervisor gkleen gkleen True (Just fraGround) (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 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 ]
upsertManyWhere supvs [] [] []
upsertManyWhere supvs [] [] []
-- insertMany_ supvs -- NOTE: multiple calls like this throw a runtime error!
-- 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)
-- [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
-- | 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)
-- [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 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
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
@ -719,13 +719,13 @@ fillDb = do
void . insert' $ UserFunction jost avn SchoolAdmin
void . insert' $ UserFunction gkleen ifi 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 mi SchoolAdmin
void . insert' $ UserFunction svaupel ifi SchoolAdmin
void . insert' $ UserFunction svaupel mi SchoolAdmin
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 svaupel 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 $ AdminProblemSupervisorNewCompany fhamann fraportAg ffacil True ) 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
let
@ -1024,7 +1026,7 @@ fillDb = do
, courseDeregisterUntil = jtt TermDayLectureStart 5 (Just Monday) toMidnight
, courseRegisterSecret = Nothing
, courseMaterialFree = True
}
}
insert_ $ CourseEdit jost now c
when (tyear >= currentYear) $ insert_ $ CourseQualification c qid_f 2
when (tyear >= succ currentYear) $ insert_ $ CourseQualification c qid_r 3