diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -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*. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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: diff --git a/NgxExport/Healthcheck.hs b/NgxExport/Healthcheck.hs --- a/NgxExport/Healthcheck.hs +++ b/NgxExport/Healthcheck.hs @@ -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 +-- . +-- ----------------------------------------------------------------------------- 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 diff --git a/ngx-export-healthcheck.cabal b/ngx-export-healthcheck.cabal --- a/ngx-export-healthcheck.cabal +++ b/ngx-export-healthcheck.cabal @@ -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 maintainer: Alexey Radkov 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