diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -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. diff --git a/NgxExport/Healthcheck.hs b/NgxExport/Healthcheck.hs --- a/NgxExport/Healthcheck.hs +++ b/NgxExport/Healthcheck.hs @@ -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 diff --git a/NgxExport/Healthcheck/Types.hs b/NgxExport/Healthcheck/Types.hs --- a/NgxExport/Healthcheck/Types.hs +++ b/NgxExport/Healthcheck/Types.hs @@ -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. 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 +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