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

src/Handler/Admin.hs

@@ -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 = isNothing <$> E.selectOne retrieveUnreachableUsers'
-areAllUsersReachable = E.selectNotExists 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 :: DB [Entity User]
-retrieveUnreachableUsers = do     
+retrieveUnreachableUsers = do 
-    user <- E.from $ E.table @User
+    emailOnlyUsers <- E.select $ do 
-    E.where_ $  E.isNothing (user E.^. UserPostAddress)
+      user <- E.from $ E.table @User
-          E.&&. E.isNothing (user E.^. UserCompanyDepartment)
+      E.where_ $   E.isNothing (user E.^. UserPostAddress)
-          E.&&. E.not_ ((user E.^. UserDisplayEmail)  `E.like` E.val "%@%.%")
+            E.&&. (E.isNothing (user E.^. UserCompanyDepartment) E.||. user E.^. UserCompanyPersonalNumber `E.ilike` E.justVal "E%")    
-          E.&&. E.not_ ((user E.^. UserEmail)         `E.like` E.val "%@%.%")
+      return user
-    return user 
+    return $ filter hasInvalidEmail emailOnlyUsers
-
+  where 
-retrieveUnreachableUsers' :: DB [Entity User]
+    hasInvalidEmail = isNothing . getEmailAddress . entityVal
-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
 
 allDriversHaveAvsId :: Day -> DB Bool
 -- allDriversHaveAvsId = fmap isNothing . E.selectOne . retrieveDriversWithoutAvsId

test/Database/Fill.hs

@@ -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
+      , userCompanyPersonalNumber = bool Nothing (Just "E123" ) (even $ length firstName)
-      , userCompanyDepartment = Nothing
+      , userCompanyDepartment     = bool Nothing (Just "AVN-A") (even $ length userSurname)
       , userPinPassword = Nothing
       , userPostAddress = Nothing
       , userPostLastUpdate = Nothing