fix(health): fix #153 and offer interface health route matching

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

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

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
+logInterface interfaceLogInterface interfaceLogSubtype interfaceLogSuccess interfaceLogRows interfaceLogInfo = do 
-  interfaceLogTime  <- liftIO getCurrentTime
   interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest
-  deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace, deleteBy & insert seems to be safest and fastest
+  logInterface' interfaceLogInterface interfaceLogSubtype interfaceLogWrite interfaceLogSuccess interfaceLogRows interfaceLogInfo
-  insert_ InterfaceLog{..}
+
+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

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,42 +42,77 @@ 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
+  let (forced, ris') = case ris of
+          ("force":ris0) -> (True , ris0)
+          _              -> (False, ris )
+      interfs = splitInterfaces $ identifyInterfaces ris'
   (missing, allok, res, iltable) <- runInterfaceLogTable interfs
-  when missing notFound -- send 404 if an interface any interface was not found
+  let badMsg = "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res]
-  unless allok $ sendResponseStatus internalServerError500 $ "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res]
+  when missing notFound -- send 404 if any requested interface was not found
-  siteLayoutMsg MsgMenuHealthInterface $ do
+  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 :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget)
-runInterfaceLogTable interfs = do
+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 :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget)
-mkInterfaceLogTable flagError interfs = do
+mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
-    runInterfaceChecks    
+    -- $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
@@ -88,12 +120,14 @@ mkInterfaceLogTable flagError interfs = do
               E.&&. ilog E.^. InterfaceLogSubtype   E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) 
               E.&&. ilog E.^. InterfaceLogWrite     E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite  ) 
             )
-      unless (null interfs) $
+      let matchUIH crits = E.or
-        E.where_ $ E.or [       ilog E.^. InterfaceLogInterface E.==. E.val ifce
+            [       ilog E.^. InterfaceLogInterface E.==. E.val (sanitize     ifce)
-                          E.&&. ilog E.^. InterfaceLogSubtype   E.=~. E.val subt
+              E.&&. ilog E.^. InterfaceLogSubtype   E.=~. E.val (sanitize <$> subt)
-                          E.&&. ilog E.^. InterfaceLogWrite     E.=~. E.val writ
+              E.&&. ilog E.^. InterfaceLogWrite     E.=~. E.val writ
-                        | (UniqueInterfaceHealth ifce subt writ) <- interfs
+            | (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 :: ReqBanInterfaceHealth -> DB ()
-runInterfaceChecks = do 
+runInterfaceChecks interfs = do
-  avsInterfaceCheck
+  avsInterfaceCheck interfs
-  lprAckCheck
+  lprAckCheck interfs
 
-lprAckCheck :: DB ()
+maybeRunCheck :: ReqBanInterfaceHealth -> Unique InterfaceHealth -> (UTCTime -> DB ()) -> DB ()
-lprAckCheck = return () -- !!! TODO !!! Stub 
+maybeRunCheck (reqIfs,banIfs) uih act
-  -- ensure that all received apc-idents were ok
+  | 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 ()
 
-avsInterfaceCheck :: DB ()  
+-- maybeRunCheck :: Unique InterfaceHealth -> (Int -> DB ()) -> DB ()
-avsInterfaceCheck = flip (maybeM $ return ()) (getBy $ UniqueInterfaceHealth "AVS" (Just "Synch") (Just True)) $ \Entity{entityVal=InterfaceHealth{interfaceHealthHours}} -> do
+-- maybeRunCheck uih act = maybeM (return ()) (act . interfaceHealthHours . entityVal) $ getBy uih
-  now <- liftIO getCurrentTime
+  -- maybeRunCheck uih act = getBy uih >>= flip whenIsJust (act . interfaceHealthHours . entityVal)
-  let cutOffOldTime = addHours (-interfaceHealthHours) now
+  -- 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
@@ -173,17 +234,15 @@ avsInterfaceCheck = flip (maybeM $ return ()) (getBy $ UniqueInterfaceHealth "AV
       fmtBad <- formatTime SelFormatDateTime badTime
       return $ tshow badRows <> " Fehler seit " <> fmtCut <> ", zuletzt um " <> fmtBad
     mkBadInfo _ _ = return mempty
-    writeAvsSynchStats okRows (fromMaybe cutOffOldTime -> okTime) badInfo = 
+    writeAvsSynchStats okRows badInfo =
-      void $ upsertBy (UniqueInterfaceSubtypeWrite "AVS" "Synch" True)
+      logInterface' "AVS" "Synch" True (null badInfo) okRows badInfo
-        (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):_) ->
+    ((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
+      writeAvsSynchStats (Just okRows) =<< mkBadInfo badRows badTime
-    ((E.Value True , E.Value okRows, E.Value okTime):_)    ->
+    ((E.Value True , E.Value okRows, E.Value _okTime):_)    ->
-      writeAvsSynchStats (Just okRows) okTime mempty
+      writeAvsSynchStats (Just okRows) mempty
-    ((E.Value False, E.Value badRows, E.Value badTime):_) -> do
+    ((E.Value False, E.Value badRows, E.Value badTime):_) ->
-      lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch]
+      -- lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch]
-      writeAvsSynchStats Nothing lastOk =<< mkBadInfo badRows badTime
+      writeAvsSynchStats Nothing =<< mkBadInfo badRows badTime
     _ -> return ()

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:

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"

src/Utils/Lens.hs

@@ -310,6 +310,7 @@ makeLenses_ ''AuthorshipStatementDefinition
 makeLenses_ ''PrintJob
 
 makeLenses_ ''InterfaceLog
+-- makeLenses_ ''InterfaceLog -- not needed
 
 --------------------------
 -- Fields for `UniWorX` --

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 ->