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

fix(reachability): account for e-users being assigned a useless company department

Browse Source
This commit is contained in:
Steffen Jost 2023-03-31 09:45:22 +00:00
parent 48e86fa578
commit bb27324ee8
2 changed files with 147 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
src/Handler/Admin.hs
View File

@ -86,7 +86,7 @@ getAdminProblemsR = do
getProblemUnreachableR :: Handler Html
getProblemUnreachableR = do
unreachables <- runDB retrieveUnreachableUsers'
unreachables <- runDB retrieveUnreachableUsers
siteLayoutMsg MsgProblemsUnreachableHeading $ do
setTitleI MsgProblemsUnreachableHeading
[whamlet|
@ -95,7 +95,7 @@ getProblemUnreachableR = do
<ul>
$forall usr <- unreachables
<li>
^{linkUserWidget ForProfileR usr} (#{usr ^. _userDisplayEmail} / #{usr ^. _userEmail})
^{linkUserWidget ForProfileDataR usr} (#{usr ^. _userDisplayEmail} / #{usr ^. _userEmail})
|]
getProblemFbutNoR :: Handler Html
@ -142,31 +142,30 @@ mkUnreachableUsersTable = do
-}
areAllUsersReachable :: DB Bool
-- areAllUsersReachable = isNothing <$> E.selectOne retrieveUnreachableUsers
areAllUsersReachable = E.selectNotExists retrieveUnreachableUsers
-- areAllUsersReachable = isNothing <$> E.selectOne retrieveUnreachableUsers'
-- areAllUsersReachable = E.selectNotExists retrieveUnreachableUsers'
areAllUsersReachable = null <$> retrieveUnreachableUsers
-- retrieveUnreachableUsers' :: E.SqlQuery (E.SqlExpr (Entity User))
-- 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
retrieveUnreachableUsers :: E.SqlQuery (E.SqlExpr (Entity User))
retrieveUnreachableUsers = do
user <- E.from $ E.table @User
E.where_ $ E.isNothing (user E.^. UserPostAddress)
E.&&. E.isNothing (user E.^. UserCompanyDepartment)
E.&&. E.not_ ((user E.^. UserDisplayEmail) `E.like` E.val "%@%.%")
E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%")
return user
retrieveUnreachableUsers' :: DB [Entity User]
retrieveUnreachableUsers' = do
obviousUnreachable <- E.select retrieveUnreachableUsers
emailUsers <- 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.^. UserDisplayEmail) `E.like` E.val "%@%.%")
E.||. ((user E.^. UserEmail) `E.like` E.val "%@%.%"))
pure user
let hasInvalidEmail = isNothing . getEmailAddress . entityVal
invaldEmail = filter hasInvalidEmail emailUsers
return $ obviousUnreachable ++ invaldEmail
retrieveUnreachableUsers :: DB [Entity User]
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%")
return user
return $ filter hasInvalidEmail emailOnlyUsers
where
hasInvalidEmail = isNothing . getEmailAddress . entityVal
allDriversHaveAvsId :: Day -> DB Bool
-- allDriversHaveAvsId = fmap isNothing . E.selectOne . retrieveDriversWithoutAvsId

125
test/Database/Fill.hs
View File

