diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 6e430b1b5..87f0902ee 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -8,8 +8,9 @@ module Handler.Admin import Import --- import qualified Database.Esqueleto.Experimental as E --- import qualified Database.Esqueleto.Utils as E +import Database.Esqueleto.Experimental ((:&)(..)) +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 = - siteLayoutMsg MsgAdminHeading $ do - setTitleI MsgAdminHeading - i18n MsgAdminPageEmpty +getAdminR = do + _userReachability <- runDB areAllUsersReachable + + + 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 diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index d97f2e8e5..e37e4593d 100644 --- a/src/Handler/Utils/Avs.hs +++ b/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)