241 lines
10 KiB
Haskell
241 lines
10 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Handler.Admin
|
|
( module Handler.Admin
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Jobs
|
|
-- import Data.Either
|
|
import qualified Data.Set as Set
|
|
-- import qualified Data.Text.Lazy.Encoding as LBS
|
|
|
|
-- import qualified Control.Monad.Catch as Catch
|
|
-- import Servant.Client (ClientError(..), ResponseF(..))
|
|
-- import Text.Blaze.Html (preEscapedToHtml)
|
|
|
|
import Database.Esqueleto.Experimental ((:&)(..))
|
|
import qualified Database.Esqueleto.Experimental as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import Handler.Utils.DateTime
|
|
import Handler.Utils.Avs
|
|
import Handler.Utils.Widgets
|
|
import Handler.Utils.Users
|
|
import Handler.Utils.Qualification
|
|
|
|
import Handler.Admin.Test as Handler.Admin
|
|
import Handler.Admin.ErrorMessage as Handler.Admin
|
|
import Handler.Admin.Tokens as Handler.Admin
|
|
import Handler.Admin.Crontab as Handler.Admin
|
|
import Handler.Admin.Avs as Handler.Admin
|
|
import Handler.Admin.Ldap as Handler.Admin
|
|
|
|
|
|
getAdminR :: Handler Html
|
|
getAdminR = redirect AdminProblemsR
|
|
|
|
getAdminProblemsR :: Handler Html
|
|
getAdminProblemsR = do
|
|
now <- liftIO getCurrentTime
|
|
let nowaday = utctDay now
|
|
cutOffPrintDays = 7
|
|
cutOffPrintJob = addLocalDays (-cutOffPrintDays) now
|
|
|
|
(usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, noAvsSynchProblems) <- runDB $ (,,,,,)
|
|
<$> areAllUsersReachable
|
|
<*> allDriversHaveAvsId now
|
|
<*> allRDriversHaveFs now
|
|
<*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <=. cutOffPrintJob])
|
|
<*> (not <$> exists [PrintAcknowledgeProcessed ==. False])
|
|
<*> (not <$> exists [UserAvsLastSynchError !=. Nothing])
|
|
diffLics <- try retrieveDifferingLicences >>= \case
|
|
-- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received"
|
|
(Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException)
|
|
(Right AvsLicenceDifferences{..}) -> do
|
|
let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld
|
|
forM_ (take 42 $ Set.toList problemIds) $ queueJob' . flip JobSynchroniseAvsId (Just nowaday)
|
|
return $ Right
|
|
( Set.size avsLicenceDiffRevokeAll
|
|
, Set.size avsLicenceDiffGrantVorfeld
|
|
, Set.size avsLicenceDiffRevokeRollfeld
|
|
, Set.size avsLicenceDiffGrantRollfeld
|
|
)
|
|
-- Attempt to format results in a nicer way failed, since rendering Html within a modal destroyed the page layout itself
|
|
-- let procDiffLics (to0, to1, to2) = Right (Set.size to0, Set.size to1, Set.size to2)
|
|
-- diffLics <- (procDiffLics <$> retrieveDifferingLicences) `catches`
|
|
-- [ Catch.Handler (\case (UnsupportedContentType "text/html;charset=utf-8" Response{responseBody})
|
|
-- -> return $ Left $ toWidget $ preEscapedToHtml $ fromRight "Response UTF8-decoding error" $ LBS.decodeUtf8' responseBody
|
|
-- ex -> return $ Left $ text2widget $ tshow ex)
|
|
-- , Catch.Handler (\(ex::SomeException) -> return $ Left $ text2widget $ tshow ex)
|
|
-- ]
|
|
|
|
-- we abuse messageTooltip for colored icons here
|
|
msgSuccessTooltip <- messageI Success MsgMessageSuccess
|
|
msgWarningTooltip <- messageI Warning MsgMessageWarning
|
|
msgErrorTooltip <- messageI Error MsgMessageError
|
|
|
|
let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip
|
|
flagWarning = messageTooltip . bool msgWarningTooltip msgSuccessTooltip
|
|
flagNonZero :: Int -> Widget
|
|
flagNonZero n | n <= 0 = flagError True
|
|
| otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n))
|
|
|
|
rerouteMail <- getsYesod $ view _appMailRerouteTo
|
|
|
|
siteLayoutMsg MsgProblemsHeading $ do
|
|
setTitleI MsgProblemsHeading
|
|
$(widgetFile "admin-problems")
|
|
|
|
|
|
getProblemUnreachableR :: Handler Html
|
|
getProblemUnreachableR = do
|
|
unreachables <- runDB retrieveUnreachableUsers
|
|
siteLayoutMsg MsgProblemsUnreachableHeading $ do
|
|
setTitleI MsgProblemsUnreachableHeading
|
|
[whamlet|
|
|
<section>
|
|
#{length unreachables} _{MsgProblemsUnreachableBody}
|
|
<ul>
|
|
$forall usr <- unreachables
|
|
<li>
|
|
^{linkUserWidget ForProfileDataR usr} (#{usr ^. _userDisplayEmail} / #{usr ^. _userEmail})
|
|
|]
|
|
|
|
getProblemFbutNoR :: Handler Html
|
|
getProblemFbutNoR = do
|
|
now <- liftIO getCurrentTime
|
|
rnofs <- runDB $ E.select $ retrieveDriversRWithoutF now
|
|
siteLayoutMsg MsgProblemsRWithoutFHeading $ do
|
|
setTitleI MsgProblemsRWithoutFHeading
|
|
[whamlet|
|
|
<section>
|
|
_{MsgProblemsRWithoutFBody}
|
|
<ul>
|
|
$forall usr <- rnofs
|
|
<li>
|
|
^{linkUserWidget AdminUserR usr}
|
|
|]
|
|
|
|
getProblemWithoutAvsId :: Handler Html
|
|
getProblemWithoutAvsId = do
|
|
now <- liftIO getCurrentTime
|
|
rnofs <- runDB $ E.select $ retrieveDriversWithoutAvsId now
|
|
siteLayoutMsg MsgProblemsNoAvsIdHeading $ do
|
|
setTitleI MsgProblemsNoAvsIdHeading
|
|
[whamlet|
|
|
<section>
|
|
_{MsgProblemsNoAvsIdBody}
|
|
<ul>
|
|
$forall usr <- rnofs
|
|
<li>
|
|
^{linkUserWidget AdminUserR usr}
|
|
|]
|
|
|
|
{-
|
|
mkUnreachableUsersTable = do
|
|
let dbtSQLQuery user -> do
|
|
E.where_ $ E.isNothing (user E.^. UserPostAddress)
|
|
E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%")
|
|
pure user
|
|
dbtRowKey = (E.^. UserId)
|
|
dbtProj = dbtProjId
|
|
dbtColonnade =
|
|
-}
|
|
|
|
areAllUsersReachable :: DB Bool
|
|
-- 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 :: 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 :: UTCTime -> DB Bool
|
|
-- allDriversHaveAvsId = fmap isNothing . E.selectOne . retrieveDriversWithoutAvsId
|
|
allDriversHaveAvsId = E.selectNotExists . retrieveDriversWithoutAvsId
|
|
|
|
{-
|
|
-- | Returns users more than once if they own multiple avs-related valid licences, but no AvsID is known
|
|
retrieveDriversWithoutAvsId' :: Day -> E.SqlQuery (E.SqlExpr (Entity User))
|
|
retrieveDriversWithoutAvsId' 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.&&. (qualUsr & validQualification nowaday)
|
|
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
|
|
retrieveDriversWithoutAvsId :: UTCTime -> E.SqlQuery (E.SqlExpr (Entity User))
|
|
retrieveDriversWithoutAvsId now = 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.&&. (qualUsr & validQualification now) -- currently valid
|
|
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
|
|
|
|
|
|
allRDriversHaveFs :: UTCTime -> DB Bool
|
|
-- allRDriversHaveFs = fmap isNothing . E.selectOne . retrieveDriversRWithoutF
|
|
allRDriversHaveFs = E.selectNotExists . retrieveDriversRWithoutF
|
|
|
|
-- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known
|
|
retrieveDriversRWithoutF :: UTCTime -> E.SqlQuery (E.SqlExpr (Entity User))
|
|
retrieveDriversRWithoutF now = do
|
|
usr <- E.from $ E.table @User
|
|
let hasValidQual lic = do
|
|
(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_ $ (qual E.^. QualificationAvsLicence E.==. E.justVal lic) -- matches licence
|
|
E.&&. (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId) -- matches user
|
|
E.&&. (qualUsr & validQualification now) -- currently valid
|
|
E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld)
|
|
E.&&. E.notExists (hasValidQual AvsLicenceVorfeld)
|
|
return usr
|
|
|