diff --git a/frontend/src/utils/exam-correct/exam-correct.js b/frontend/src/utils/exam-correct/exam-correct.js index 7685c00e1..a20df8344 100644 --- a/frontend/src/utils/exam-correct/exam-correct.js +++ b/frontend/src/utils/exam-correct/exam-correct.js @@ -301,7 +301,7 @@ export class ExamCorrect { users: [user], status: STATUS.LOADING, }; - if (results && results !== {}) rowInfo.results = results; + if (results && Object.keys(results).length > 0) rowInfo.results = results; if (result !== undefined) rowInfo.result = result; this._addRow(rowInfo); diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index e24dcad0b..3bf0ac7a5 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -149,4 +149,10 @@ InterfaceSubtype: Betreffend InterfaceWrite: Schreibend InterfaceSuccess: Rückmeldung InterfaceInfo: Nachricht -InterfaceFreshness: Prüfungszeitraum (h) \ No newline at end of file +InterfaceFreshness: Prüfungszeitraum (h) +ConfigInterfacesHeading: Konfiguration Warnung Schnittstellen + +IWTActAdd: Hinzufügen +IWTActDelete: Entfernen +InterfaceWarningAdded: Schnittstellenwarnungszeit hinzugefügt oder geändert +InterfaceWarningDeleted n@Int: #{pluralDEeN n "Schnittstellenwarnungszeit"} gelöscht \ No newline at end of file diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index d8f6ca0d7..dff532fa9 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -149,4 +149,10 @@ InterfaceSubtype: Affecting InterfaceWrite: Write InterfaceSuccess: Returned InterfaceInfo: Message -InterfaceFreshness: Check hours \ No newline at end of file +InterfaceFreshness: Check hours +ConfigInterfacesHeading: Configuration interface warnings + +IWTActAdd: Add +IWTActDelete: Delete +InterfaceWarningAdded: Interface warning time added/changed +InterfaceWarningDeleted n: #{pluralENsN n "interface warning time"} deleted \ No newline at end of file diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 7d44de1cf..8597a7c2c 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -79,6 +79,7 @@ TableCompany: Firma TableCompanyFilter: Firma oder Nummer TableCompanyShort: Firmenkürzel TableCompanies: Firmen +TablePrimeCompany: Primäre Firma TableCompanyNo: Firmennummer TableCompanyNos: Firmennummern TableCompanyUser: Firmenangehöriger diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 830a5c441..d489426c1 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -79,6 +79,7 @@ TableCompany: Company TableCompanyFilter: Company/Nr TableCompanyShort: Company shorthand TableCompanies: Companies +TablePrimeCompany: Primary company TableCompanyNo: Company number TableCompanyNos: Company numbers TableCompanyUser: Associate diff --git a/routes b/routes index 1030745a2..98042a4a7 100644 --- a/routes +++ b/routes @@ -76,6 +76,7 @@ /admin/problems/r-without-f ProblemFbutNoR GET /admin/problems/avs ProblemAvsSynchR GET POST /admin/problems/avs/errors ProblemAvsErrorR GET +/admin/config/interfaces ConfigInterfacesR GET POST /comm CommCenterR GET /comm/email MailCenterR GET POST diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 6eebe6da3..6c33958e3 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -122,6 +122,7 @@ breadcrumb ProblemWithoutAvsId = i18nCrumb MsgProblemsNoAvsIdHeading $ Just breadcrumb ProblemFbutNoR = i18nCrumb MsgProblemsRWithoutFHeading $ Just AdminProblemsR breadcrumb ProblemAvsSynchR = i18nCrumb MsgProblemsAvsSynchHeading $ Just AdminProblemsR breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just AdminProblemsR +breadcrumb ConfigInterfacesR = i18nCrumb MsgConfigInterfacesHeading $ Just AdminProblemsR breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing breadcrumb FirmsCommR{} = i18nCrumb MsgMenuFirmsComm $ Just FirmAllR @@ -2533,6 +2534,20 @@ pageActions AdminCrontabR = return } ] +pageActions AdminProblemsR = return + [ NavPageActionPrimary + { navLink = defNavLink MsgConfigInterfacesHeading ConfigInterfacesR + , navChildren = [] + } + , NavPageActionPrimary + { navLink = defNavLink MsgProblemsAvsSynchHeading ProblemAvsSynchR + , navChildren = [] + } + , NavPageActionSecondary + { navLink = defNavLink MsgProblemsAvsErrorHeading ProblemAvsErrorR + } + ] + pageActions _ = return [] submissionList :: ( MonadIO m diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index 00de8e004..de9a44b18 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -8,12 +8,14 @@ module Handler.Health.Interface getHealthInterfaceR , mkInterfaceLogTable , runInterfaceChecks + , getConfigInterfacesR, postConfigInterfacesR ) where import Import --- import qualified Data.Set as Set +import qualified Data.Set as Set +import qualified Data.Map as Map import qualified Data.Text as Text import Handler.Utils import Handler.Utils.Concurrent @@ -24,6 +26,8 @@ import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Legacy as EL (on) import qualified Database.Persist.Sql as E (deleteWhereCount) +defaultInterfaceWarnHours :: Int +defaultInterfaceWarnHours = 3 * 24 -- if no warn time can be found, use 3 days instead -- | identify a wildcard argument wc2null :: Text -> Maybe Text @@ -148,7 +152,7 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do -- E.where_ $ E.not_ (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- BAD All missing, except for "Printer" "F" -- E.where_ $ E.not_ $ E.parens (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- WORKS OKAY -- E.where_ $ ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||. ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F") -- WORKS OKAY - let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead + let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val defaultInterfaceWarnHours) -- if no default time is set, use a default instead return (ilog, ihour) queryILog :: (E.SqlExpr (Entity InterfaceLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity InterfaceHealth))) -> E.SqlExpr (Entity InterfaceLog) @@ -258,3 +262,140 @@ avsInterfaceCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "AVS" ( -- lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch] writeAvsSynchStats Nothing =<< mkBadInfo badRows badTime _ -> return () + + + +data IWTableAction + = IWTActAdd + | IWTActDelete + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + +instance Universe IWTableAction +instance Finite IWTableAction +nullaryPathPiece ''IWTableAction $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''IWTableAction id + +data IWTableActionData + = IWTActAddData + { iwtActInterface :: Text + , iwtActSubtype :: Maybe Text + , iwtActWrite :: Maybe Bool + , iwtActHours :: Int + } + | IWTActDeleteData + deriving (Eq, Ord, Read, Show, Generic) + +type IWTableExpr = E.SqlExpr (Entity InterfaceHealth) + +queryInterfaceHealth :: IWTableExpr -> E.SqlExpr (Entity InterfaceHealth) +queryInterfaceHealth = id + +type IWTableData = DBRow (Entity InterfaceHealth) + +resultInterfaceHealth :: Lens' IWTableData (Entity InterfaceHealth) +resultInterfaceHealth = _dbrOutput + +wildcardCell :: IsDBTable m b => (a -> DBCell m b) -> Maybe a -> DBCell m b +wildcardCell _ Nothing = textCell "*" +wildcardCell c (Just x) = c x + +mkInterfaceWarnTable :: DB (FormResult (IWTableActionData, Set InterfaceHealthId), Widget) +mkInterfaceWarnTable = do + let + mkOption :: E.Value Text -> Option Text + mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t } + getSuggestion pj = E.select $ E.distinct $ do + il <- E.from $ E.table @InterfaceLog + let res = il E.^. pj + E.orderBy [E.asc res] + pure res + suggestionInterface :: HandlerFor UniWorX (OptionList Text) + suggestionInterface = mkOptionList . fmap mkOption <$> runDB (getSuggestion InterfaceLogInterface) + suggestionSubtype :: HandlerFor UniWorX (OptionList Text) + suggestionSubtype = mkOptionList . fmap mkOption <$> runDB (getSuggestion InterfaceLogSubtype) + dbtIdent = "interface-warnings" :: Text + dbtSQLQuery :: IWTableExpr -> E.SqlQuery IWTableExpr + dbtSQLQuery = return + dbtRowKey = queryInterfaceHealth >>> (E.^. InterfaceHealthId) + dbtProj = dbtProjId + dbtColonnade = formColonnade $ mconcat + [ dbSelect (applying _2) id (return . view (resultInterfaceHealth . _entityKey)) + , sortable (Just "interface") (i18nCell MsgInterfaceName ) $ \(view (resultInterfaceHealth . _entityVal . _interfaceHealthInterface) -> n) -> textCell n + , sortable (Just "subtype") (i18nCell MsgInterfaceSubtype ) $ wildcardCell textCell . view (resultInterfaceHealth . _entityVal . _interfaceHealthSubtype ) + , sortable (Just "write") (i18nCell MsgInterfaceWrite ) $ wildcardCell (`ifIconCell` IconEdit) . view (resultInterfaceHealth . _entityVal . _interfaceHealthWrite ) + , sortable (Just "hours") (i18nCell MsgInterfaceFreshness ) $ numCell . view (resultInterfaceHealth . _entityVal . _interfaceHealthHours ) + , sortable (Just "hours") (i18nCell MsgInterfaceFreshness ) $ textCell . formatDiffHours . view (resultInterfaceHealth . _entityVal . _interfaceHealthHours) + ] + dbtSorting = mconcat + [ singletonMap "interface" $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthInterface) + , singletonMap "subtype" $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthSubtype) + , singletonMap "write" $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthWrite) + , singletonMap "time" $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthHours) + ] + dbtFilter = mempty + dbtFilterUI = mempty + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtParams = DBParamsForm + { dbParamsFormMethod = POST + , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute + , dbParamsFormAttrs = [] + , dbParamsFormSubmit = FormSubmit + , dbParamsFormAdditional + = let acts :: Map IWTableAction (AForm Handler IWTableActionData) + acts = mconcat + [ singletonMap IWTActAdd $ IWTActAddData + <$> apreq (textField & cfStrip & addDatalist suggestionInterface) (fslI MsgInterfaceName) Nothing + <*> aopt (textField & cfStrip & addDatalist suggestionSubtype) (fslI MsgInterfaceSubtype) Nothing + <*> aopt boolField' (fslI MsgInterfaceWrite) Nothing + <*> apreq intField (fslI MsgInterfaceFreshness) Nothing + , singletonMap IWTActDelete $ pure IWTActDeleteData + ] + in renderAForm FormStandard + $ (, mempty) . First . Just + <$> multiActionA acts (fslI MsgTableAction) Nothing + , dbParamsFormEvaluate = liftHandler . runFormPost + , dbParamsFormResult = id + , dbParamsFormIdent = def + } + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + postprocess :: FormResult (First IWTableActionData, DBFormResult InterfaceHealthId Bool IWTableData) + -> FormResult ( IWTableActionData, Set InterfaceHealthId) + postprocess inp = do + (First (Just act), jobMap) <- inp + let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap + return (act, jobSet) + psValidator = def & defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"] + over _1 postprocess <$> dbTable psValidator DBTable{..} + +getConfigInterfacesR, postConfigInterfacesR :: Handler Html +getConfigInterfacesR = postConfigInterfacesR +postConfigInterfacesR = do + + -- 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 + ((interfaceOks, interfaceTable), (warnRes, configTable)) <- runDB $ (,) + <$> mkInterfaceLogTable flagError mempty + <*> mkInterfaceWarnTable + let interfacesBadNr = length $ filter (not . snd) interfaceOks + formResult warnRes $ \case + (IWTActAddData{..}, _) -> do + void $ runDB $ upsertBy + (UniqueInterfaceHealth iwtActInterface iwtActSubtype iwtActWrite) + ( InterfaceHealth iwtActInterface iwtActSubtype iwtActWrite iwtActHours) + [InterfaceHealthHours =. iwtActHours] + addMessageI Success MsgInterfaceWarningAdded + reloadKeepGetParams ConfigInterfacesR + (IWTActDeleteData, ihids) -> do + runDB $ mapM_ delete ihids + addMessageI Success $ MsgInterfaceWarningDeleted $ Set.size ihids + reloadKeepGetParams ConfigInterfacesR + + siteLayoutMsg MsgConfigInterfacesHeading $ do + setTitleI MsgConfigInterfacesHeading + let defWarnTime = formatDiffHours defaultInterfaceWarnHours + $(i18nWidgetFile "config-interfaces") \ No newline at end of file diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 27fd41991..f02c86734 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -220,7 +220,6 @@ data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc.. { ltcDisplayName :: UserDisplayName , ltcEmail :: UserEmail , ltcCompany :: Maybe Text - , ltcCompanyNumbers :: CsvSemicolonList Int , ltcValidUntil :: Day , ltcLastRefresh :: Day , ltcFirstHeld :: Day @@ -242,8 +241,7 @@ ltcExample :: LmsTableCsv ltcExample = LmsTableCsv { ltcDisplayName = "Max Mustermann" , ltcEmail = "m.mustermann@example.com" - , ltcCompany = Just "Example Brothers LLC, SecondaryJobs Inc" - , ltcCompanyNumbers = CsvSemicolonList [27,69] + , ltcCompany = Just "Example Brothers LLC" , ltcValidUntil = succ compDay , ltcLastRefresh = compDay , ltcFirstHeld = pred $ pred compDay @@ -285,8 +283,7 @@ instance CsvColumnsExplained LmsTableCsv where csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList [ ('ltcDisplayName , SomeMessage MsgLmsUser) , ('ltcEmail , SomeMessage MsgTableLmsEmail) - , ('ltcCompany , SomeMessage MsgTableCompanies) - , ('ltcCompanyNumbers , SomeMessage MsgTableCompanyNos) + , ('ltcCompany , SomeMessage MsgTablePrimeCompany) , ('ltcValidUntil , SomeMessage MsgLmsQualificationValidUntil) , ('ltcLastRefresh , SomeMessage MsgTableQualificationLastRefresh) , ('ltcFirstHeld , SomeMessage MsgTableQualificationFirstHeld) @@ -320,7 +317,7 @@ queryQualBlock :: LmsTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBloc queryQualBlock = $(sqlLOJproj 2 2) -type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), [Entity UserCompany], E.Value Bool) +type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), E.Value (Maybe CompanyId), E.Value Bool) resultQualUser :: Lens' LmsTableData (Entity QualificationUser) resultQualUser = _dbrOutput . _1 @@ -337,8 +334,8 @@ resultQualBlock = _dbrOutput . _4 . _Just resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime] resultPrintAck = _dbrOutput . _5 . _unValue . _Just -resultCompanyUser :: Lens' LmsTableData [Entity UserCompany] -resultCompanyUser = _dbrOutput . _6 +resultCompanyId :: Traversal' LmsTableData CompanyId +resultCompanyId = _dbrOutput . _6 . _unValue . _Just resultValidQualification :: Lens' LmsTableData Bool resultValidQualification = _dbrOutput . _7 . _unValue @@ -406,6 +403,7 @@ lmsTableQuery :: UTCTime -> QualificationId -> LmsTableExpr , E.SqlExpr (Entity LmsUser) , E.SqlExpr (Maybe (Entity QualificationUserBlock)) , E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs + , E.SqlExpr (E.Value (Maybe CompanyId)) , E.SqlExpr (E.Value Bool) ) lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do @@ -421,12 +419,16 @@ lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.Left E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification -- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken! let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do - E.where_ $ E.isJust (pj E.^. PrintJobLmsUser) - E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser)) - let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on! - pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted type of subSelect does not seem to support this! - E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder - return (qualUser, user, lmsUser, qualBlock, printAcknowledged, validQualification now qualUser) + E.where_ $ E.isJust (pj E.^. PrintJobLmsUser) + E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser)) + let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on! + pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted type of subSelect does not seem to support this! + E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder + primeComp = E.subSelect . E.from $ \uc -> do + E.where_ $ user E.^. UserId E.==. uc E.^. UserCompanyUser + E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany] + return (uc E.^. UserCompanyCompany) + return (qualUser, user, lmsUser, qualBlock, printAcknowledged, primeComp, validQualification now qualUser) mkLmsTable :: ( Functor h, ToSortable h @@ -435,25 +437,26 @@ mkLmsTable :: ( Functor h, ToSortable h => Bool -> Entity Qualification -> Map LmsTableAction (AForm Handler LmsTableActionData) - -> (Map CompanyId Company -> cols) + -> ((CompanyId -> CompanyName) -> cols) -> PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData)) -> DB (FormResult (LmsTableActionData, Set UserId), Widget) mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do now <- liftIO getCurrentTime -- lookup all companies - cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do + cmpMap <- memcachedBy (Just . Right $ 15 * diffMinute) ("CompanyDictionary"::Text) $ do cmps <- selectList [] [] -- [Asc CompanyShorthand] return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps let + getCompanyName :: CompanyId -> CompanyName + getCompanyName cid = maybe (unCompanyKey cid) companyName $ Map.lookup cid cmpMap -- use shorthand in case of impossible failure + csvName = T.replace " " "-" $ ciOriginal (quali ^. _qualificationName) dbtIdent :: Text dbtIdent = "lms" dbtSQLQuery = lmsTableQuery now qid dbtRowKey = queryUser >>> (E.^. UserId) - dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock, printAcks, validQ) -> do - cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Desc UserCompanyPriority, Asc UserCompanyCompany, LimitTo 1] - return (qualUsr, usr, lmsUsr, qUsrBlock, printAcks, cmpUsr, validQ) - dbtColonnade = cols cmpMap + dbtProj = dbtProjId + dbtColonnade = cols getCompanyName dbtSorting = mconcat [ single $ sortUserNameLink queryUser , single $ sortUserEmail queryUser @@ -544,25 +547,20 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do doEncode' = LmsTableCsv <$> view (resultUser . _entityVal . _userDisplayName) <*> view (resultUser . _entityVal . _userDisplayEmail) - <*> (view resultCompanyUser >>= getCompanies) - <*> (view resultCompanyUser >>= getCompanyNos) - <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) - <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) - <*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld) + <*> preview (resultCompanyId . to getCompanyName . _CI) + <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) + <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) + <*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld) <*> preview (resultQualBlock . _entityVal . _qualificationUserBlockUnblock . _not) <*> preview (resultQualBlock . _entityVal . _qualificationUserBlockFrom) - <*> view (resultLmsUser . _entityVal . _lmsUserIdent) - <*> view (resultLmsUser . _entityVal . _lmsUserStatus) - <*> view (resultLmsUser . _entityVal . _lmsUserStatusDay) - <*> view (resultLmsUser . _entityVal . _lmsUserStarted) - <*> view (resultLmsUser . _entityVal . _lmsUserDatePin) - <*> view (resultLmsUser . _entityVal . _lmsUserReceived) - <*> view (resultLmsUser . _entityVal . _lmsUserNotified) -- TODO: only exports last email date / print job sending date, not print acknowledge - <*> view (resultLmsUser . _entityVal . _lmsUserEnded) - getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of - [] -> pure Nothing - somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps - getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) + <*> view (resultLmsUser . _entityVal . _lmsUserIdent) + <*> view (resultLmsUser . _entityVal . _lmsUserStatus) + <*> view (resultLmsUser . _entityVal . _lmsUserStatusDay) + <*> view (resultLmsUser . _entityVal . _lmsUserStarted) + <*> view (resultLmsUser . _entityVal . _lmsUserDatePin) + <*> view (resultLmsUser . _entityVal . _lmsUserReceived) + <*> view (resultLmsUser . _entityVal . _lmsUserNotified) -- TODO: only exports last email date / print job sending date, not print acknowledge + <*> view (resultLmsUser . _entityVal . _lmsUserEnded) dbtCsvDecode = Nothing dbtExtraReps = [] @@ -627,16 +625,12 @@ postLmsR sid qsh = do -- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing <* aformMessage msgRestartWarning ] - colChoices cmpMap = mconcat + colChoices getCompanyName = mconcat [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) , colUserNameModalHdrAdmin MsgLmsUser AdminUserR , colUserEmail - , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) -> - let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr - | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps - , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap - ] - in intercalate spacerCell cs + , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> + maybeEmpty mcid $ \cid -> companyCell (unCompanyKey cid) (getCompanyName cid) False , colUserMatriclenr isAdmin -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d diff --git a/src/Handler/MailCenter.hs b/src/Handler/MailCenter.hs index c6abfa015..021860b76 100644 --- a/src/Handler/MailCenter.hs +++ b/src/Handler/MailCenter.hs @@ -96,7 +96,7 @@ mkMCTable = do , sortable Nothing (i18nCell MsgCommSubject) $ \(view resultMail -> Entity k v) -> let subject = v ^? _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject" linkWgt = maybe (msg2widget MsgUtilEMail) text2widget subject - in anchorCellM (MailPlainR <$> encrypt k) linkWgt + in anchorCellM (MailHtmlR <$> encrypt k) linkWgt -- , sortable Nothing (i18nCell MsgCommContent) $ \(view $ resultMail . _entityKey -> k) -> anchorCellM (MailHtmlR <$> encrypt k) (text2widget "html") -- , sortable Nothing (i18nCell MsgCommSubject) $ \(preview $ resultMail . _entityVal . _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject" -> h) -> cellMaybe textCell h ] @@ -219,10 +219,13 @@ handleMailShow hdr prefTypes cusm = do

