diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index 6fb6a2836..eb6cfe753 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -122,7 +122,7 @@ ProblemsAvsErrorHeading: Fehlermeldungen ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit InterfacesOk: Schnittstellen sind ok. -InterfacesFail n@Int: #{tshow n} Schnittstellenprobleme! +InterfacesFail n@Int: #{pluralDEeN n "Schnittstellenproblem"}! InterfaceStatus !ident-ok: Status InterfaceName: Schnittstelle InterfaceLastSynch: Zuletzt diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index 74420ff19..13f35ed9f 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -122,7 +122,7 @@ ProblemsAvsErrorHeading: Error Log ProblemsInterfaceSince: Only considering successes and errors since InterfacesOk: Interfaces are ok. -InterfacesFail n: #{tshow n} Interface problems! +InterfacesFail n: #{pluralENsN n "interface problem"}! InterfaceStatus: Status InterfaceName: Interface InterfaceLastSynch: Last diff --git a/src/Audit.hs b/src/Audit.hs index f26af2d80..40c4a4206 100644 --- a/src/Audit.hs +++ b/src/Audit.hs @@ -8,7 +8,7 @@ module Audit , audit , AuditRemoteException(..) , getRemote - , logInterface + , logInterface, logInterface' ) where @@ -128,11 +128,39 @@ logInterface :: ( AuthId (HandlerSite m) ~ Key User -> Text -- ^ Any additional information -> ReaderT (YesodPersistBackend (HandlerSite m)) m () -- ^ Log a transaction using information available from `HandlerT`, also calls `audit` -logInterface (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogSubtype) interfaceLogSuccess interfaceLogRows (Text.strip -> interfaceLogInfo) = do - interfaceLogTime <- liftIO getCurrentTime +logInterface interfaceLogInterface interfaceLogSubtype interfaceLogSuccess interfaceLogRows interfaceLogInfo = do interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest - deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace, deleteBy & insert seems to be safest and fastest - insert_ InterfaceLog{..} + logInterface' interfaceLogInterface interfaceLogSubtype interfaceLogWrite interfaceLogSuccess interfaceLogRows interfaceLogInfo + +logInterface' :: ( AuthId (HandlerSite m) ~ Key User + , IsSqlBackend (YesodPersistBackend (HandlerSite m)) + , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m)) + , HasInstanceID (HandlerSite m) InstanceId + , YesodAuthPersist (HandlerSite m) + , MonadHandler m + , MonadCatch m + , HasAppSettings (HandlerSite m) + , HasCallStack + ) + => Text -- ^ Interface that is used + -> Text -- ^ Subtype of the interface, if any + -> Bool -- ^ True indicates Write Access to FRADrive + -> Bool -- ^ Success=True, Failure=False + -> Maybe Int -- ^ Number of transmitted datasets + -> Text -- ^ Any additional information + -> ReaderT (YesodPersistBackend (HandlerSite m)) m () +-- ^ Log a transaction using information available from `HandlerT`, also calls `audit` +logInterface' (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogSubtype) interfaceLogWrite interfaceLogSuccess interfaceLogRows (Text.strip -> interfaceLogInfo) = do + interfaceLogTime <- liftIO getCurrentTime + -- deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace: deleteBy & insert seems to be safest and fastest + -- insert_ InterfaceLog{..} + void $ upsertBy (UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite) + ( InterfaceLog{..} ) + [ InterfaceLogTime =. interfaceLogTime + , InterfaceLogRows =. interfaceLogRows + , InterfaceLogInfo =. interfaceLogInfo + , InterfaceLogSuccess =. interfaceLogSuccess + ] audit TransactionInterface { transactionInterfaceName = interfaceLogInterface , transactionInterfaceSubtype = interfaceLogSubtype diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index d1b8a0af0..c43ffaed8 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -18,24 +18,21 @@ import Import -- import qualified Data.Set as Set import qualified Data.Text as Text import Handler.Utils +import Handler.Utils.Concurrent -- import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Legacy as EL (on) +import qualified Database.Persist.Sql as E (deleteWhereCount) -identifyInterfaces :: [Text] -> [Unique InterfaceHealth] -identifyInterfaces [] = [] -identifyInterfaces [i] = [UniqueInterfaceHealth i Nothing Nothing] -identifyInterfaces [i,s] = [UniqueInterfaceHealth i (wc2null s) Nothing] -identifyInterfaces (i:s:w:r) = UniqueInterfaceHealth i (wc2null s) (pbool w) : identifyInterfaces r - -- | identify a wildcard argument wc2null :: Text -> Maybe Text -wc2null "." = Nothing +-- wc2null "." = Nothing -- does not work, since dots are eliminated in URLs -- wc2null "-" = Nothing -- used as wildcard subtype in lpr interface wc2null "_" = Nothing +wc2null "*" = Nothing wc2null o = Just o -- | sloppily parse a boolean, also see Model.Types.Avs.SloppyBool @@ -45,55 +42,92 @@ pbool (Text.toLower . Text.strip -> w) | w `elem` ["0", "f", "false","falsch"] = Just False | otherwise = Nothing +-- | parse UniqueInterfaceHealth with subtype and write arguments being optional for the last interface. Wildcards '_' or '.' are also allowed in all places. +identifyInterfaces :: [Text] -> [Unique InterfaceHealth] +identifyInterfaces [] = [] +identifyInterfaces [i] = [UniqueInterfaceHealth i Nothing Nothing] +identifyInterfaces [i,s] = [UniqueInterfaceHealth i (wc2null s) Nothing] +identifyInterfaces (i:s:w:r) = UniqueInterfaceHealth i (wc2null s) (pbool w) : identifyInterfaces r + +type ReqBanInterfaceHealth = ([Unique InterfaceHealth],[Unique InterfaceHealth]) + +-- | Interface names prefixed with '-' are to be excluded from the query +splitInterfaces :: [Unique InterfaceHealth] -> ReqBanInterfaceHealth +splitInterfaces = foldl' aux mempty + where + aux (reqs,bans) uih@(UniqueInterfaceHealth i s w) + | Just ('-', b) <- Text.uncons i = (reqs, UniqueInterfaceHealth b s w : bans) + | otherwise = (uih : reqs, bans) + +-- | check whether the first argument is equal or more specialzed (i.e. more Just) than the second +matchesUniqueInterfaceHealth :: Unique InterfaceHealth -> Unique InterfaceHealth -> Bool +matchesUniqueInterfaceHealth (UniqueInterfaceHealth ai as aw) (UniqueInterfaceHealth bi bs bw) = ai == bi && eqOrNothing as bs && eqOrNothing aw bw + where + eqOrNothing _ Nothing = True + eqOrNothing a b = a == b getHealthInterfaceR :: [Text] -> Handler Html getHealthInterfaceR ris = do - let interfs = identifyInterfaces ris - (missing, allok, res, iltable) <- runInterfaceLogTable interfs - when missing notFound -- send 404 if an interface any interface was not found - unless allok $ sendResponseStatus internalServerError500 $ "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] - siteLayoutMsg MsgMenuHealthInterface $ do + let (forced, ris') = case ris of + ("force":ris0) -> (True , ris0) + _ -> (False, ris ) + interfs = splitInterfaces $ identifyInterfaces ris' + (missing, allok, res, iltable) <- runInterfaceLogTable interfs + let badMsg = "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] + when missing notFound -- send 404 if any requested interface was not found + unless (forced || allok) $ sendResponseStatus internalServerError500 badMsg + content <- siteLayoutMsg MsgMenuHealthInterface $ do setTitleI MsgMenuHealthInterface [whamlet| - Interfaces healthy. + $if allok + Interfaces are healthy. + $else + #{badMsg} ^{iltable} |] + sendResponseStatus (bool internalServerError500 status200 allok) content -runInterfaceLogTable :: [Unique InterfaceHealth] -> Handler (Bool, Bool, [(Text,Bool)], Widget) -runInterfaceLogTable interfs = do +runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget) +runInterfaceLogTable interfs@(reqIfs,_) = 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 (res, twgt) <- runDB $ mkInterfaceLogTable flagError interfs - let missing = notNull [ifce | (UniqueInterfaceHealth ifce _subt _writ) <- interfs, ifce `notElem` (fst <$> res) ] + let missing = notNull [ifce | (UniqueInterfaceHealth ifce _subt _writ) <- reqIfs, ifce `notElem` (fst <$> res) ] allok = all snd res return (missing, allok, res, twgt) +-- ihDebugShow :: Unique InterfaceHealth -> Text +-- ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> tshow s <> tshow w <> ")" -mkInterfaceLogTable :: (Bool -> Widget) -> [Unique InterfaceHealth] -> DB ([(Text,Bool)], Widget) -mkInterfaceLogTable flagError interfs = do - runInterfaceChecks +mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget) +mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do + -- $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs]) + void $ liftHandler $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs now <- liftIO getCurrentTime dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..} where + sanitize = text2AlphaNumPlus ['+','-','_','Ä','Ö','Ü','ß','ä','ö','ü'] dbtIdent = "interface-log" :: Text dbtProj = dbtProjId dbtSQLQuery (ilog `E.LeftOuterJoin` ihealth) = do EL.on ( ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface - E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) - E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) + E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) + E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) ) - unless (null interfs) $ - E.where_ $ E.or [ ilog E.^. InterfaceLogInterface E.==. E.val ifce - E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.val subt - E.&&. ilog E.^. InterfaceLogWrite E.=~. E.val writ - | (UniqueInterfaceHealth ifce subt writ) <- interfs - ] + let matchUIH crits = E.or + [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) + E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.val (sanitize <$> subt) + E.&&. ilog E.^. InterfaceLogWrite E.=~. E.val writ + | (UniqueInterfaceHealth ifce subt writ) <- crits + ] + unless (null reqIfs) $ E.where_ $ matchUIH reqIfs + unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead return (ilog, ihour) @@ -147,19 +181,46 @@ mkInterfaceLogTable flagError interfs = do -- | runs additional checks and logs results within InterfaceLogTable; assumed to executable within a handler call -runInterfaceChecks :: DB () -runInterfaceChecks = do - avsInterfaceCheck - lprAckCheck - -lprAckCheck :: DB () -lprAckCheck = return () -- !!! TODO !!! Stub - -- ensure that all received apc-idents were ok +runInterfaceChecks :: ReqBanInterfaceHealth -> DB () +runInterfaceChecks interfs = do + avsInterfaceCheck interfs + lprAckCheck interfs -avsInterfaceCheck :: DB () -avsInterfaceCheck = flip (maybeM $ return ()) (getBy $ UniqueInterfaceHealth "AVS" (Just "Synch") (Just True)) $ \Entity{entityVal=InterfaceHealth{interfaceHealthHours}} -> do - now <- liftIO getCurrentTime - let cutOffOldTime = addHours (-interfaceHealthHours) now +maybeRunCheck :: ReqBanInterfaceHealth -> Unique InterfaceHealth -> (UTCTime -> DB ()) -> DB () +maybeRunCheck (reqIfs,banIfs) uih act + | null reqIfs || any (matchesUniqueInterfaceHealth uih) reqIfs + , null banIfs || not (any (matchesUniqueInterfaceHealth uih) banIfs) = do + mih <- getBy uih + whenIsJust mih $ \eih -> do + now <- liftIO getCurrentTime + act $ addHours (negate $ interfaceHealthHours $ entityVal eih) now + | otherwise = return () + +-- maybeRunCheck :: Unique InterfaceHealth -> (Int -> DB ()) -> DB () +-- maybeRunCheck uih act = maybeM (return ()) (act . interfaceHealthHours . entityVal) $ getBy uih + -- maybeRunCheck uih act = getBy uih >>= flip whenIsJust (act . interfaceHealthHours . entityVal) + -- where + -- ih2hours :: Entity InterfaceHealth -> Int + -- -- ih2hours Entity{entityVal=InterfaceHealth{interfaceHealthHours=h}} = h + -- ih2hours = interfaceHealthHours . entityVal + + +lprAckCheck :: ReqBanInterfaceHealth -> DB () +lprAckCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "Printer" (Just "Acknowledge") (Just True)) $ \cutOffOldTime -> do + unproc <- selectList [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. False] [] + if notNull unproc + then mkLog False (Just $ length unproc) "Long unprocessed APC-Idents exist" + else do + oks <- E.deleteWhereCount [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. True] + if oks > 0 + then mkLog True (Just $ fromIntegral oks) "Long processed APC-Idents removed" + else mkLog True Nothing mempty + where + mkLog = logInterface' "Printer" "Acknowledge" True + + +avsInterfaceCheck :: ReqBanInterfaceHealth -> DB () +avsInterfaceCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "AVS" (Just "Synch") (Just True)) $ \cutOffOldTime -> do avsSynchStats <- E.select $ do uavs <- E.from $ E.table @UserAvs E.where_ $ uavs E.^. UserAvsLastSynch E.>. E.val cutOffOldTime @@ -167,23 +228,21 @@ avsInterfaceCheck = flip (maybeM $ return ()) (getBy $ UniqueInterfaceHealth "AV E.groupBy isOk E.orderBy [E.descNullsLast isOk] return (isOk, E.countRows, E.max_ $ uavs E.^. UserAvsLastSynch) - let + let mkBadInfo badRows (fromMaybe cutOffOldTime -> badTime) | badRows > 0 = do fmtCut <- formatTime SelFormatDate cutOffOldTime fmtBad <- formatTime SelFormatDateTime badTime return $ tshow badRows <> " Fehler seit " <> fmtCut <> ", zuletzt um " <> fmtBad mkBadInfo _ _ = return mempty - writeAvsSynchStats okRows (fromMaybe cutOffOldTime -> okTime) badInfo = - void $ upsertBy (UniqueInterfaceSubtypeWrite "AVS" "Synch" True) - (InterfaceLog "AVS" "Synch" True okTime okRows badInfo (null badInfo)) - [InterfaceLogTime =. okTime, InterfaceLogRows =. okRows, InterfaceLogInfo =. badInfo, InterfaceLogSuccess =. null badInfo] - --case $(unValueN 3) <$> avsSynchStats of - case avsSynchStats of - ((E.Value True , E.Value okRows, E.Value okTime):(E.Value False, E.Value badRows, E.Value badTime):_) -> - writeAvsSynchStats (Just okRows) okTime =<< mkBadInfo badRows badTime - ((E.Value True , E.Value okRows, E.Value okTime):_) -> - writeAvsSynchStats (Just okRows) okTime mempty - ((E.Value False, E.Value badRows, E.Value badTime):_) -> do - lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch] - writeAvsSynchStats Nothing lastOk =<< mkBadInfo badRows badTime + writeAvsSynchStats okRows badInfo = + logInterface' "AVS" "Synch" True (null badInfo) okRows badInfo + --case $(unValueN 3) <$> avsSynchStats of + case avsSynchStats of + ((E.Value True , E.Value okRows, E.Value _okTime):(E.Value False, E.Value badRows, E.Value badTime):_) -> + writeAvsSynchStats (Just okRows) =<< mkBadInfo badRows badTime + ((E.Value True , E.Value okRows, E.Value _okTime):_) -> + writeAvsSynchStats (Just okRows) mempty + ((E.Value False, E.Value badRows, E.Value badTime):_) -> + -- lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch] + writeAvsSynchStats Nothing =<< mkBadInfo badRows badTime _ -> return () diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 8e458ac47..a875b9648 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -123,6 +123,14 @@ migrateAlwaysSafe = do let itemDay = Map.findWithDefault today item changelogItemDays return [st|('#{toPathPiece item}', '#{iso8601Show itemDay}')|] in sql + -- unless (tableExists "interface_health") $ do + -- [executeQQ| + -- INSERT INTO "interface_health" (interface, subtype, write, hours) + -- VALUES + -- ('Printer', 'Acknowledge', True, 168) + -- , ('AVS' , 'Synch' , True , 96) + -- ON CONFLICT DO NOTHING; + -- |] {- Confusion about quotes, from the PostgreSQL Manual: diff --git a/src/Utils.hs b/src/Utils.hs index 2093da8b2..c47f29992 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -23,7 +23,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as CBS -import qualified Data.Char as Char +-- import qualified Data.Char as Char import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -319,9 +319,16 @@ citext2string = Text.unpack . CI.original string2citext :: String -> CI Text string2citext = CI.mk . Text.pack +text2AlphaNumPlus :: [Char] -> Text -> Text +text2AlphaNumPlus = + let alphaNum = Set.fromAscList $ ['0'..'9'] <> ['A'..'Z'] <> ['a'..'z'] + in \oks -> + let aNumPlus = Set.fromList oks <> alphaNum + in Text.filter (`Set.member` aNumPlus) + -- | Convert or remove all non-ascii characters, e.g. for filenames text2asciiAlphaNum :: Text -> Text -text2asciiAlphaNum = Text.filter (\c -> Char.isAlphaNum c && Char.isAscii c) +text2asciiAlphaNum = text2AlphaNumPlus ['-','_'] . Text.replace "ä" "ae" . Text.replace "Ä" "Ae" . Text.replace "Æ" "ae" diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 5e5f993c6..adcba7262 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -310,6 +310,7 @@ makeLenses_ ''AuthorshipStatementDefinition makeLenses_ ''PrintJob makeLenses_ ''InterfaceLog +-- makeLenses_ ''InterfaceLog -- not needed -------------------------- -- Fields for `UniWorX` -- diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 8687158b8..d4dc3f882 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -270,7 +270,7 @@ printLetter' pji pdf = do printJobFile = LBS.toStrict pdf printJobAcknowledged = Nothing qshort <- ifMaybeM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get - let logInter = flip (logInterface "LPR" qshort) (Just 1) + let logInter = flip (logInterface "Printer" qshort) (Just 1) lprPDF printJobFilename pdf >>= \case Left err -> do logInter False err @@ -288,7 +288,7 @@ reprintPDF ignoreReroute pjid = maybeM (return $ Left "Print job id is unknown." reprint :: PrintJob -> DB (Either Text Text) reprint pj@PrintJob{..} = do qshort <- ifMaybeM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get - let logInter = flip (logInterface "LPR" qshort) (Just 1) + let logInter = flip (logInterface "Printer" qshort) (Just 1) result <- lprPDF' ignoreReroute printJobFilename $ LBS.fromStrict printJobFile case result of Left err ->