ngx-export-healthcheck 1.6.3 → 1.6.4

raw patch · 4 files changed

+83/−95 lines, 4 filesdep −safedep −vectordep ~timePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: safe, vector

Dependency ranges changed: time

API changes (from Hackage documentation)

Files

• Changelog.md +10/−0
• LICENSE +1/−1
• NgxExport/Healthcheck.hs +67/−87
• ngx-export-healthcheck.cabal +5/−7

@@ -1,3 +1,13 @@+### 1.6.4++- Drop support for *time < 1.9.1*.+- Drop dependency on packages *vector* and *safe*.+- Replace *Control.Arrow* with *Data.Bifunctor*.+- **Note**: due to a [bug](https://gitlab.haskell.org/ghc/ghc/-/issues/26136)+  introduced in GHC major versions *9.12*, *9.10*, and *9.8*, the code won't+  compile with GHC *9.12.2*, *9.12.1* (fixed in *9.12.4*), *9.10.2* (fixed in+  *9.10.3*), *9.8.4* (not fixed, compile with *9.8.2*).+ ### 1.6.3  - Added ability to tweak CA store when running health checks over *https*.

@@ -1,4 +1,4 @@-Copyright 2022-2024, Alexey Radkov. All rights reserved.+Copyright 2022-2026, Alexey Radkov. All rights reserved.  Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:

