diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index bdb52de55..922d58f4c 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -127,7 +127,6 @@ AdminProblemSolved: Erledigt AdminProblemSolver: Bearbeitet von AdminProblemCreated: Erkannt AdminProblemInfo: Problembeschreibung -AdminProblemInfoTooltip: Nur Teile der folgenden englische Begriffe sind derzeit möglich: new-company, supervisor-new-company, supervisor-left-company, superior-change, newly-unsupervised und unknown AdminProblemsSolved n@Int: #{pluralDEeN n "Admin Problem"} als erledigt markiert AdminProblemsReopened n@Int: #{pluralDEeN n "Admin Problem"} erneut eröffnet AdminProblemNewCompany: Neue Firma über AVS automatisch erstellt; prüfen und ggf. Standardansprechpartner eintragen diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index cccdf50a3..96972ad87 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -127,7 +127,6 @@ AdminProblemSolved: Done AdminProblemSolver: Solved by AdminProblemCreated: Recognized AdminProblemInfo: Problem -AdminProblemInfoTooltip: Only parts of the following keys currently work here: new-company, supervisor-new-company, supervisor-left-company, superior-change, newly-unsupervised und unknown AdminProblemsSolved n: #{pluralENsN n "admin problem"} marked as solved AdminProblemsReopened n: #{pluralENsN n "admin problem"} reopened AdminProblemNewCompany: New company from AVS; verify and add default supervisors diff --git a/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg b/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg index 9512318eb..827732551 100644 --- a/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg +++ b/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg @@ -29,7 +29,7 @@ Remarks: Hinweis: ProfileNoSupervisor: Keine übergeordneten Ansprechpartner vorhanden ProfileSupervisor n@Int m@Int: #{n} #{pluralDE n "übergeordneter" "übergeordnete"} Ansprechpartner#{noneMoreDE m "" (", davon " <> tshow m <> " mit Benachrichtigungsumleitung")} -ProfileSupervisorRemark n@Int m@Int l@Int: #{m}/#{n} #{pluralDE m "übergeordneter" "übergeordnete"} Ansprechpartner mit Benachrichtigungsumleitung#{noneMoreDE l "" (", davon " <> tshow l <> " mit postalischer Benachrichtigung")} +ProfileSupervisorRemark n@Int m@Int l@Int: #{m} von #{n} #{pluralDE m "übergeordneter" "übergeordnete"} Ansprechpartner mit Benachrichtigungsumleitung#{noneMoreDE l "" (", davon " <> tshow l <> " mit postalischer Benachrichtigung")} ProfileNoSupervisee: Ist kein Ansprechpartner für irgendjemand ProfileSupervisee n@Int m@Int: Ist Ansprechpartner für #{n} #{pluralDE n "Person" "Personen"}#{noneMoreDE m "" (", davon " <> tshow m <> " mit Benachrichtigungsumleitung")} ProfileSuperviseeRemark n@Int m@Int: Dieser Nutzer ist Ansprechpartner für #{n} #{pluralDE n "Person" "Personen"}#{noneMoreDE m "" (", davon " <> tshow m <> " mit Benachrichtigungsumleitung")} diff --git a/messages/uniworx/categories/settings/personal_settings/en-eu.msg b/messages/uniworx/categories/settings/personal_settings/en-eu.msg index 3bbb8cec4..db67e3940 100644 --- a/messages/uniworx/categories/settings/personal_settings/en-eu.msg +++ b/messages/uniworx/categories/settings/personal_settings/en-eu.msg @@ -29,7 +29,7 @@ Remarks: Remark: ProfileNoSupervisor: Is not supervised by anynone ProfileSupervisor n m: #{pluralENsN n "supervisor"} #{noneMoreEN m "" ("with " <> tshow m <> " active notification rerouting")} -ProfileSupervisorRemark n@Int m@Int l@Int: #{m}/#{n} #{pluralENs m "supervisor"} with active notification rerouting#{noneMoreEN l "" (", and " <> tshow l <> "of these prefer postal notifications")} +ProfileSupervisorRemark n@Int m@Int l@Int: #{m} of #{n} #{pluralENs m "supervisor"} with active notification rerouting#{noneMoreEN l "" (", and " <> tshow l <> "of these prefer postal notifications")} ProfileNoSupervisee: Does not supervise anynone ProfileSupervisee n m: Supervises #{pluralENsN n "person"} #{noneMoreEN m "" ("with " <> tshow m <> " active notification rerouting")} ProfileSuperviseeRemark n m: This person supervises #{pluralENsN n "person"}#{noneMoreEN m "" (" with " <> tshow m <> " having active notifications rerouting to this user")} diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index dc927ec1d..4f8494fdf 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -688,6 +688,7 @@ infixl 8 ->. infixl 8 ->>. +-- Unsafe variant, see Database.Esqueleto.PostgreSQL.JSON for a safe version! (->>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value Text) (->>.) expr t = E.unsafeSqlBinOp "->>" expr $ E.val t diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 483c536b6..64c4acadd 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -9,8 +9,9 @@ module Handler.Admin import Import -- import Data.Either -import qualified Data.Set as Set -import qualified Data.Map as Map +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 @@ -316,7 +317,13 @@ resultUser :: Traversal' ProblemLogTableData (Entity User) resultUser = _dbrOutput . _3 . _Just mkProblemLogTable :: DB (FormResult (ProblemTableActionData, Set ProblemLogId), Widget) -mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..} +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 @@ -326,7 +333,7 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..} EL.on (solver E.?. UserId E.==. problem E.^. ProblemLogSolver) return (problem, solver, usr) dbtRowKey = queryProblem >>> (E.^. ProblemLogId) - dbtProj = dbtProjId + 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 @@ -349,14 +356,20 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..} dbtFilter = mconcat [ single ("user" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryUser) (E.?. UserDisplayName)) , single ("solver" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySolver) (E.?. UserDisplayName)) - , single ("problem" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "problem").(E.^. ProblemLogInfo))) , single ("company" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "company").(E.^. ProblemLogInfo))) , single ("solved" , FilterColumn . E.mkExactFilterLast $ views (to queryProblem) (E.isJust . (E.^. ProblemLogSolved))) + -- , single ("problem" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "problem").(E.^. ProblemLogInfo))) -- not stored in plaintext! + , single ("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 & setTooltip MsgAdminProblemInfoTooltip) + , 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) ] diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 69ee99847..a538160af 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -35,6 +35,7 @@ import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Legacy as EL (on,from) import qualified Database.Esqueleto.Utils as E +import qualified Database.Esqueleto.PostgreSQL as E import qualified Data.Text as Text import Data.List (inits) @@ -605,6 +606,7 @@ tableWidget :: TableHasData -> Widget tableWidget = snd -} +-- | Given a header message, a bool and widget; display widget and header only if the boolean is true maybeTable :: (RenderMessage UniWorX a) => a -> (Bool, Widget) -> Widget maybeTable m = maybeTable' m Nothing Nothing @@ -675,14 +677,24 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do qualificationsTable <- mkQualificationsTable now uid -- Tabelle mit allen Qualifikationen supervisorsTable <- mkSupervisorsTable uid -- Tabelle mit allen Supervisors superviseesTable <- mkSuperviseesTable actualPrefersPostal uid -- Tabelle mit allen Supervisees - let supervisorsWgt :: Widget = - let ((getSum -> nrSupers, getSum -> nrReroute, getSum -> nrLetter), tWgt) = supervisorsTable - in maybeTable' (MsgProfileSupervisor nrSupers nrReroute) (Just MsgProfileNoSupervisor) - (toMaybe (nrReroute > 0) $ msg2widget $ MsgProfileSupervisorRemark nrSupers nrReroute nrLetter) (nrSupers > 0, tWgt) + countUnderlings <- E.select $ do + spr <- E.from $ E.table @UserSupervisor + E.where_ $ spr E.^. UserSupervisorSupervisor E.==. E.val uid + return (E.countRows, E.count (spr E.^. UserSupervisorId) `E.filterWhere` (spr E.^. UserSupervisorRerouteNotifications)) + countSupervisors <- E.select $ do + spr <- E.from $ E.table @UserSupervisor + E.where_ $ spr E.^. UserSupervisorUser E.==. E.val uid + return (E.countRows, E.count (spr E.^. UserSupervisorId) `E.filterWhere` (spr E.^. UserSupervisorRerouteNotifications)) + let errorCount ((E.Value x, E.Value y):_) = (x,y) + errorCount _ = (-1,-1) + supervisorsWgt :: Widget = + let (nrSupers, nrSupersReroute) = errorCount countSupervisors + in maybeTable' (MsgProfileSupervisor nrSupers nrSupersReroute) (Just MsgProfileNoSupervisor) + (toMaybe (nrSupersReroute > 0) $ msg2widget $ MsgProfileSupervisorRemark nrSupers nrSupersReroute 0) (nrSupers > 0, supervisorsTable) superviseesWgt :: Widget = - let ((getSum -> nrSubs, getSum -> nrReroute), tWgt) = superviseesTable - in maybeTable' (MsgProfileSupervisee nrSubs nrReroute) (Just MsgProfileNoSupervisee) - (toMaybe (nrReroute > 0) $ msg2widget $ MsgProfileSuperviseeRemark nrSubs nrReroute) (nrSubs > 0, tWgt) + let (nrUnderlings, nrUndersReroute) = errorCount countUnderlings + in maybeTable' (MsgProfileSupervisee nrUnderlings nrUndersReroute) (Just MsgProfileNoSupervisee) + (toMaybe (nrUndersReroute > 0) $ msg2widget $ MsgProfileSuperviseeRemark nrUnderlings nrUndersReroute) (nrUnderlings > 0, superviseesTable) -- let examTable, ownTutorialTable, tutorialTable :: Widget -- examTable = i18n MsgPersonalInfoExamAchievementsWip -- ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip @@ -1093,10 +1105,10 @@ instance HasUser TblSupervisorData where hasUser = _dbrOutput . _1 . _entityVal -- | Table listing all supervisor of the given user -mkSupervisorsTable :: UserId -> DB ((Sum Int, Sum Int, Sum Int), Widget) -mkSupervisorsTable uid = dbTableWidget validator DBTable{..} +mkSupervisorsTable :: UserId -> DB Widget +mkSupervisorsTable uid = dbTableWidget' validator DBTable{..} where - dbtIdent = "userSupervisedBy" :: Text + dbtIdent = "supervisors" :: Text dbtStyle = def dbtSQLQuery (usr `E.InnerJoin` spr) = do @@ -1114,8 +1126,7 @@ mkSupervisorsTable uid = dbTableWidget validator DBTable{..} , sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row -> let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications isLetter = row ^. resultUser . _userPrefersPostal - in tellCell (Sum 1, Sum $ fromEnum isReroute, Sum $ fromEnum $ isReroute && isLetter) $ - if isReroute + in if isReroute then iconCell IconReroute <> spacerCell <> iconFixedCell (iconLetterOrEmail isLetter) else mempty , sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c) @@ -1146,10 +1157,10 @@ mkSupervisorsTable uid = dbTableWidget validator DBTable{..} -- | Table listing all persons supervised by the given user -mkSuperviseesTable ::Bool -> UserId -> DB ((Sum Int, Sum Int), Widget) -mkSuperviseesTable userPrefersPostal uid = dbTableWidget validator DBTable{..} +mkSuperviseesTable ::Bool -> UserId -> DB Widget +mkSuperviseesTable userPrefersPostal uid = dbTableWidget' validator DBTable{..} where - dbtIdent = "userSupervisedBy" :: Text + dbtIdent = "supervisees" :: Text dbtStyle = def dbtSQLQuery (usr `E.InnerJoin` spr) = do @@ -1167,7 +1178,7 @@ mkSuperviseesTable userPrefersPostal uid = dbTableWidget validator DBTable{..} -- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b , sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row -> let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications - in tellCell (Sum 1, Sum $ fromEnum isReroute) $ boolCell isReroute $ iconCell IconReroute <> iconCellLetterOrEmail + in boolCell isReroute $ iconCell IconReroute <> iconCellLetterOrEmail , sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c) , sortable (Just "reason") (i18nCell MsgTableReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell ] diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 11a12edc2..b7a112d86 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -166,6 +166,7 @@ redirectKeepGetParams route = liftHandler $ do adminProblemCell :: (IsDBTable m a) => AdminProblem -> DBCell m a -- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns +-- WARNING: this function should correspond with adminProblem2Text adminProblemCell AdminProblemNewCompany{} = i18nCell MsgAdminProblemNewCompany adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute} @@ -184,6 +185,35 @@ adminProblemCell AdminProblemUnknown{adminProblemText} company2msg :: CompanyId -> SomeMessage UniWorX company2msg = text2message . ciOriginal . unCompanyKey +-- used to enable filtering, must correspond to function adminProblemCell shown above +adminProblem2Text :: AdminProblem -> DB Text +adminProblem2Text adprob = do + MsgRenderer mr <- getMsgRenderer + case adprob of + AdminProblemNewCompany{} + -> return $ mr MsgAdminProblemNewCompany + AdminProblemSupervisorNewCompany{adminProblemSupervisorReroute, adminProblemCompanyNew} + -> return $ mr $ SomeMessages [SomeMessage $ MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute, company2msg adminProblemCompanyNew] + AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute} + -> return $ mr (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute) + AdminProblemCompanySuperiorChange{adminProblemUserOld=mbuid} + -> maybeT (return $ mr MsgAdminProblemCompanySuperiorChange) $ do + uid <- MaybeT $ pure mbuid + User{userDisplayName = udn, userSurname = usn} <- MaybeT $ get uid + pure $ mr $ SomeMessages [SomeMessage MsgAdminProblemCompanySuperiorChange, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn] + -- AdminProblemCompanySuperiorChange{adminProblemUserOld=Nothing} + -- -> return $ mr MsgAdminProblemCompanySuperiorChange + -- AdminProblemCompanySuperiorChange{adminProblemUserOld=Just uid} + -- -> get uid >>= \case + -- Nothing -> + -- return $ mr MsgAdminProblemCompanySuperiorChange + -- Just User{userDisplayName = udn, userSurname = usn} -> + -- return $ mr $ SomeMessages [SomeMessage MsgAdminProblemCompanySuperiorChange, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn] + AdminProblemNewlyUnsupervised{adminProblemCompanyNew} + -> return $ mr $ SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, company2msg adminProblemCompanyNew] + AdminProblemUnknown{adminProblemText} + -> return $ "Problem: " <> adminProblemText + msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX) msgAdminProblem AdminProblemNewCompany{adminProblemCompany=comp} = return $ SomeMessages [SomeMessage MsgAdminProblemNewCompany, text2message ": ", company2msg comp] diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 62d147f4b..02ccc8857 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -32,6 +32,7 @@ spacerCell = cell [whamlet| |] semicolonCell :: IsDBTable m a => DBCell m a semicolonCell = cell [whamlet|; |] +-- | Contribute to DBResult. BEWARE: only shown cells are executed; pagination makes tellCell useless for rowcounts; instead use dbtProj for computations on all rows regardless of pagination tellCell :: IsDBTable m a => a -> DBCell m a -> DBCell m a tellCell = flip mappend . writerCell . tell diff --git a/src/Utils/Pandoc.hs b/src/Utils/Pandoc.hs index d2030d2a3..fbe00080d 100644 --- a/src/Utils/Pandoc.hs +++ b/src/Utils/Pandoc.hs @@ -17,7 +17,10 @@ import qualified Text.Pandoc as P markdownToHtml :: Html -> Either P.PandocError Html -markdownToHtml html = P.runPure $ P.writeHtml5 htmlWriterOptions =<< P.readMarkdown markdownReaderOptions (toStrict $ renderHtml html) +markdownToHtml html = P.runPure $ P.writeHtml5 htmlWriterOptions =<< P.readMarkdown markdownReaderOptions (toStrict $ renderHtml html) + +htmlToPlainText :: Html -> Either P.PandocError Text +htmlToPlainText html = P.runPure $ P.writePlain htmlWriterOptions =<< P.readHtml markdownReaderOptions (toStrict $ renderHtml html) plainTextToHtml :: Text -> Html plainTextToHtml text = fromRight (toMarkup text) $ P.runPure $