fix(health): negative interface routes working as intended now

src/Handler/Health/Interface.hs

@@ -2,8 +2,6 @@
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
-{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}    -- !!! TODO REMOVE ME
-
 
 module Handler.Health.Interface
   (
@@ -100,19 +98,12 @@ runInterfaceLogTable interfs@(reqIfs,_) = do
       allok   = all snd res
   return (missing, allok, res, twgt)
 
-ihDebugShow :: Unique InterfaceHealth -> Text
+-- ihDebugShow :: Unique InterfaceHealth -> Text
-ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> "," <> tshow s <> "," <> tshow w <> ")"
+-- ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> "," <> tshow s <> "," <> tshow w <> ")"
-
--- NOTE: Using (~~.) instead of ()=~.)
--- | like (=~.) but avoids condition entirely if second argument is Nothing; Note that using =~. with E.val Nothing did not work somehow!
--- infixl 4 ~~.
--- (~~.) ::  PersistField typ => E.SqlExpr (E.Value typ) -> Maybe typ -> E.SqlExpr (E.Value Bool)
--- (~~.) _ Nothing  = E.true 
--- (~~.) a (Just b) = a E.==. E.val b
 
 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])
+    -- $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, ..}
@@ -125,24 +116,27 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
               E.&&. ilog E.^. InterfaceLogSubtype   E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype)
               E.&&. ilog E.^. InterfaceLogWrite     E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite  )
             )
-      -- let matchUIH crits = E.or
+      let matchUIH crits = E.or
-      --       [       ilog E.^. InterfaceLogInterface E.==. E.val (sanitize     ifce)
+           [ E.and $ catMaybes
-      --         E.&&. ilog E.^. InterfaceLogSubtype     ~~.       (sanitize <$> subt)
+             [  ilog E.^. InterfaceLogInterface E.==.    E.val  (sanitize     ifce) & Just
-      --         E.&&. ilog E.^. InterfaceLogWrite       ~~.                     writ
+             , (ilog E.^. InterfaceLogSubtype   E.==.) . E.val . sanitize <$> subt
-      --       | (UniqueInterfaceHealth ifce subt writ) <- crits
+             , (ilog E.^. InterfaceLogWrite     E.==.) . E.val            <$> writ
-      --       ]      
+             ]
-      -- let matchUIH crits = E.or
+           | (UniqueInterfaceHealth ifce subt writ) <- crits
-      --      [ E.and $ catMaybes
+           ]
-      --        [  ilog E.^. InterfaceLogInterface E.==.    E.val  (sanitize     ifce) & Just
+          matchUIHnot crits = E.and
-      --        , (ilog E.^. InterfaceLogSubtype   E.==.) . E.val . sanitize <$> subt
+           [ E.or $ catMaybes
-      --        , (ilog E.^. InterfaceLogWrite     E.==.) . E.val            <$> writ
+             [  ilog E.^. InterfaceLogInterface E.!=.    E.val  (sanitize     ifce) & Just
-      --        ]
+             , (ilog E.^. InterfaceLogSubtype   E.!=.) . E.val . sanitize <$> subt
-      --      | (UniqueInterfaceHealth ifce subt writ) <- crits
+             , (ilog E.^. InterfaceLogWrite     E.!=.) . E.val            <$> writ
-      --      ]
+             ]
-      -- unless (null reqIfs) $ E.where_ $          matchUIH reqIfs
+           | (UniqueInterfaceHealth ifce subt writ) <- crits
-      -- unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs      
+           ]
-      E.where_ $ E.not_ (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&.  ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- NOT OKAY ONLY Printer F SEE ISSUE #155
+      unless (null reqIfs) $ E.where_ $ matchUIH    reqIfs
-      -- E.where_ $  ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||.  ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F") -- OKAY
+      unless (null banIfs) $ E.where_ $ matchUIHnot banIfs
+      -- unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs -- !!! DOES NOT WORK !!! Yields strange results, see #155
+      -- 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_ $         ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||.  ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F")  -- OKAY
       let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24)  -- if no default time is set, use 3 days instead
       return (ilog, ihour)
 
@@ -211,14 +205,6 @@ maybeRunCheck (reqIfs,banIfs) uih act
         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