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

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

Browse Source
This commit is contained in:
Steffen Jost 2022-12-05 18:40:57 +01:00
parent a4716cb92f
commit 214610007c
2 changed files with 78 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

85
src/Handler/Admin.hs
View File

@ -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

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

@ -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)