^{part2widget pt} |] - -- Include for Debugging: - -- ^{jsonWidget (sm ^. _sentMailHeaders)} - -- ^{jsonWidget (sentMailContentContent cn)} - + -- Include for Debugging: + --

+ --

Debugging + --

+ -- ^{jsonWidget (sm ^. _sentMailHeaders)} + --

+ -- ^{jsonWidget (sentMailContentContent cn)} -- content fields needs decoding of base64 to make sense here selectAlternative :: [ContentType] -> Alternatives -> Maybe Part selectAlternative (fmap decodeUtf8 -> prefTypes) allAlts = aux prefTypes allAlts @@ -255,8 +258,8 @@ part2widget Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partD |] where showBody - | pt == decodeUtf8 typePlain = toWidget $ preEscapedToHtml $ plaintextToHtml $ decodeUtf8 pc - | pt == decodeUtf8 typeHtml = toWidget $ preEscapedToHtml $ decodeUtf8 pc -- preEscapedToHtml :: ToMarkup a => a -> Html + | pt == decodeUtf8 typePlain = toWidget $ preEscapedToHtml $ plainTextToHtml $ decodeUtf8 pc + | pt == decodeUtf8 typeHtml = toWidget $ preEscapedToHtml $ plainHtmlToHtml $ decodeUtf8 pc -- preEscapedToHtml :: ToMarkup a => a -> Html | pt == decodeUtf8 typeJson = let jw :: Aeson.Value -> Widget = jsonWidget in either str2widget jw $ Aeson.eitherDecodeStrict' pc diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 01c38cd0b..c9e7839b1 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -158,7 +158,6 @@ data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc.. { qtcDisplayName :: UserDisplayName , qtcEmail :: UserEmail , qtcCompany :: Maybe Text - , qtcCompanyNumbers :: CsvSemicolonList Int , qtcValidUntil :: Day , qtcLastRefresh :: Day , qtcBlockStatus :: Maybe Bool @@ -174,8 +173,7 @@ qtcExample :: QualificationTableCsv qtcExample = QualificationTableCsv { qtcDisplayName = "Max Mustermann" , qtcEmail = "m.mustermann@example.com" - , qtcCompany = Just "Example Brothers LLC, SecondaryJobs Inc" - , qtcCompanyNumbers = CsvSemicolonList [27,69] + , qtcCompany = Just "Example Brothers LLC" , qtcValidUntil = compDay , qtcLastRefresh = compDay , qtcBlockStatus = Nothing @@ -209,8 +207,7 @@ instance CsvColumnsExplained QualificationTableCsv where csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList [ ('qtcDisplayName , SomeMessage MsgLmsUser) , ('qtcEmail , SomeMessage MsgTableLmsEmail) - , ('qtcCompany , SomeMessage MsgTableCompanies) - , ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos) + , ('qtcCompany , SomeMessage MsgTablePrimeCompany) , ('qtcValidUntil , SomeMessage MsgLmsQualificationValidUntil) , ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh) , ('qtcBlockStatus , SomeMessage MsgInfoQualificationBlockStatus) @@ -238,7 +235,7 @@ queryLmsUser = $(sqlLOJproj 3 2) queryQualBlock :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock)) queryQualBlock = $(sqlLOJproj 3 3) -type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity QualificationUserBlock), [Entity UserCompany]) +type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity QualificationUserBlock), E.Value (Maybe CompanyId)) resultQualUser :: Lens' QualificationTableData (Entity QualificationUser) resultQualUser = _dbrOutput . _1 @@ -252,8 +249,8 @@ resultLmsUser = _dbrOutput . _3 . _Just resultQualBlock :: Traversal' QualificationTableData (Entity QualificationUserBlock) resultQualBlock = _dbrOutput . _4 . _Just -resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany] -resultCompanyUser = _dbrOutput . _5 +resultCompanyId :: Traversal' QualificationTableData CompanyId +resultCompanyId = _dbrOutput . _5 . _unValue . _Just instance HasEntity QualificationTableData User where @@ -340,6 +337,7 @@ qualificationTableQuery :: UTCTime -> QualificationId -> (_ -> E.SqlExpr (E.Valu , E.SqlExpr (Entity User) , E.SqlExpr (Maybe (Entity LmsUser)) , E.SqlExpr (Maybe (Entity QualificationUserBlock)) + , E.SqlExpr (E.Value (Maybe CompanyId)) ) qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do -- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps @@ -351,7 +349,11 @@ qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJo E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) - return (qualUser, user, lmsUser, qualBlock) + let primeComp = E.subSelect . E.from $ \uc -> do + E.where_ $ user E.^. UserId E.==. uc E.^. UserCompanyUser + E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany] + return (uc E.^. UserCompanyCompany) + return (qualUser, user, lmsUser, qualBlock, primeComp) mkQualificationTable :: @@ -361,17 +363,19 @@ mkQualificationTable :: => Bool -> Entity Qualification -> Map QualificationTableAction (AForm Handler QualificationTableActionData) - -> (Map CompanyId Company -> cols) + -> ((CompanyId -> CompanyName) -> cols) -> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData)) -> DB (FormResult (QualificationTableActionData, Set UserId), Widget) mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do svs <- getSupervisees now <- liftIO getCurrentTime -- lookup all companies - cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do + cmpMap <- memcachedBy (Just . Right $ 15 * diffMinute) ("CompanyDictionary"::Text) $ do cmps <- selectList [] [] -- [Asc CompanyShorthand] return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps let + getCompanyName :: CompanyId -> CompanyName + getCompanyName cid = maybe (unCompanyKey cid) companyName $ Map.lookup cid cmpMap -- use shorthand in case of impossible failure nowaday = utctDay now mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) @@ -380,15 +384,8 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs dbtSQLQuery = qualificationTableQuery now qid fltrSvs dbtRowKey = queryUser >>> (E.^. UserId) - dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do - -- cmps <- E.select . E.from $ \(usrComp `E.InnerJoin` comp) -> do - -- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId - -- E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val (entityKey usr) - -- E.orderBy [E.asc (comp E.^. CompanyName)] - -- return (comp E.^. CompanyName, comp E.^. CompanyAvsId, usrComp E.^. UserCompanySupervisor) - cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Desc UserCompanyPriority, Asc UserCompanyCompany, LimitTo 1] - return (qualUsr, usr, lmsUsr, qUsrBlock, cmpUsr) - dbtColonnade = cols cmpMap + dbtProj = dbtProjId + dbtColonnade = cols getCompanyName dbtSorting = mconcat [ single $ sortUserNameLink queryUser , single $ sortUserEmail queryUser @@ -471,8 +468,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do doEncode' = QualificationTableCsv <$> view (resultUser . _entityVal . _userDisplayName) <*> view (resultUser . _entityVal . _userDisplayEmail) - <*> (view resultCompanyUser >>= getCompanies) - <*> (view resultCompanyUser >>= getCompanyNos) + <*> preview (resultCompanyId . to getCompanyName . _CI) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not) @@ -480,10 +476,6 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do <*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal) <*> getStatusPlusTxt <*> getStatusPlusDay - getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of - [] -> pure Nothing - somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps - getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) getStatusPlusTxt = (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case @@ -585,16 +577,12 @@ postQualificationR sid qsh = do ] isAdmin linkLmsUser = toMaybe isAdmin (LmsUserR sid qsh) linkUserName = bool ForProfileR ForProfileDataR isAdmin - colChoices cmpMap = mconcat + colChoices getCompanyName = mconcat [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , colUserNameModalHdr MsgLmsUser linkUserName , colUserEmail - , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) -> - let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr - | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps - , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap - ] - in intercalate spacerCell cs + , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> + maybeEmpty mcid $ \cid -> companyCell (unCompanyKey cid) (getCompanyName cid) False , guardMonoid isAdmin $ colUserMatriclenr isAdmin -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 7ffbee74f..b470a288e 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -10,7 +10,8 @@ module Handler.Utils.DateTime , toTimeOfDay , toMidnight, beforeMidnight, toMidday, toMorning , toFullHour, roundDownToMinutes, addHours - , formatDiffDays, formatCalendarDiffDays + , formatDiffDays, formatDiffHours + , formatCalendarDiffDays , formatTime' , formatTime, formatTimeUser, formatTimeW, formatTimeMail , formatTimeRange, formatTimeRangeW, formatTimeRangeMail @@ -144,8 +145,8 @@ getDateTimeFormatUser sel mUser = do getDateTimeFormatUser' :: SelDateTimeFormat -> User -> DateTimeFormat getDateTimeFormatUser' SelFormatDateTime usr = usr & userDateTimeFormat -getDateTimeFormatUser' SelFormatDate usr = usr & userDateFormat -getDateTimeFormatUser' SelFormatTime usr = usr & userTimeFormat +getDateTimeFormatUser' SelFormatDate usr = usr & userDateFormat +getDateTimeFormatUser' SelFormatTime usr = usr & userTimeFormat getDateTimeFormatter :: (MonadHandler m, HandlerSite m ~ UniWorX, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => m DateTimeFormatter getDateTimeFormatter = do @@ -160,7 +161,7 @@ getDateTimeFormatterUser mUser = do return $ mkDateTimeFormatter locale formatMap appTZ getDateTimeFormatterUser' :: (MonadHandler m) => User -> m DateTimeFormatter -getDateTimeFormatterUser' usr = do +getDateTimeFormatterUser' usr = do locale <- getTimeLocale let formatMap = flip getDateTimeFormatUser' usr return $ mkDateTimeFormatter locale formatMap appTZ @@ -263,18 +264,21 @@ formatDiffDays t inHours = tshow $ convertBy nominalHour inMinutes = tshow $ convertBy nominalMinute +formatDiffHours :: Integral a => a -> Text +formatDiffHours = formatDiffDays . secondsToNominalDiffTime . (* 360) . fromIntegral + formatCalendarDiffDays :: CalendarDiffDays -> Text -formatCalendarDiffDays = pack . iso8601Show +formatCalendarDiffDays = pack . iso8601Show setYear :: Integer -> Day -> Day setYear year date = fromGregorian year m d where (_,m,d) = toGregorian date -getYear :: Day -> Integer +getYear :: Day -> Integer getYear date = y - where - (y,_,_) = toGregorian date + where + (y,_,_) = toGregorian date dayOfWeekDiff :: DayOfWeek -> DayOfWeek -> Int dayOfWeekDiff a b = mod (fromEnum a - fromEnum b) 7 @@ -310,10 +314,10 @@ addLocalDays n utct = localTimeToUTCTZ appTZ newLocal -- CalendarDiffDays -- ---------------------- -fromMonths :: Integral a => a -> CalendarDiffDays +fromMonths :: Integral a => a -> CalendarDiffDays fromMonths (toInteger -> m) = CalendarDiffDays { cdMonths = m, cdDays = 0 } -- above is equivalent -fromDays :: Integral a => a -> CalendarDiffDays +fromDays :: Integral a => a -> CalendarDiffDays fromDays (toInteger -> d) = CalendarDiffDays { cdMonths = 0, cdDays = d } addDiffDaysClip :: CalendarDiffDays -> UTCTime -> UTCTime @@ -393,7 +397,7 @@ formatTimeRangeMail = formatTimeRange' formatTimeMail formatGregorianW :: (YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => Integer -> Int -> Int -> WidgetFor UniWorX () formatGregorianW y m d = formatTimeW SelFormatDate $ fromGregorian y m d -instance Csv.ToField ZonedTime where +instance Csv.ToField ZonedTime where toField = Csv.toField . iso8601Show -- also see Data.Time.Clock.Instances diff --git a/src/Model/Types/Markup.hs b/src/Model/Types/Markup.hs index a250927c4..836530d75 100644 --- a/src/Model/Types/Markup.hs +++ b/src/Model/Types/Markup.hs @@ -9,7 +9,7 @@ module Model.Types.Markup , markdownToStoredMarkup , esqueletoMarkupOutput , I18nStoredMarkup - , markupIsSmallish + , markupIsSmallish , html2textlines , isSimilarMarkup ) where @@ -53,7 +53,7 @@ data StoredMarkup = StoredMarkup deriving anyclass (Binary, Hashable, NFData) isSimilarMarkup :: StoredMarkup -> StoredMarkup -> Bool -isSimilarMarkup StoredMarkup{markupInputFormat=af, markupInput=ai} +isSimilarMarkup StoredMarkup{markupInputFormat=af, markupInput=ai} StoredMarkup{markupInputFormat=bf, markupInput=bi} = af==bf && ai == bi @@ -74,7 +74,7 @@ plaintextToStoredMarkup :: Textual t => t -> StoredMarkup plaintextToStoredMarkup (repack -> t) = StoredMarkup { markupInputFormat = MarkupPlaintext , markupInput = t - , markupOutput = plaintextToHtml $ LT.toStrict t + , markupOutput = plainTextToHtml $ LT.toStrict t } preEscapedToStoredMarkup :: Textual t => t -> StoredMarkup preEscapedToStoredMarkup (repack -> t) = StoredMarkup @@ -86,8 +86,8 @@ markdownToStoredMarkup :: Textual t => t -> StoredMarkup markdownToStoredMarkup (repack -> t) = StoredMarkup { markupInputFormat = MarkupMarkdown , markupInput = t - , markupOutput = plaintextToHtml $ LT.toStrict t - } + , markupOutput = plainTextToHtml $ LT.toStrict t + } esqueletoMarkupOutput :: E.SqlExpr (E.Value StoredMarkup) -> E.SqlExpr (E.Value Html) diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index fbf697fec..f44763c48 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -316,6 +316,7 @@ makeLenses_ ''AuthorshipStatementDefinition makeLenses_ ''PrintJob makeLenses_ ''InterfaceLog +makeLenses_ ''InterfaceHealth makeLenses_ ''AdminProblem makeLenses_ ''ProblemLog diff --git a/src/Utils/Pandoc.hs b/src/Utils/Pandoc.hs index ad7582377..d2030d2a3 100644 --- a/src/Utils/Pandoc.hs +++ b/src/Utils/Pandoc.hs @@ -19,11 +19,16 @@ 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) -plaintextToHtml :: Text -> Html -plaintextToHtml text = fromRight (toMarkup text) $ P.runPure $ +plainTextToHtml :: Text -> Html +plainTextToHtml text = fromRight (toMarkup text) $ P.runPure $ P.writeHtml5 htmlWriterOptions =<< P.readMarkdown markdownReaderOptions text -- Line below does not work as intended, also see Handler.Utils.Pandoc.plaintextToMarkdownWith which uses this code - -- where pandoc = P.Pandoc mempty [P.Plain [P.Str text]] + -- where pandoc = P.Pandoc mempty [P.Plain [P.Str text]] + +plainHtmlToHtml :: Text -> Html +plainHtmlToHtml text = fromRight (toMarkup text) $ P.runPure $ + P.writeHtml5 htmlWriterOptions =<< P.readHtml markdownReaderOptions text + htmlReaderOptions, markdownReaderOptions :: P.ReaderOptions diff --git a/templates/admin-problems.hamlet b/templates/admin-problems.hamlet index 3909155cf..85701ef5a 100644 --- a/templates/admin-problems.hamlet +++ b/templates/admin-problems.hamlet @@ -1,6 +1,6 @@ $newline never -$# SPDX-FileCopyrightText: 2022 Steffen Jost +$# SPDX-FileCopyrightText: 2022-24 Steffen Jost $# $# SPDX-License-Identifier: AGPL-3.0-or-later @@ -62,7 +62,9 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later $else _{MsgInterfacesOk} ^{interfaceTable} - +

+ + _{MsgConfigInterfacesHeading}

_{MsgProblemsHeadingMisc} diff --git a/templates/i18n/config-interfaces/de-de-formal.hamlet b/templates/i18n/config-interfaces/de-de-formal.hamlet new file mode 100644 index 000000000..63265ad51 --- /dev/null +++ b/templates/i18n/config-interfaces/de-de-formal.hamlet @@ -0,0 +1,41 @@ +$newline never + +$# SPDX-FileCopyrightText: 2024 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +
+

+ _{MsgMenuInterfaces} +
+

+ Eine Schnittstelle gilt als fehlgeschlagen, wenn die letzte Transaktion dieser Schnittstelle ein konkreten Fehler lieferte, + oder wenn seit einer gewissen Anzahl an Stunden kein erneuter Erfolg für diese Schnittstelle registriert wurde. + + Diese Zeitspanne beträgt normalerweise: #{defWarnTime} + + Mit der nachfolgend gezeigten Tabelle kann diese Zeitspanne zwischen letztem Erfolg und dem Anzeigen eines Fehlers aufgrund + des Ausbleibens eines erneuten Erfolges für einzelne Schnittstellen geändert werden. + Einträge mit unspezifiertem _{MsgInterfaceSubtype} und/oder _{MsgInterfaceWrite} betreffen alle drauf passenden Schnittstellen, + sofern es keine anderen passenden, besser spezifizierten Einträge gibt. + + Die Zeitspanne ist hier immer in Stunden anzugeben. + Eine negative Stundenzahl deaktiviert den Warnungsmechanismus für ausbleibende wiederholte Erfolge; + in diesem Fall werden für die Schnittstelle nur tatsächliche Fehlschläge als Fehler gemeldet. +

+ ^{configTable} + +

+

+ _{MsgMenuInterfaces} +
+

+ Current interface health is shown here for reference +

+ $if interfacesBadNr > 0 + _{MsgInterfacesFail interfacesBadNr} + $else + _{MsgInterfacesOk} + ^{interfaceTable} + + diff --git a/templates/i18n/config-interfaces/en-eu.hamlet b/templates/i18n/config-interfaces/en-eu.hamlet new file mode 100644 index 000000000..0b36757d5 --- /dev/null +++ b/templates/i18n/config-interfaces/en-eu.hamlet @@ -0,0 +1,36 @@ +$newline never + +$# SPDX-FileCopyrightText: 2024 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +

+

+ _{MsgMenuInterfaces} +
+

+ An interface is flagged as failed, if no success had been reported within the last #{defWarnTime} + + The following table allows to change the time span between the last success and before an error is raised. + A time value having _{MsgInterfaceSubtype} and/or _{MsgInterfaceWrite} left unspecified affects all matching interfeaces, + unless another more specified matching row exists for a particular interface. + + The time span is configure by a number of hours. + A negative hour value disables the raising of an error by time entirely; in this case, an error is only raised if the last interface transaction reported failure. +

+ ^{configTable} + +

+

+ _{MsgMenuInterfaces} +
+

+ Current interface health is shown here for reference +

+ $if interfacesBadNr > 0 + _{MsgInterfacesFail interfacesBadNr} + $else + _{MsgInterfacesOk} + ^{interfaceTable} + +