380 lines
18 KiB
Haskell
380 lines
18 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Handler.Admin
|
|
( module Handler.Admin
|
|
) where
|
|
|
|
import Import
|
|
|
|
-- import Data.Either
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
-- 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.Persist.Sql (updateWhereCount)
|
|
import Database.Esqueleto.Experimental ((:&)(..))
|
|
import qualified Database.Esqueleto.Experimental as E
|
|
import qualified Database.Esqueleto.Legacy as EL (on) -- needed for dbTable
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Avs
|
|
import Handler.Utils.Users
|
|
-- import Handler.Utils.Company
|
|
import Handler.Health.Interface
|
|
|
|
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
|
|
|
|
-- avoids repetition of local definitions
|
|
single :: (k,a) -> Map k a
|
|
single = uncurry Map.singleton
|
|
|
|
|
|
-- Types and Template Haskell
|
|
data ProblemTableAction = ProblemTableMarkSolved
|
|
| ProblemTableMarkUnsolved
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
nullaryPathPiece ''ProblemTableAction $ camelToPathPiece' 2
|
|
embedRenderMessage ''UniWorX ''ProblemTableAction id
|
|
|
|
data ProblemTableActionData = ProblemTableMarkSolvedData
|
|
| ProblemTableMarkUnsolvedData -- Placeholder, remove later
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
|
|
|
|
-- Handlers
|
|
getAdminR :: Handler Html
|
|
getAdminR = redirect AdminProblemsR
|
|
|
|
getAdminProblemsR, postAdminProblemsR :: Handler Html
|
|
getAdminProblemsR = handleAdminProblems Nothing
|
|
|
|
handleAdminProblems :: Maybe Widget -> Handler Html
|
|
handleAdminProblems mbProblemTable = do
|
|
now <- liftIO getCurrentTime
|
|
let nowaday = utctDay now
|
|
cutOffOldDays = 1
|
|
cutOffOldTime = toMidnight $ addDays (-cutOffOldDays) nowaday
|
|
|
|
-- 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, (interfaceOks, interfaceTable)) <- runDB $ (,,,,,)
|
|
<$> areAllUsersReachable
|
|
<*> allDriversHaveAvsId now
|
|
<*> allRDriversHaveFs now
|
|
<*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <. cutOffOldTime])
|
|
<*> (not <$> exists [PrintAcknowledgeProcessed ==. False])
|
|
<*> mkInterfaceLogTable flagError mempty
|
|
let interfacesBadNr = length $ filter (not . snd) interfaceOks
|
|
-- interfacesOk = all snd interfaceOks
|
|
|
|
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
|
|
void $ runDB $ queueAvsUpdateByAID problemIds $ 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
|
|
problemLogTable <- maybeM (snd <$> runDB mkProblemLogTable) return $ return mbProblemTable -- formResult only processed in POST-Handler
|
|
|
|
siteLayoutMsg MsgProblemsHeading $ do
|
|
setTitleI MsgProblemsHeading
|
|
$(widgetFile "admin-problems")
|
|
|
|
postAdminProblemsR = do
|
|
(problemLogRes, problemLogTable) <- runDB mkProblemLogTable
|
|
formResult problemLogRes procProblems
|
|
handleAdminProblems $ Just problemLogTable
|
|
where
|
|
procProblems :: (ProblemTableActionData, Set ProblemLogId) -> Handler ()
|
|
procProblems (ProblemTableMarkSolvedData , pids) = actUpdate True pids
|
|
procProblems (ProblemTableMarkUnsolvedData, pids) = actUpdate False pids
|
|
|
|
actUpdate markdone pids = do
|
|
mauid <- maybeAuthId
|
|
now <- liftIO getCurrentTime
|
|
let (pls_fltr,newv,msg) | markdone = (ProblemLogSolved ==. Nothing, Just now, MsgAdminProblemsSolved)
|
|
| otherwise = (ProblemLogSolved !=. Nothing, Nothing , MsgAdminProblemsReopened)
|
|
(fromIntegral -> oks) <- runDB $ updateWhereCount [pls_fltr, ProblemLogId <-. toList pids]
|
|
[ProblemLogSolved =. newv, ProblemLogSolver =. mauid]
|
|
let no_req = Set.size pids
|
|
mkind = if oks < no_req || no_req <= 0 then Warning else Success
|
|
addMessageI mkind $ msg oks
|
|
when (oks > 0) $ reloadKeepGetParams AdminProblemsR -- reload to update all tables
|
|
|
|
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
|
|
filterM hasInvalidEmail emailOnlyUsers
|
|
where
|
|
hasInvalidEmail = fmap isNothing . getUserEmail
|
|
|
|
|
|
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
|
|
|
|
|
|
|
|
type ProblemLogTableExpr = E.SqlExpr (Entity ProblemLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
|
|
queryProblem :: ProblemLogTableExpr -> E.SqlExpr (Entity ProblemLog)
|
|
queryProblem = $(E.sqlLOJproj 3 1)
|
|
|
|
querySolver :: ProblemLogTableExpr -> E.SqlExpr (Maybe (Entity User))
|
|
querySolver = $(E.sqlLOJproj 3 2)
|
|
|
|
queryUser :: ProblemLogTableExpr -> E.SqlExpr (Maybe (Entity User))
|
|
queryUser = $(E.sqlLOJproj 3 3)
|
|
|
|
type ProblemLogTableData = DBRow (Entity ProblemLog, Maybe (Entity User), Maybe (Entity User))
|
|
resultProblem :: Lens' ProblemLogTableData (Entity ProblemLog)
|
|
resultProblem = _dbrOutput . _1
|
|
|
|
resultSolver :: Traversal' ProblemLogTableData (Entity User)
|
|
resultSolver = _dbrOutput . _2 . _Just
|
|
|
|
resultUser :: Traversal' ProblemLogTableData (Entity User)
|
|
resultUser = _dbrOutput . _3 . _Just
|
|
|
|
mkProblemLogTable :: DB (FormResult (ProblemTableActionData, Set ProblemLogId), Widget)
|
|
mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
|
|
where
|
|
dbtIdent = "problem-log" :: Text
|
|
dbtSQLQuery = \(problem `E.LeftOuterJoin` solver `E.LeftOuterJoin` usr) -> do
|
|
-- EL.on (usr E.?. UserId E.==. E.text2num (problem E.^. ProblemLogInfo E.->>. "user")) -- works
|
|
EL.on (usr E.?. UserId E.==. problem E.^. ProblemLogInfo E.->>>. "user")
|
|
EL.on (solver E.?. UserId E.==. problem E.^. ProblemLogSolver)
|
|
return (problem, solver, usr)
|
|
dbtRowKey = queryProblem >>> (E.^. ProblemLogId)
|
|
dbtProj = dbtProjId
|
|
dbtColonnade = formColonnade $ mconcat
|
|
[ dbSelect (applying _2) id $ return . view (resultProblem . _entityKey)
|
|
, sortable (Just "time") (i18nCell MsgAdminProblemCreated) $ \( view $ resultProblem . _entityVal . _problemLogTime -> t) -> dateTimeCell t
|
|
, sortable (Just "info") (i18nCell MsgAdminProblemInfo) $ \( view $ resultProblem . _entityVal . _problemLogAdminProblem -> p) -> adminProblemCell p
|
|
-- , sortable (Just "firm") (i18nCell MsgTableCompany) $ \(preview $ resultProblem . _entityVal . _problemLogAdminProblem . _adminProblemCompany -> c) -> cellMaybe companyIdCell c
|
|
, sortable (Just "firm") (i18nCell MsgTableCompany) $ \( view $ resultProblem . _entityVal . _problemLogAdminProblem -> p) -> cellMaybe companyIdCell $ join (p ^? _adminProblemCompanyOld) <|> (p ^? _adminProblemCompany)
|
|
, sortable (Just "user") (i18nCell MsgAdminProblemUser) $ \(preview resultUser -> u) -> maybeCell u $ cellHasUserLink AdminUserR
|
|
, sortable (Just "solved") (i18nCell MsgAdminProblemSolved) $ \( view $ resultProblem . _entityVal . _problemLogSolved -> t) -> cellMaybe dateTimeCell t
|
|
, sortable (Just "solver") (i18nCell MsgAdminProblemSolver) $ \(preview resultSolver -> u) -> maybeCell u $ cellHasUserLink AdminUserR
|
|
]
|
|
dbtSorting = mconcat
|
|
[ single ("time" , SortColumn $ queryProblem >>> (E.^. ProblemLogTime))
|
|
, single ("info" , SortColumn $ queryProblem >>> (E.^. ProblemLogInfo))
|
|
-- , single ("firm" , SortColumn ((E.->>. "company" ).(queryProblem >>> (E.^. ProblemLogInfo))))
|
|
, single ("firm" , SortColumn $ \r -> queryProblem r E.^. ProblemLogInfo E.->>. "company")
|
|
, single ("user" , sortUserNameBareM queryUser)
|
|
, single ("solved", SortColumn $ queryProblem >>> (E.^. ProblemLogSolved))
|
|
, single ("solver", sortUserNameBareM querySolver)
|
|
]
|
|
dbtFilter = mconcat
|
|
[ single ("solved" , FilterColumn . E.mkExactFilterLast $ views (to queryProblem) (E.isJust . (E.^. ProblemLogSolved)))
|
|
]
|
|
dbtFilterUI mPrev = mconcat
|
|
[ prismAForm (singletonFilter "solved" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgAdminProblemSolved)
|
|
]
|
|
acts :: Map ProblemTableAction (AForm Handler ProblemTableActionData)
|
|
acts = mconcat
|
|
[ singletonMap ProblemTableMarkSolved $ pure ProblemTableMarkSolvedData
|
|
, singletonMap ProblemTableMarkUnsolved $ pure ProblemTableMarkUnsolvedData
|
|
]
|
|
dbtParams = DBParamsForm
|
|
{ dbParamsFormMethod = POST
|
|
, dbParamsFormAction = Nothing
|
|
, dbParamsFormAttrs = []
|
|
, dbParamsFormSubmit = FormSubmit
|
|
, dbParamsFormAdditional
|
|
= renderAForm FormStandard
|
|
$ (, mempty) . First . Just
|
|
<$> multiActionA acts (fslI MsgTableAction) (Just ProblemTableMarkSolved)
|
|
, dbParamsFormEvaluate = liftHandler . runFormPost
|
|
, dbParamsFormResult = id
|
|
, dbParamsFormIdent = def
|
|
}
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
validator = def & defaultSorting [SortAscBy "time"]
|
|
& defaultFilter (singletonMap "solved" [toPathPiece False])
|
|
postprocess :: FormResult (First ProblemTableActionData, DBFormResult ProblemLogId Bool ProblemLogTableData)
|
|
-> FormResult ( ProblemTableActionData, Set ProblemLogId)
|
|
postprocess inp = do
|
|
(First (Just act), usrMap) <- inp
|
|
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
|
|
return (act, usrSet)
|
|
|
|
-- adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a -- moved to Handler.Utils
|
|
-- msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX) -- moved to Handler.Utils
|