@ -358,7 +358,126 @@ fillDb = do
, userExamOfficeGetSynced = False
, userExamOfficeGetLabels = True
}
_stranger1 <- insert User
{ userIdent = "AVSID:996699"
, userAuthentication = AuthLDAP
, userLastAuthentication = Nothing
, userTokensIssuedAfter = Nothing
, userMatrikelnummer = Nothing
, userEmail = "E996699@fraport.de"
, userDisplayEmail = ""
, userDisplayName = "Stranger One"
, userSurname = "One"
, userFirstName = "Stranger"
, userTitle = Nothing
, userMaxFavourites = userDefaultMaxFavourites
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
, userTheme = ThemeMossGreen
, userDateTimeFormat = userDefaultDateTimeFormat
, userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles
, userWarningDays = userDefaultWarningDays
, userLanguages = Nothing
, userNotificationSettings = def
, userCreated = now
, userLastLdapSynchronisation = Nothing
, userLdapPrimaryKey = Nothing
, userCsvOptions = def
, userSex = Just SexMale
, userBirthday = Nothing
, userShowSex = userDefaultShowSex
, userTelephone = Nothing
, userMobile = Nothing
, userCompanyPersonalNumber = Just "E996699"
, userCompanyDepartment = Just "AVN-Strange"
, userPinPassword = Nothing
, userPostAddress = Nothing
, userPostLastUpdate = Nothing
, userPrefersPostal = False
, userExamOfficeGetSynced = False
, userExamOfficeGetLabels = True
}
_stranger2 <- insert User
{ userIdent = "AVSID:669966"
, userAuthentication = AuthLDAP
, userLastAuthentication = Nothing
, userTokensIssuedAfter = Nothing
, userMatrikelnummer = Nothing
, userEmail = "E669966@fraport.de"
, userDisplayEmail = ""
, userDisplayName = "Stranger Two"
, userSurname = "Stranger"
, userFirstName = "Two"
, userTitle = Nothing
, userMaxFavourites = userDefaultMaxFavourites
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
, userTheme = ThemeMossGreen
, userDateTimeFormat = userDefaultDateTimeFormat
, userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles
, userWarningDays = userDefaultWarningDays
, userLanguages = Nothing
, userNotificationSettings = def
, userCreated = now
, userLastLdapSynchronisation = Nothing
, userLdapPrimaryKey = Nothing
, userCsvOptions = def
, userSex = Just SexMale
, userBirthday = Nothing
, userShowSex = userDefaultShowSex
, userTelephone = Nothing
, userMobile = Nothing
, userCompanyPersonalNumber = Just "669966"
, userCompanyDepartment = Just "AVN-Strange"
, userPinPassword = Nothing
, userPostAddress = Nothing
, userPostLastUpdate = Nothing
, userPrefersPostal = False
, userExamOfficeGetSynced = False
, userExamOfficeGetLabels = True
}
_stranger3 <- insert User
{ userIdent = "AVSID:6969"
, userAuthentication = AuthLDAP
, userLastAuthentication = Nothing
, userTokensIssuedAfter = Nothing
, userMatrikelnummer = Nothing
, userEmail = "E6969@fraport.de"
, userDisplayEmail = ""
, userDisplayName = "Stranger 3 Three"
, userSurname = "Three"
, userFirstName = "Stranger"
, userTitle = Nothing
, userMaxFavourites = userDefaultMaxFavourites
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
, userTheme = ThemeMossGreen
, userDateTimeFormat = userDefaultDateTimeFormat
, userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles
, userWarningDays = userDefaultWarningDays
, userLanguages = Nothing
, userNotificationSettings = def
, userCreated = now
, userLastLdapSynchronisation = Nothing
, userLdapPrimaryKey = Nothing
, userCsvOptions = def
, userSex = Just SexMale
, userBirthday = Nothing
, userShowSex = userDefaultShowSex
, userTelephone = Nothing
, userMobile = Nothing
, userCompanyPersonalNumber = Just "E996699"
, userCompanyDepartment = Just "AVN-Strange"
, userPinPassword = Nothing
, userPostAddress = Just $ markdownToStoredMarkup ("Kartoffelweg 12 \n666 Höllensumpf \nFreiland"::Text)
, userPostLastUpdate = Nothing
, userPrefersPostal = False
, userExamOfficeGetSynced = False
, userExamOfficeGetLabels = True
}
let
firstNames = [ "James", "John", "Robert", "Michael"
, "William", "David", "Mary", "Richard"
@ -419,8 +538,8 @@ fillDb = do
, userShowSex = userDefaultShowSex
, userTelephone = Nothing
, userMobile = Nothing
, userCompanyPersonalNumber = Nothing
, userCompanyDepartment = Nothing
, userCompanyPersonalNumber = bool Nothing (Just "E123" ) (even $ length firstName)
, userCompanyDepartment = bool Nothing (Just "AVN-A") (even $ length userSurname)
, userPinPassword = Nothing
, userPostAddress = Nothing
, userPostLastUpdate = Nothing