Merge branch 'fradrive/jost' into 'master'

Fradrive/jost - two minor fixes

See merge request fradrive/fradrive!40

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

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

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")}

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")}

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
 

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.Set  as Set
-import qualified Data.Map as Map
+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)
       ]

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 =
+  countUnderlings <- E.select $ do
-        let ((getSum -> nrSupers, getSum -> nrReroute, getSum -> nrLetter), tWgt) = supervisorsTable
+    spr <- E.from $ E.table @UserSupervisor
-        in  maybeTable' (MsgProfileSupervisor nrSupers nrReroute) (Just MsgProfileNoSupervisor)
+    E.where_ $ spr E.^. UserSupervisorSupervisor E.==. E.val uid
-                        (toMaybe (nrReroute > 0) $ msg2widget $ MsgProfileSupervisorRemark nrSupers nrReroute nrLetter) (nrSupers > 0, tWgt)
+    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
+        let (nrUnderlings, nrUndersReroute) = errorCount countUnderlings
-        in  maybeTable' (MsgProfileSupervisee nrSubs nrReroute) (Just MsgProfileNoSupervisee)
+        in maybeTable' (MsgProfileSupervisee nrUnderlings nrUndersReroute) (Just MsgProfileNoSupervisee)
-                        (toMaybe (nrReroute > 0) $ msg2widget $ MsgProfileSuperviseeRemark nrSubs nrReroute) (nrSubs > 0, tWgt)
+                       (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 :: UserId -> DB Widget
-mkSupervisorsTable uid = dbTableWidget validator DBTable{..}
+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) $
+            in  if isReroute
-                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 ::Bool -> UserId -> DB Widget
-mkSuperviseesTable userPrefersPostal uid = dbTableWidget validator DBTable{..}
+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
         ]

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]

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
 

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 $