439 lines
22 KiB
Haskell
439 lines
22 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-2025 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 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 Utils.Company (areThereInsaneCompanySupervisions)
|
|
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))
|
|
|
|
showDiffTime t =
|
|
let d = diffUTCTime now t
|
|
in guardMonoid (d > secondsToNominalDiffTime 30) [whamlet|<small>_{MsgProblemLastCheckTime (formatDiffDays d)}|]
|
|
|
|
(usersAreReachable, aurTime) <- areAllUsersReachable -- cached
|
|
(not -> thereAreInsaneFirmSupervisions, ifsTime) <- areThereInsaneCompanySupervisions -- cached
|
|
(driversHaveAvsIds, rDriversHaveFs, not -> noStalePrintJobs, not -> noBadAPCids) <- runDBRead $ (,,,)
|
|
<$> allDriversHaveAvsId now
|
|
<*> allRDriversHaveFs now
|
|
<*> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <. cutOffOldTime]
|
|
<*> exists [PrintAcknowledgeProcessed ==. False]
|
|
(interfaceOks, interfaceTable) <- runDB $ 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 <- runDBRead 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|
|
|
<section>
|
|
<h3>_{MsgProblemsUnreachableButtons}
|
|
^{noreachUsersWgt}
|
|
<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 :: Handler (Bool, UTCTime)
|
|
areAllUsersReachable = $(memcachedByHere) (Just . Right $ 22 * diffHour) [st|isane-users-reachable|] $ do
|
|
now <- liftIO getCurrentTime
|
|
res <- runDBRead retrieveUnreachableUsers
|
|
-- res <- E.selectNotExists retrieveUnreachableUsers' -- works and would be more efficient, but we cannot check proper email validity within DB alone
|
|
$logInfoS "sanity" [st|Are there insane company supervisions: #{tshow res}|]
|
|
return (null res,now)
|
|
|
|
-- 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 :: DBReadUq' [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 -> DBReadUq 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 -> DBReadUq 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
|