chore(admin): add sql queries for some problems admins have to handle

src/Handler/Admin.hs

@@ -8,8 +8,9 @@ module Handler.Admin
 
 import Import
 
--- import qualified Database.Esqueleto.Experimental as E
+import           Database.Esqueleto.Experimental ((:&)(..))
--- import qualified Database.Esqueleto.Utils as E
+import qualified Database.Esqueleto.Experimental as E
+import qualified Database.Esqueleto.Utils as E
 
 import Handler.Admin.Test as Handler.Admin
 import Handler.Admin.ErrorMessage as Handler.Admin
@@ -20,16 +21,84 @@ import Handler.Admin.Ldap as Handler.Admin
 
 
 getAdminR :: Handler Html
-getAdminR =
+getAdminR = do 
-   siteLayoutMsg MsgAdminHeading $ do
+  _userReachability <- runDB areAllUsersReachable
-      setTitleI MsgAdminHeading
+
-      i18n MsgAdminPageEmpty
+
+  siteLayoutMsg MsgAdminHeading $ do
+    setTitleI MsgAdminHeading
+    i18n MsgAdminPageEmpty
+
+
+areAllUsersReachable :: DB Bool
+areAllUsersReachable = isNothing <$> E.selectOne getUnreachableUsers
+
+getUnreachableUsers :: E.SqlQuery (E.SqlExpr (Entity User))
+getUnreachableUsers = do     
+    user <- E.from $ E.table @User
+    E.where_ $  E.isNothing (user E.^. UserPostAddress)
+          E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%") 
+    return user 
+
+allDriversHaveAvsId :: DB Bool
+allDriversHaveAvsId = do
+  now <- liftIO getCurrentTime
+  let nowaday = utctDay now
+  isNothing <$> E.selectOne (getDriversWithoutAvsId nowaday)
+
+-- | Returns users more than once if they own multiple avs-related valid licences, but no AvsID is known
+getDriversWithoutAvsId :: Day -> E.SqlQuery (E.SqlExpr (Entity User))
+getDriversWithoutAvsId 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.where_ $ -- is avs licence
+      E.isJust (qual E.^. QualificationAvsLicence)
+    E.&&. -- currently valid 
+      (E.val nowaday `E.between` ( qualUsr E.^. QualificationUserFirstHeld           
+                                  , qualUsr E.^. QualificationUserValidUntil))
+    E.&&. -- not blocked
+      E.isNothing (qualUsr E.^. QualificationUserBlockedDue)
+    E.&&. -- AvsId is unknown
+      E.notExists (do 
+        avsUsr <- E.from $ E.table @UserAvs
+        E.where_ $ avsUsr E.^. UserAvsUser E.==. usr E.^. UserId
+      )
+  return usr
+
+-- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known
+getDriversWithoutAvsId' :: Day -> E.SqlQuery (E.SqlExpr (Entity User))
+getDriversWithoutAvsId' nowaday = do     
+  usr <- E.from $ E.table @User
+  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.&&. -- currently valid
+            (E.val nowaday `E.between`  ( qualUsr E.^. QualificationUserFirstHeld           
+                                        , qualUsr E.^. QualificationUserValidUntil))
+          E.&&. -- not blocked
+            E.isNothing (qualUsr E.^. QualificationUserBlockedDue)
+          E.&&. -- matches user 
+            (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId)
+      )
+    E.&&. 
+      E.notExists (do -- a known AvsId
+        avsUsr <- E.from $ E.table @UserAvs
+        E.where_ $ avsUsr E.^. UserAvsUser E.==. usr E.^. UserId
+      )
+  return usr
 
 {-
-mkBadAddressTable = do
+mkUnreachableUsersTable = 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 = dbtProjFilteredPostId -- TODO: still don't understand the choices here

src/Handler/Utils/Avs.hs

@@ -181,7 +181,7 @@ computeDifferingLicences (AvsResponseGetLicences licences) = do
               E.&&. (quali E.^. QualificationAvsLicence E.==. E.justVal lic)                  -- correct type of licence
               E.&&. (E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld           
                                                ,qualUser E.^. QualificationUserValidUntil))   -- currently valid
-              E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue)                   -- no blocked 
+              E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue)                   -- not blocked 
               )
             `E.innerJoin` E.table @UserAvs
             `E.on` (\(_ :& qualUser :& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser)