-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- 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 as Text -- 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 Jobs import Handler.Utils import Handler.Utils.Avs import Handler.Utils.Users -- import Handler.Utils.Company import Handler.Health.Interface import Handler.Users (AllUsersAction(..)) 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 -- 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 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 . fst <$> 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, postProblemUnreachableR :: Handler Html getProblemUnreachableR = postProblemUnreachableR postProblemUnreachableR = do unreachables <- runDB retrieveUnreachableUsers -- the following form is a nearly identicaly copy from Handler.Users: ((noreachUsersRes, noreachUsersWgt'), noreachUsersEnctype) <- runFormPost . identifyForm FIDUnreachableUsersAction $ buttonForm let noreachUsersWgt = wrapForm noreachUsersWgt' def { formSubmit = FormNoSubmit , formAction = Just $ SomeRoute ProblemUnreachableR , formEncoding = noreachUsersEnctype } formResult noreachUsersRes $ \case AllUsersLdapSync -> do forM_ unreachables $ \Entity{entityKey=uid} -> void . queueJob $ JobSynchroniseLdapUser uid addMessageI Success . MsgSynchroniseLdapUserQueued $ length unreachables redirect ProblemUnreachableR AllUsersAvsSync -> do n <- runDB $ queueAvsUpdateByUID (entityKey <$> unreachables) Nothing addMessageI Success . MsgSynchroniseAvsUserQueued $ fromIntegral n redirect ProblemUnreachableR siteLayoutMsg MsgProblemsUnreachableHeading $ do setTitleI MsgProblemsUnreachableHeading [whamlet|

_{MsgProblemsUnreachableButtons} ^{noreachUsersWgt}
#{length unreachables} _{MsgProblemsUnreachableBody}
    $forall usr <- unreachables
  • ^{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|
    _{MsgProblemsRWithoutFBody}
      $forall usr <- rnofs
    • ^{linkUserWidget AdminUserR usr} |] getProblemWithoutAvsId :: Handler Html getProblemWithoutAvsId = do now <- liftIO getCurrentTime rnofs <- runDB $ E.select $ retrieveDriversWithoutAvsId now siteLayoutMsg MsgProblemsNoAvsIdHeading $ do setTitleI MsgProblemsNoAvsIdHeading [whamlet|
      _{MsgProblemsNoAvsIdBody}
        $forall usr <- rnofs
      • ^{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 = E.selectNotExists retrieveUnreachableUsers' -- works and would be more efficient, but we cannot check proper email validity within DB alone 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%") E.&&. E.notExists (do (cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany) E.where_ $ user E.^. UserId E.==. usrCmp E.^. UserCompanyUser E.&&. usrCmp E.^. UserCompanyUseCompanyAddress E.&&. E.isJust (cmp E.^. CompanyPostAddress) ) return user filterM hasInvalidEmail emailOnlyUsers -- filterM hasInvalifPostal -- probably not worth it, since Utils.Postal.validPostAddress is pretty weak anyway 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 = do -- problem_types <- E.select $ do -- ap <- E.from $ E.table @ProblemLog -- let res = ap E.^. ProblemLogInfo E.->>. "problem" -- E.groupBy res -- return res over _1 postprocess <$> dbTable validator DBTable{..} where -- TODO: query to collect all occurring problem types to use as tooltip for the problem filter, so that these don't run out of synch 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 = dbtProjFilteredPostId 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 = Map.fromList [ ("time" , SortColumn $ queryProblem >>> (E.^. ProblemLogTime)) , ("info" , SortColumn $ queryProblem >>> (E.^. ProblemLogInfo)) -- , ("firm" , SortColumn ((E.->>. "company" ).(queryProblem >>> (E.^. ProblemLogInfo)))) , ("firm" , SortColumn $ \r -> queryProblem r E.^. ProblemLogInfo E.->>. "company") , ("user" , sortUserNameBareM queryUser) , ("solved", SortColumn $ queryProblem >>> (E.^. ProblemLogSolved)) , ("solver", sortUserNameBareM querySolver) ] dbtFilter = Map.fromList [ ("user" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryUser) (E.?. UserDisplayName)) , ("solver" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySolver) (E.?. UserDisplayName)) , ("company" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "company").(E.^. ProblemLogInfo))) , ("solved" , FilterColumn . E.mkExactFilterLast $ views (to queryProblem) (E.isJust . (E.^. ProblemLogSolved))) -- , ("problem" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "problem").(E.^. ProblemLogInfo))) -- not stored in plaintext! , ("problem" , mkFilterProjectedPost $ \(getLast -> criterion) dbr -> -- falls es nicht schnell genug ist: in dbtProj den Anzeigetext nur einmal berechnen ifNothingM criterion True $ \(crit::Text) -> do let problem = dbr ^. resultProblem . _entityVal . _problemLogAdminProblem protxt <- adminProblem2Text problem return $ crit `Text.isInfixOf` protxt ) ] dbtFilterUI mPrev = mconcat [ prismAForm (singletonFilter "user" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgAdminProblemUser & setTooltip MsgTableFilterCommaPlus) , prismAForm (singletonFilter "solver" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgAdminProblemSolver & setTooltip MsgTableFilterCommaPlusShort) , prismAForm (singletonFilter "problem" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgAdminProblemInfo) , prismAForm (singletonFilter "company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableCompanyShort) , prismAForm (singletonFilter "solved" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgAdminProblemSolved) ] acts :: Map ProblemTableAction (AForm Handler ProblemTableActionData) acts = Map.fromList [ (ProblemTableMarkSolved , pure ProblemTableMarkSolvedData) , (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