ngx-export-healthcheck 1.6 → 1.6.1
raw patch · 4 files changed
+120/−37 lines, 4 filesdep +crypton-connectiondep +tlsPVP ok
version bump matches the API change (PVP)
Dependencies added: crypton-connection, tls
API changes (from Hackage documentation)
Files
- Changelog.md +7/−0
- NgxExport/Healthcheck.hs +102/−35
- NgxExport/Healthcheck/Types.hs +1/−1
- ngx-export-healthcheck.cabal +10/−1
Changelog.md view
@@ -1,3 +1,10 @@+### 1.6.1++- Extract host names from service keys and use them in header *Host* and for+ validation of server certificates in health checks over *https*.+- Conditional building of the *https* support controlled by Cabal flag+ *HealthcheckHttps*.+ ### 1.6 - Added support for *https* transport protocol.
NgxExport/Healthcheck.hs view
@@ -21,7 +21,6 @@ import NgxExport import NgxExport.Healthcheck.Types as Types import Network.HTTP.Client-import Network.HTTP.Client.TLS (newTlsManager) import Network.HTTP.Client.BrReadWithTimeout import Network.HTTP.Types.Status import Data.Map (Map)@@ -41,6 +40,7 @@ import qualified Data.ByteString.Unsafe as B import qualified Data.Vector.Mutable as MV import qualified Data.Vector as V+import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Maybe@@ -63,6 +63,12 @@ import Data.Time.Calendar import Safe +#ifdef HEALTHCHECK_HTTPS+import Network.HTTP.Client.TLS+import Network.Connection+import Network.TLS+#endif+ #ifdef SNAP_STATS_SERVER import Control.Monad.IO.Class import Control.Exception.Enclosed (handleAny)@@ -72,6 +78,7 @@ type Url = String type HttpStatus = Int+type PeerHostName = Text data Conf = Conf { upstreams :: [Upstream] , interval :: TimeInterval@@ -107,7 +114,9 @@ conf = unsafePerformIO $ newIORef M.empty {-# NOINLINE conf #-} -peers :: IORef (MServiceKey Peers)+type NamedPeers = (PeerHostName, Peers)++peers :: IORef (MServiceKey NamedPeers) peers = unsafePerformIO $ newIORef M.empty {-# NOINLINE peers #-} @@ -116,9 +125,23 @@ {-# NOINLINE active #-} httpManager :: Manager-httpManager = unsafePerformIO newTlsManager+httpManager = unsafePerformIO $ newManager defaultManagerSettings {-# NOINLINE httpManager #-} ++#ifdef HEALTHCHECK_HTTPS++httpsManager :: IORef (Map ServiceKey Manager)+httpsManager = unsafePerformIO $ newIORef M.empty+{-# NOINLINE httpsManager #-}++mkTlsManager :: HostName -> IO Manager+mkTlsManager name = newTlsManagerWith $+ mkManagerSettings (TLSSettings $ defaultParamsClient name "") Nothing++#endif++ data StatsServerConf = StatsServerConf { ssPort :: Int , ssPurgeInterval :: TimeInterval } deriving Read@@ -145,23 +168,40 @@ #endif . fromIntegral . toSec -getUrl :: Url -> TimeInterval -> IO HttpStatus-getUrl url ((1e6 *) . toSec -> tmo) = do+terminateWorkerProcess :: String -> IO a+terminateWorkerProcess = throwIO . TerminateWorkerProcess++getUrl :: Url -> Manager -> PeerHostName -> TimeInterval -> IO HttpStatus+getUrl url man hname ((1e6 *) . toSec -> tmo) = do -- Note: using here httpNoBody makes Nginx backends claim about closed -- keepalive connections! request <- parseRequest url statusCode . responseStatus <$> httpLbsBrReadWithTimeout- (request { responseTimeout = responseTimeoutMicro tmo })- httpManager+ (request { responseTimeout = responseTimeoutMicro tmo+ , requestHeaders = [("Host", T.encodeUtf8 hname)]+ }+ ) man -query :: Url -> TransportProtocol -> TimeInterval -> Peer ->- IO (Peer, HttpStatus)-query url proto tmo p =- (p, ) <$> getUrl (mkAddr p url) tmo- where mkAddr = ((fromProto proto ++) .) . (++) . T.unpack- fromProto Http = "http://"- fromProto Https = "https://"+query :: Url -> TransportProtocol -> ServiceKey -> PeerHostName -> Peer ->+ TimeInterval -> IO (Peer, HttpStatus)+query url proto skey hname p tmo = do+ man <- getManager proto+ (p, ) <$> getUrl (mkAddr p url) man hname tmo+ where mkAddr = ((getPrefix proto ++) .) . (++) . T.unpack+ getPrefix Http = "http://"+ getPrefix Https = "https://"+ getManager Http = return httpManager+ getManager Https =+#ifdef HEALTHCHECK_HTTPS+ M.lookup skey <$> readIORef httpsManager >>=+ maybe (throwUserError $+ "Secure manager for service key " +++ T.unpack skey ++ " was not found!"+ ) return+#else+ skey `seq` undefined+#endif catchBadResponse :: Peer -> IO (Peer, HttpStatus) -> IO (Peer, HttpStatus) catchBadResponse p = handle $ \(_ :: SomeException) -> return (p, 0)@@ -185,15 +225,25 @@ isActive :: ServiceKey -> IO Bool isActive skey = (skey `elem`) <$> readIORef active -lookupServiceKey :: ServiceKey -> MServiceKey Peers -> MUpstream Peers+lookupServiceKey :: ServiceKey -> MServiceKey a -> MUpstream a lookupServiceKey = (fromMaybe M.empty .) . M.lookup+{-# SPECIALIZE INLINE lookupServiceKey ::+ ServiceKey -> MServiceKey NamedPeers -> MUpstream NamedPeers #-} +toHostName :: ServiceKey -> PeerHostName+toHostName key = let (_, t) = T.break (== ':') key+ in if T.length t > 1+ then T.tail t+ else key+ throwUserError :: String -> IO a throwUserError = ioError . userError -throwWhenPeersUninitialized :: ServiceKey -> MUpstream Peers -> IO ()+throwWhenPeersUninitialized :: ServiceKey -> MUpstream a -> IO () throwWhenPeersUninitialized skey ps = when (M.null ps) $ throwUserError $ "Peers were not initialized for service set " ++ T.unpack skey ++ "!"+{-# SPECIALIZE INLINE throwWhenPeersUninitialized ::+ ServiceKey -> MUpstream NamedPeers -> IO () #-} reportStats :: Int -> (Int32, ServiceKey, MUpstream Peers) -> IO () reportStats ssp v = do@@ -212,8 +262,8 @@ cf'' <- readIORef conf >>= maybe (do let cf'' = readMay $ C8.unpack cf'- when (isNothing cf'') $ throwIO $- TerminateWorkerProcess "Unreadable peers configuration!"+ when (isNothing cf'') $+ terminateWorkerProcess "Unreadable peers configuration!" let cf''' = fromJust cf'' atomicModifyIORef' conf $ (, ()) . M.insert skey' cf''' return cf'''@@ -226,8 +276,25 @@ if fstRun then do peers' <- lookupServiceKey skey' <$> readIORef peers- let peers'' = foldr (flip (M.insertWith $ const id) []) peers' us+ let hname = toHostName skey'+ peers'' = foldr (flip (M.insertWith $ const id) (hname, []))+ peers' us atomicModifyIORef' peers $ (, ()) . M.insert skey' peers''+ when (isJust ep) $ case epProto $ fromJust ep of+ Https ->+#ifdef HEALTHCHECK_HTTPS+ readIORef httpsManager >>=+ maybe (atomicModifyIORef' httpsManager $+ (, ()) . M.insert skey'+ (unsafePerformIO $+ mkTlsManager $ T.unpack hname+ )+ ) (void . return) . M.lookup skey'+#else+ terminateWorkerProcess+ "Healthcheck plugin wasn't built with support for https"+#endif+ _ -> return () atomicModifyIORef' active $ (, ()) . (skey' :) else threadDelaySec $ toSec int peers' <- lookupServiceKey skey' <$> readIORef peers@@ -235,21 +302,19 @@ when (isJust ssp) $ do (fromIntegral -> pid) <- ngxCachedPid void $ async $ reportStats (fromJust ssp)- (pid, skey', M.filter (not . null) peers')+ (pid, skey', M.filter (not . null) $ M.map snd peers') let concatResult = L.fromStrict . B.concat if isJust ep then do- let ep' = fromJust ep- url = epUrl ep'- proto = epProto ep'- rule = epPassRule ep'+ let ep' = fromJust ep (map (flip B.append "\0\n" . T.encodeUtf8) -> peers'') <- forConcurrently us $ \u -> do- let !ps = fromJust $ M.lookup u peers'+ let (hname, !ps) = fromJust $ M.lookup u peers' ps' <- forConcurrently ps $ \p ->- catchBadResponse p $ query url proto pto p+ catchBadResponse p $+ query (epUrl ep') (epProto ep') skey' hname p pto let (psGood, psBad) = both (map fst) $- partition (byPassRule rule+ partition (byPassRule (epPassRule ep') . (\st -> defaultPassRuleParams { responseHttpStatus = st } )@@ -301,11 +366,15 @@ (filter (not . T.null) . T.split (== ',') . T.decodeUtf8 -> ps'') <- B.unsafePackCStringLen (v, l)- let peers'' = fromMaybe [] $ M.lookup u peers'+ let (hname, peers'') =+ fromMaybe (toHostName skey', []) $+ M.lookup u peers' unless (null peers'' && null ps'') $ atomicModifyIORef' peers $ (, ()) . M.update- (Just . M.insert u ps'') skey'+ (Just+ . M.insert u (hname, ps'')+ ) skey' else do usBad' <- V.unsafeFreeze usBad let idx = fromJust $@@ -335,8 +404,7 @@ let (!tn, f) = if diffUTCTime t t' >= int then (t- ,M.filter $- \(t'', _) -> diffUTCTime t t'' < int+ ,M.filter $ \(t'', _) -> diffUTCTime t t'' < int ) else (t', id) !psn = f $ M.alter@@ -431,9 +499,8 @@ statsServer cf fstRun = do if fstRun then do- cf' <- maybe (throwIO $- TerminateWorkerProcess- "Unreadable stats server configuration!"+ cf' <- maybe (terminateWorkerProcess+ "Unreadable stats server configuration!" ) return $ readMay $ C8.unpack cf let !int = toNominalDiffTime $ ssPurgeInterval cf' simpleHttpServe (ssConfig $ ssPort cf') $ ssHandler int@@ -446,7 +513,7 @@ reportPeers :: ByteString -> IO ContentHandlerResult reportPeers = const $ do- (M.map $ M.filter $ not . null -> peers') <- readIORef peers+ (M.map $ M.filter (not . null) . M.map snd -> peers') <- readIORef peers return (encode peers', "application/json", 200, []) ngxExportAsyncHandler 'reportPeers
NgxExport/Healthcheck/Types.hs view
@@ -15,7 +15,7 @@ type ServiceKey = Text -- | Upstream name. type Upstream = Text--- | Peer identifier.+-- | Peer identifier (actually, IP address of the peer). type Peer = Text -- | List of peers.
ngx-export-healthcheck.cabal view
@@ -1,5 +1,5 @@ name: ngx-export-healthcheck-version: 1.6+version: 1.6.1 synopsis: Active health checks and monitoring of Nginx upstreams description: Active health checks and monitoring of Nginx upstreams. .@@ -21,6 +21,9 @@ flag SnapStatsServer description: Build Snap server to collect stats. +flag HealthcheckHttps+ description: Support secure connections to endpoints.+ library default-language: Haskell2010 build-depends: base >=4.8 && <5@@ -43,6 +46,12 @@ , snap-server , enclosed-exceptions cpp-options: -DSNAP_STATS_SERVER++ if flag(HealthcheckHttps)+ build-depends: http-client-tls >= 0.3.4+ , crypton-connection+ , tls >= 1.4.0+ cpp-options: -DHEALTHCHECK_HTTPS exposed-modules: NgxExport.Healthcheck