309 lines
14 KiB
Haskell
309 lines
14 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
|
|
import Handler.Utils.Avs
|
|
import Handler.Utils.Users
|
|
|
|
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
|
|
cutOffOldDays = 7
|
|
cutOffOldTime = addLocalDays (-cutOffOldDays) now
|
|
|
|
-- 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))
|
|
|
|
(usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, interfaceTable) <- runDB $ (,,,,,)
|
|
<$> areAllUsersReachable
|
|
<*> allDriversHaveAvsId now
|
|
<*> allRDriversHaveFs now
|
|
<*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <. cutOffOldTime])
|
|
<*> (not <$> exists [PrintAcknowledgeProcessed ==. False])
|
|
<*> fmap (view _2) (mkInterfaceLogTable flagError cutOffOldTime)
|
|
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)
|
|
-- ]
|
|
|
|
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
|
|
|
|
|
|
|
|
|
|
|
|
mkInterfaceLogTable :: (Bool -> Widget) -> UTCTime -> DB (Any, Widget)
|
|
mkInterfaceLogTable flagError cutOffOldTime = do
|
|
avsSynchStats <- E.select $ do
|
|
uavs <- E.from $ E.table @UserAvs
|
|
E.where_ $ uavs E.^. UserAvsLastSynch E.>. E.val cutOffOldTime
|
|
let isOk = E.isNothing (uavs E.^. UserAvsLastSynchError)
|
|
E.groupBy isOk
|
|
E.orderBy [E.descNullsLast isOk]
|
|
return (isOk, E.countRows, E.max_ $ uavs E.^. UserAvsLastSynch)
|
|
let
|
|
mkBadInfo badRows (fromMaybe cutOffOldTime -> badTime) | badRows > 0 = do
|
|
fmtCut <- formatTime SelFormatDate cutOffOldTime
|
|
fmtBad <- formatTime SelFormatDateTime badTime
|
|
return $ tshow badRows <> " Fehler seit " <> fmtCut <> ", zuletzt um " <> fmtBad
|
|
mkBadInfo _ _ = return mempty
|
|
writeAvsSynchStats okRows (fromMaybe cutOffOldTime -> okTime) badInfo =
|
|
void $ upsertBy (UniqueInterfaceSubtypeWrite "AVS" "Synch" True)
|
|
(InterfaceLog "AVS" "Synch" True okTime okRows badInfo)
|
|
[InterfaceLogTime =. okTime, InterfaceLogRows =. okRows, InterfaceLogInfo =. badInfo]
|
|
--case $(unValueN 3) <$> avsSynchStats of
|
|
case avsSynchStats of
|
|
((E.Value True , E.Value okRows, E.Value okTime):(E.Value False, E.Value badRows, E.Value badTime):_) ->
|
|
writeAvsSynchStats (Just okRows) okTime =<< mkBadInfo badRows badTime
|
|
((E.Value True , E.Value okRows, E.Value okTime):_) ->
|
|
writeAvsSynchStats (Just okRows) okTime mempty
|
|
((E.Value False, E.Value badRows, E.Value badTime):_) -> do
|
|
lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch]
|
|
writeAvsSynchStats Nothing lastOk =<< mkBadInfo badRows badTime
|
|
_ -> return ()
|
|
|
|
let
|
|
flagOld = flagError . (cutOffOldTime <)
|
|
resultDBTable = DBTable{..}
|
|
where
|
|
resultILog :: Lens' (DBRow (Entity InterfaceLog)) InterfaceLog
|
|
resultILog = _dbrOutput . _entityVal
|
|
dbtSQLQuery = return
|
|
dbtRowKey = (E.^. InterfaceLogId)
|
|
dbtProj = dbtProjId
|
|
dbtColonnade = dbColonnade $ mconcat
|
|
[ sortable Nothing (textCell "Status" ) $ wgtCell . flagOld . view (resultILog . _interfaceLogTime)
|
|
, sortable (Just "interface") (textCell "Interface") $ \(view (resultILog . _interfaceLogInterface) -> n) -> textCell n
|
|
, sortable (Just "subtype") (textCell "Art" ) $ textCell . view (resultILog . _interfaceLogSubtype)
|
|
, sortable (Just "write") (textCell "Write" ) $ (`ifIconCell` IconEdit) . view (resultILog . _interfaceLogWrite)
|
|
, sortable (Just "time") (i18nCell MsgSystemMessageTimestamp) $ dateTimeCell . view (resultILog . _interfaceLogTime)
|
|
, sortable (Just "rows") (textCell "Zeilen" ) $ cellMaybe numCell . view (resultILog . _interfaceLogRows)
|
|
, sortable Nothing (textCell "Info" ) $ \(view resultILog -> ilt) -> case ilt of
|
|
InterfaceLog "AVS" "Synch" True _ _ i -> anchorCell ProblemAvsErrorR $ toWgt i
|
|
InterfaceLog _ _ _ _ _ i -> textCell i
|
|
]
|
|
dbtSorting = mconcat
|
|
[ singletonMap "interface" $ SortColumn (E.^. InterfaceLogInterface)
|
|
, singletonMap "subtype" $ SortColumn (E.^. InterfaceLogSubtype)
|
|
, singletonMap "write" $ SortColumn (E.^. InterfaceLogWrite)
|
|
, singletonMap "time" $ SortColumn (E.^. InterfaceLogTime)
|
|
, singletonMap "rows" $ SortColumn (E.^. InterfaceLogRows)
|
|
]
|
|
dbtFilter = mempty
|
|
dbtFilterUI = mempty
|
|
dbtStyle = def
|
|
dbtIdent = "interface-log" :: Text
|
|
dbtParams = def
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
resultDBTableValidator = def
|
|
dbTable resultDBTableValidator resultDBTable |