diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index eb6cfe753..9c3c020db 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Winnie Ros +# SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Winnie Ros ,Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -121,6 +121,15 @@ ProblemsAvsSynchHeading: Synchronisation AVS Fahrberechtigungen ProblemsAvsErrorHeading: Fehlermeldungen ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit +AdminProblemSolved: Erledigt +AdminProblemSolver: Bearbeitet von +AdminProblemCreated: Zeitpunkt +AdminProblemInfo: Problembeschreibung +AdminProblemsSolved n@Int: #{pluralDEeN n "Admin Probleme"} als erledigt markiert +AdminProblemNewCompany: Neue Firma aus AVS automatisch erstellt; prüfen und ggf. Standardansprechpartner eintragen +ProblemTableMarkSolved: Als erledigt markieren +ProblemTableUnknownTodo: Unbekanntes ToDo Problem + InterfacesOk: Schnittstellen sind ok. InterfacesFail n@Int: #{pluralDEeN n "Schnittstellenproblem"}! InterfaceStatus !ident-ok: Status diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index 13f35ed9f..1cece93e8 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Sarah Vaupel ,Winnie Ros +# SPDX-FileCopyrightText: 2022-24 Sarah Vaupel ,Winnie Ros ,Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -121,6 +121,15 @@ ProblemsAvsSynchHeading: Synchronisation AVS Driving Licences ProblemsAvsErrorHeading: Error Log ProblemsInterfaceSince: Only considering successes and errors since +AdminProblemSolved: Done +AdminProblemSolver: Solved by +AdminProblemCreated: Creation time +AdminProblemInfo: Problem +AdminProblemsSolved n: #{pluralENsN n "admin problem"} marked as solved +AdminProblemNewCompany: New company from AVS; verify and add default supervisors +ProblemTableMarkSolved: Mark done +ProblemTableUnknownTodo: Unknown todo problem + InterfacesOk: Interfaces are ok. InterfacesFail n: #{pluralENsN n "interface problem"}! InterfaceStatus: Status diff --git a/models/audit.model b/models/audit.model index 42364c829..e61f11389 100644 --- a/models/audit.model +++ b/models/audit.model @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later diff --git a/routes b/routes index 34ad73505..b3871ef8c 100644 --- a/routes +++ b/routes @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -70,7 +70,7 @@ /admin/avs AdminAvsR GET POST /admin/avs/#CryptoUUIDUser AdminAvsUserR GET /admin/ldap AdminLdapR GET POST -/admin/problems AdminProblemsR GET +/admin/problems AdminProblemsR GET POST /admin/problems/no-contact ProblemUnreachableR GET /admin/problems/no-avs-id ProblemWithoutAvsId GET /admin/problems/r-without-f ProblemFbutNoR GET diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 6f5831a37..2933edcdf 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -1,16 +1,18 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Audit.Types ( Transaction(..) , AdminProblem(..) + , decodeAdminProblem ) where import ClassyPrelude.Yesod hiding (derivePersistFieldJSON) import Model.Types.TH.JSON import Model +import Data.Aeson import Data.Aeson.TH import Utils.PathPiece @@ -264,6 +266,8 @@ data AdminProblem { adminProblemCompany :: CompanyId } | AdminProblemUnknown -- placeholder to avoid hlint newtype suggestion while we have few problems yet + { adminProblemText :: Text + } deriving (Eq, Ord, Read, Show, Generic) deriveJSON defaultOptions @@ -274,3 +278,8 @@ deriveJSON defaultOptions } ''AdminProblem derivePersistFieldJSON ''AdminProblem + +decodeAdminProblem :: Value -> AdminProblem +decodeAdminProblem v = case fromJSON v of + Error msg -> AdminProblemUnknown $ pack msg + Success p -> p diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index def7ff98f..44f0ac35f 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -11,14 +11,17 @@ import Import import Jobs -- 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 @@ -33,12 +36,34 @@ 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 + | ProblemTableUnknownTodo -- Placeholder, remove later, inculding associated Message + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + deriving anyclass (Universe, Finite) + +nullaryPathPiece ''ProblemTableAction $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''ProblemTableAction id + +data ProblemTableActionData = ProblemTableMarkSolvedData + | ProblemTableUnknownTodoData -- Placeholder, remove later + deriving (Eq, Ord, Read, Show, Generic) + + +-- Handlers getAdminR :: Handler Html getAdminR = redirect AdminProblemsR -getAdminProblemsR :: Handler Html -getAdminProblemsR = do +getAdminProblemsR, postAdminProblemsR :: Handler Html +getAdminProblemsR = handleAdminProblems Nothing + +handleAdminProblems :: Maybe Widget -> Handler Html +handleAdminProblems mbProblemTable = do now <- liftIO getCurrentTime let nowaday = utctDay now cutOffOldDays = 1 @@ -55,15 +80,16 @@ getAdminProblemsR = do flagNonZero n | n <= 0 = flagError True | otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n)) - (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, (interfaceOks, interfaceTable)) <- runDB $ (,,,,,) + (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 + <*> 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) @@ -86,11 +112,28 @@ getAdminProblemsR = do -- ] 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 + let procProblems :: (ProblemTableActionData, Set ProblemLogId) -> Handler () + procProblems (ProblemTableMarkSolvedData, pids) = do + mauid <- maybeAuthId + now <- liftIO getCurrentTime + (fromIntegral -> oks) <- runDB $ updateWhereCount [ProblemLogSolved ==. Nothing, ProblemLogId <-. toList pids] + [ProblemLogSolved =. Just now, ProblemLogSolver =. mauid] + let no_req = Set.size pids + mkind = if oks < no_req || no_req < 0 then Warning else Success + addMessageI mkind $ MsgAdminProblemsSolved oks + when (oks > 0) $ redirect AdminProblemsR -- reload to update all tables + procProblems (ProblemTableUnknownTodoData, _) = return () -- just a no-op + formResult problemLogRes procProblems + handleAdminProblems $ Just problemLogTable + getProblemUnreachableR :: Handler Html getProblemUnreachableR = do @@ -238,3 +281,84 @@ retrieveDriversRWithoutF now = do 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)) +queryProblem :: ProblemLogTableExpr -> E.SqlExpr (Entity ProblemLog) +queryProblem = $(E.sqlLOJproj 2 1) + +querySolver :: ProblemLogTableExpr -> E.SqlExpr (Maybe (Entity User)) +querySolver = $(E.sqlLOJproj 2 2) + +type ProblemLogTableData = DBRow (Entity ProblemLog, Maybe (Entity User)) +resultProblem :: Lens' ProblemLogTableData (Entity ProblemLog) +resultProblem = _dbrOutput . _1 + +resultSolver :: Traversal' ProblemLogTableData (Entity User) +resultSolver = _dbrOutput . _2 . _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) -> do + EL.on (problem E.^. ProblemLogSolver E.==. solver E.?. UserId) + return (problem, solver) + 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 "solved") (i18nCell MsgAdminProblemSolver) $ \( 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 ("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 + ] + 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 +adminProblemCell AdminProblemNewCompany{} = i18nCell MsgAdminProblemNewCompany +adminProblemCell AdminProblemUnknown{adminProblemText} = textCell $ "Problem: " <> adminProblemText diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 3994b81f0..48c2e4444 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros +-- SPDX-FileCopyrightText: 2022-24 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -79,6 +79,7 @@ ifCell decision cTrue cFalse x linkEmptyCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a linkEmptyCell = anchorCell +-- not to be confused with i18nCell msgCell :: (ToMessage t, IsDBTable m a) => t -> DBCell m a msgCell = textCell . toMessage @@ -356,14 +357,18 @@ courseCell Course{..} = anchorCell link name `mappend` desc |] companyCell :: IsDBTable m a => CompanyShorthand -> CompanyName -> Bool -> DBCell m a -companyCell cid cname isSupervisor = anchorCell link name +companyCell csh cname isSupervisor = anchorCell link name where - link = FirmUsersR cid + link = FirmUsersR csh corg = ciOriginal cname - name + name | isSupervisor = text2markup (corg <> " ") <> icon IconSupervisor | otherwise = text2markup corg +companyIdCell :: IsDBTable m a => CompanyId -> DBCell m a +companyIdCell cid = companyCell csh csh False + where + csh = unCompanyKey cid qualificationCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c qualificationCell (view hasQualification -> Qualification{..}) = anchorCell link name diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index fe14123eb..91f731f75 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -1689,7 +1689,7 @@ widgetColonnade :: Colonnade h r (DBCell (HandlerFor UniWorX) x) -> Colonnade h r (DBCell (HandlerFor UniWorX) x) widgetColonnade = id --- | force the column list type for tables that cotain forms, especially those constructed with dbSelect, avoids explicit type signatures +-- | force the column list type for tables that contain forms, especially those constructed with dbSelect, avoids explicit type signatures formColonnade :: Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a)) -> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a)) formColonnade = id diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index af3e2bb7b..55228823d 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -13,7 +13,7 @@ import Model import Model.Rating import qualified ClassyPrelude.Yesod as Yesod (HasHttpManager(..)) -import Audit.Types (AdminProblem(..)) +import Audit.Types (AdminProblem(..), decodeAdminProblem) import Control.Lens as Utils.Lens hiding ( (<.>) @@ -313,8 +313,11 @@ makeLenses_ ''AuthorshipStatementDefinition makeLenses_ ''PrintJob makeLenses_ ''InterfaceLog -makeLenses_ ''ProblemLog makeLenses_ ''AdminProblem +makeLenses_ ''ProblemLog + +_problemLogAdminProblem :: Getter ProblemLog AdminProblem +_problemLogAdminProblem = _problemLogInfo . to decodeAdminProblem -------------------------- -- Fields for `UniWorX` -- diff --git a/templates/admin-problems.hamlet b/templates/admin-problems.hamlet index b2a48143b..3909155cf 100644 --- a/templates/admin-problems.hamlet +++ b/templates/admin-problems.hamlet @@ -63,5 +63,10 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later _{MsgInterfacesOk} ^{interfaceTable} - +
+

+ _{MsgProblemsHeadingMisc} +
+

+ ^{problemLogTable} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 12bd24c1a..5b4606153 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -785,6 +785,9 @@ fillDb = do void . insert $ PrintJob "TestJob9" "AckTestJob9" "job9" "No Text herein." (n_day' (-1)) Nothing (Just svaupel) Nothing Nothing Nothing (Just $ LmsIdent "abcdefg") void . insert $ PrintJob "TestJob0" "AckTestJob0" "job0" "No Text herein." (n_day' (-3)) Nothing Nothing Nothing Nothing Nothing (Just $ LmsIdent "hijklmn") + insert_ $ ProblemLog now (toJSON $ AdminProblemNewCompany fraportAg) Nothing Nothing + insert_ $ ProblemLog now (toJSON $ AdminProblemNewCompany ffacil ) Nothing Nothing + insert_ $ ProblemLog now (toJSON $ AdminProblemUnknown "This is a test problem only.") Nothing Nothing let examLabels = Map.fromList