@@ -5,7 +5,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  NgxExport.Healthcheck--- Copyright   :  (c) Alexey Radkov 2022-2024+-- Copyright   :  (c) Alexey Radkov 2022-2026 -- License     :  BSD-style -- -- Maintainer  :  alexey.radkov@gmail.com@@ -14,13 +14,18 @@ -- -- Active health checks and monitoring of Nginx upstreams. --+-- This documentation contains a brief description of the API required for+-- building custom health check modules. For an elaborate explanation of the+-- subject of this module see+-- <https://github.com/lyokha/nginx-healthcheck-plugin#readme>.+-- -----------------------------------------------------------------------------  module NgxExport.Healthcheck (     -- * Type declarations                               module Types #ifdef HEALTHCHECK_HTTPS-    -- * Use a custom CA store+    -- * Use of a custom CA store                              ,useCustomCAStore #endif                              ) where@@ -34,7 +39,6 @@ import qualified Data.Map.Strict as M import qualified Data.Map.Lazy as ML import           Control.Monad-import           Control.Arrow import           Control.Concurrent import           Control.Concurrent.Async import           Control.Exception@@ -45,8 +49,6 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Unsafe as B-import qualified Data.Vector.Mutable as MV-import qualified Data.Vector as V import qualified Data.Text as T import qualified Data.Text.Encoding as T import           Data.Maybe@@ -54,6 +56,7 @@ import           Data.Char import           Data.Ord import           Data.Function+import           Data.Bifunctor import           Foreign.C.Types import           Foreign.C.String import           Foreign.Ptr@@ -61,13 +64,11 @@ import           Foreign.Marshal.Alloc import           Foreign.Marshal.Utils import           Data.Aeson-#if MIN_VERSION_time(1,9,1) import           Data.Fixed-#endif import           Data.Int import           Data.Time.Clock import           Data.Time.Calendar-import           Safe+import           Text.Read  #ifdef HEALTHCHECK_HTTPS import           Data.HashMap.Strict (HashMap)@@ -114,9 +115,6 @@  newtype PassRuleParams = PassRuleParams { responseHttpStatus :: HttpStatus } -defaultPassRuleParams :: PassRuleParams-defaultPassRuleParams = PassRuleParams { responseHttpStatus = 200 }- data TimeInterval = Hr Int                   | Min Int                   | Sec Int@@ -163,10 +161,11 @@ -- | Use a custom CA store in health checks over https. -- -- When doing health checks over https, it's sometimes required to tweak the--- location of the trusted certificates store. This functions implements such a+-- location of the trusted certificates store. This function implements such a -- tweak when it's run from the initialization hook. ----- ==== __Example 1: use a CA store accessible in Nginx worker processes__+-- ==== __Example 1: use a CA store accessible in Nginx worker processes.__+-- -- ===== File /ngx_healthcheck.hs/ -- @ -- {-\# LANGUAGE TemplateHaskell \#-}@@ -196,7 +195,7 @@ --     haskell load \/var\/lib\/nginx\/ngx_healthcheck.so; -- @ ----- ==== __Example 2: use a CA store accessible only in Nginx master process__+-- ==== __Example 2: use a CA store accessible only in Nginx master process.__ -- -- In this case, the /mread/ trick is used to make Nginx master process -- substitute the file content in place of the path contained in the argument@@ -308,23 +307,13 @@ stats = unsafePerformIO $ newIORef (UTCTime (ModifiedJulianDay 0) 0, M.empty) {-# NOINLINE stats #-} -both :: Arrow a => a b c -> a (b, b) (c, c)-both = join (***)--#if MIN_VERSION_time(1,9,1) asIntegerPart :: forall a. HasResolution a => Integer -> Fixed a asIntegerPart = MkFixed . (resolution (undefined :: Fixed a) *) {-# SPECIALIZE INLINE asIntegerPart :: Integer -> Pico #-}-#endif  toNominalDiffTime :: TimeInterval -> NominalDiffTime toNominalDiffTime =-#if MIN_VERSION_time(1,9,1)-    secondsToNominalDiffTime . asIntegerPart-#else-    fromRational . toRational . secondsToDiffTime-#endif-    . fromIntegral . toSec+    secondsToNominalDiffTime . asIntegerPart . fromIntegral . toSec  getUrl :: Url -> Manager -> PeerHostName -> TimeInterval -> IO HttpStatus getUrl url man hname ((1e6 *) . toSec -> tmo) = do@@ -419,12 +408,11 @@         skey' = T.decodeUtf8 skey     cf'' <- readIORef conf >>=         maybe (do-                  let cf'' = readMay $ C8.unpack cf'-                  when (isNothing cf'') $-                      terminateWorkerProcess "Unreadable peers configuration!"-                  let cf''' = fromJust cf''-                  atomicModifyIORef' conf $ (, ()) . M.insert skey' cf'''-                  return cf'''+                  cf'' <- maybe (terminateWorkerProcess+                                    "Unreadable peers configuration!"+                                ) return $ readMaybe $ C8.unpack cf'+                  atomicModifyIORef' conf $ (, ()) . M.insert skey' cf''+                  return cf''               ) return . M.lookup skey'     let !us  = upstreams cf''         ep   = endpoint cf''@@ -444,7 +432,7 @@                     mkHttpsManager us hname #else                     terminateWorkerProcess-                        "Healthcheck plugin wasn't built with support for https"+                        "Healthcheck plugin wasn't built with HTTPS support" #endif                 _ -> return ()             atomicModifyIORef' active $ (, ()) . (skey' :)@@ -465,12 +453,9 @@                     ps' <- forConcurrently ps $ \p ->                         catchBadResponse p $                             query (epUrl ep') (epProto ep') hname p pto-                    let (psGood, psBad) = both (map fst) $+                    let (psGood, psBad) = join bimap (map fst) $                             partition (byPassRule (epPassRule ep')-                                      . (\st -> defaultPassRuleParams-                                            { responseHttpStatus = st }-                                        )-                                      . snd+                                      . PassRuleParams . snd                                       ) $ map (first fst) ps'                         ic = T.intercalate ","                     return $ T.concat [u, "|", ic psBad, "/", ic psGood]@@ -492,8 +477,7 @@ updatePeers :: ByteString -> IO L.ByteString updatePeers (C8.lines -> ls)     | (B.splitAt 1 -> (readFlag -> ck, skey)) : us <- ls = do-        let skey'  = T.decodeUtf8 skey-            skey'' = L.fromStrict skey+        let skey' = T.decodeUtf8 skey         c   <- ngxCyclePtr         umc <- ngxUpstreamMainConfPtr         t   <- ngxCachedTimePtr >>= peek@@ -503,48 +487,46 @@             then throwWhenPeersUninitialized skey' peers'             else when (isNothing $ M.lookup skey' peers') $                 atomicModifyIORef' peers $ (, ()) . M.insert skey' M.empty-        usBad <- MV.replicate (length us) Nothing-        forM_ us $ \ps -> do-            let (T.decodeUtf8 . fst -> !u) = C8.break (== '|') ps-            B.unsafeUseAsCString ps $ \ps' ->-                alloca $ \pv ->-                    alloca $ \pl -> do-                        ((0 ==) -> !ok) <--                            c_healthcheck c umc t ck (fromBool a) ps' pv pl-                        if ok-                            then do-                                v <- peek pv-                                (fromIntegral -> l) <- peek pl-                                (map (second (maybe T.empty snd . T.uncons)-                                      . T.break (== '/')-                                     )-                                     . filter (not . T.null) . T.split (== ',')-                                    . T.decodeUtf8 -> ps'') <--                                    B.unsafePackCStringLen (v, l)-                                let (hname, peers'') =-                                        fromMaybe (toHostName skey', []) $-                                            M.lookup u peers'-                                unless (null peers'' && null ps'') $-                                    atomicModifyIORef' peers $-                                        (, ()) . M.update-                                                 (Just-                                                 . M.insert u (hname, ps'')-                                                 ) skey'-                            else do-                                usBad' <- V.unsafeFreeze usBad-                                let idx = fromJust $-                                        V.findIndex (== Nothing) usBad'-                                usBad'' <- V.unsafeThaw usBad'-                                MV.unsafeWrite usBad'' idx $ Just u-        (V.toList -> usBad') <- V.unsafeFreeze usBad-        let usBad'' = L.fromStrict $ T.encodeUtf8 $ T.intercalate ", " $-                map fromJust $ takeWhile (/= Nothing) usBad'-        return $ if L.null usBad''+        usBad <- reverse <$> foldM+            (\usBad' ps -> do+                let (T.decodeUtf8 . fst -> !u) = C8.break (== '|') ps+                B.unsafeUseAsCString ps $ \ps' ->+                    alloca $ \pv ->+                        alloca $ \pl -> do+                            ((0 ==) -> !ok) <-+                                c_healthcheck c umc t ck (fromBool a) ps' pv pl+                            if ok+                                then do+                                    v <- peek pv+                                    (fromIntegral -> l) <- peek pl+                                    (map (second (maybe T.empty snd . T.uncons)+                                         . T.break (== '/')+                                         )+                                        . filter (not . T.null)+                                        . T.split (== ',')+                                        . T.decodeUtf8 -> ps'') <-+                                        B.unsafePackCStringLen (v, l)+                                    let (hname, peers'') =+                                            fromMaybe (toHostName skey', []) $+                                                M.lookup u peers'+                                    unless (null peers'' && null ps'') $+                                        atomicModifyIORef' peers $+                                            (, ())+                                            . M.update+                                                  (Just+                                                  . M.insert u (hname, ps'')+                                                  ) skey'+                                    return usBad'+                                else return $ u : usBad'+            ) [] us+        return $ if null usBad                      then ""-                     else L.concat ["Healthcheck: upstreams [", usBad''-                                   ,"] from service set ", skey''-                                   ," have failed to process"-                                   ]+                     else let usBad' = T.encodeUtf8 $ T.intercalate ", " usBad+                          in L.concat ["Healthcheck: upstreams ["+                                      ,L.fromStrict usBad'+                                      ,"] from service set ", L.fromStrict skey+                                      ," have failed to process"+                                      ]     | otherwise = throwUserError "Parse error when reading saved peers data!" ngxExportServiceHook 'updatePeers @@ -564,17 +546,15 @@                         else (t', id)                 !psn = f $ M.alter                            (\old ->-                               let !new' = if isNothing old-                                               then ML.singleton skey ps-                                               else ML.insert skey ps $-                                                   snd $ fromJust old+                               let !new' = maybe (ML.singleton skey ps)+                                               (ML.insert skey ps . snd) old                                in Just (t, new')                            ) pid ps'             in (tn, psn)  receiveStats :: L.ByteString -> ByteString -> IO L.ByteString-receiveStats v sint = do-    let !int = toNominalDiffTime $ readDef (Min 5) $ C8.unpack sint+receiveStats v (C8.unpack -> sint) = do+    let !int = toNominalDiffTime $ fromMaybe (Min 5) $ readMaybe sint     updateStats v int     return "done" ngxExportAsyncOnReqBody 'receiveStats@@ -656,7 +636,7 @@         then do             cf' <- maybe (terminateWorkerProcess                              "Unreadable stats server configuration!"-                         ) return $ readMay $ C8.unpack cf+                         ) return $ readMaybe $ C8.unpack cf             let !int = toNominalDiffTime $ ssPurgeInterval cf'             simpleHttpServe (ssConfig $ ssPort cf') $ ssHandler int         else threadDelaySec 5

@@ -1,5 +1,5 @@ name:                  ngx-export-healthcheck-version:               1.6.3+version:               1.6.4 synopsis:              Active health checks and monitoring of Nginx upstreams description:           Active health checks and monitoring of Nginx upstreams.         .@@ -13,7 +13,7 @@ author:                Alexey Radkov <alexey.radkov@gmail.com> maintainer:            Alexey Radkov <alexey.radkov@gmail.com> stability:             stable-copyright:             2022-2024 Alexey Radkov+copyright:             2022-2026 Alexey Radkov category:              Network build-type:            Simple cabal-version:         1.20@@ -30,20 +30,18 @@  library   default-language:    Haskell2010-  build-depends:       base >=4.8 && <5+  build-depends:       base >= 4.8 && < 5                      , ngx-export >= 1.7.1                      , http-client                      , http-client-tls >= 0.3.4                      , http-client-brread-timeout                      , http-types                      , containers-                     , async                      , bytestring-                     , vector                      , text                      , aeson >= 1.0.0.0-                     , time-                     , safe+                     , time >= 1.9.1+                     , async    if flag(SnapStatsServer)     build-depends:     snap-core