diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,13 @@ +### 1.6.2 + +- Fixed validation of server certificates by name (versions *1.6* and *1.6.1* + had no chance to work with *https* as it was expected because of this bug). +- *New feature*: take the host name from the bound server name in the Nginx + upstream configuration when the service key ends with a slash and this is the + only slash inside it. + + **Breaking changes**: internal Haskell/C interoperability protocol has + changed which requires rebuilding of the C plugin. + ### 1.6.1 - Extract host names from service keys and use them in header *Host* and for diff --git a/NgxExport/Healthcheck.hs b/NgxExport/Healthcheck.hs --- a/NgxExport/Healthcheck.hs +++ b/NgxExport/Healthcheck.hs @@ -40,7 +40,6 @@ 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 @@ -64,9 +63,16 @@ import Safe #ifdef HEALTHCHECK_HTTPS +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM +import Data.Default.Class import Network.HTTP.Client.TLS import Network.Connection -import Network.TLS +import Network.TLS hiding (HashSHA256) +import Network.TLS.Extra.Cipher +import System.X509 (getSystemCertificateStore) +import qualified Data.X509.Validation as X509 +import Data.X509 (HashALG (..)) #endif #ifdef SNAP_STATS_SERVER @@ -78,7 +84,6 @@ type Url = String type HttpStatus = Int -type PeerHostName = Text data Conf = Conf { upstreams :: [Upstream] , interval :: TimeInterval @@ -110,11 +115,14 @@ | MinSec Int Int deriving Read +terminateWorkerProcess :: String -> IO a +terminateWorkerProcess = throwIO . TerminateWorkerProcess + conf :: IORef (Map ServiceKey Conf) conf = unsafePerformIO $ newIORef M.empty {-# NOINLINE conf #-} -type NamedPeers = (PeerHostName, Peers) +type NamedPeers = (Maybe PeerHostName, Peers) peers :: IORef (MServiceKey NamedPeers) peers = unsafePerformIO $ newIORef M.empty @@ -131,14 +139,64 @@ #ifdef HEALTHCHECK_HTTPS -httpsManager :: IORef (Map ServiceKey Manager) -httpsManager = unsafePerformIO $ newIORef M.empty +httpsManager :: IORef (HashMap PeerHostName Manager) +httpsManager = unsafePerformIO $ newIORef HM.empty {-# NOINLINE httpsManager #-} -mkTlsManager :: HostName -> IO Manager -mkTlsManager name = newTlsManagerWith $ - mkManagerSettings (TLSSettings $ defaultParamsClient name "") Nothing +foreign import ccall unsafe "plugin_ngx_http_haskell_healthcheck_srv" + c_healthcheck_srv :: Ptr () -> Ptr () -> CString -> Ptr CString -> + Ptr CSize -> IO CIntPtr +mkHttpsManager :: [Upstream] -> Maybe PeerHostName -> IO () +mkHttpsManager us hname = do + hnames <- + case hname of + Nothing -> concat <$> mapM + (\ps -> do + c <- ngxCyclePtr + umc <- ngxUpstreamMainConfPtr + B.useAsCString (T.encodeUtf8 ps) $ \ps' -> + alloca $ \pv -> + alloca $ \pl -> do + ((0 ==) -> !ok) <- + c_healthcheck_srv c umc ps' pv pl + if ok + then do + v <- peek pv + (fromIntegral -> l) <- peek pl + flip finally (free v) $ do + (T.decodeUtf8 -> !v') <- + B.unsafePackCStringLen (v, l) + return $ filter (not . T.null) $ + T.split (== ',') v' + else terminateWorkerProcess $ + "Failed to get servers in upstream " ++ + T.unpack ps ++ "!" + ) us + Just v -> return [v] + man <- mapM (\name -> (name, ) <$> mkManager name) hnames + atomicModifyIORef' httpsManager $ (, ()) . (`HM.union` HM.fromList man) + where mkManager name = do + systemCAStore <- getSystemCertificateStore + let (T.unpack -> h, T.encodeUtf8 -> p) = + second (fromMaybe "" . fmap snd . T.uncons) $ + T.break (':' ==) name + validateName = const . hookValidateName X509.defaultHooks + defaultParams = (defaultParamsClient h p) + { clientShared = def + { sharedCAStore = systemCAStore } + , clientHooks = def + { onServerCertificate = X509.validate HashSHA256 + X509.defaultHooks + { hookValidateName = validateName h } + X509.defaultChecks + } + , clientSupported = def + { supportedCiphers = ciphersuite_default } + } + newTlsManagerWith $ + mkManagerSettings (TLSSettings defaultParams) Nothing + #endif @@ -168,9 +226,6 @@ #endif . fromIntegral . toSec -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 @@ -183,24 +238,25 @@ } ) man -query :: Url -> TransportProtocol -> ServiceKey -> PeerHostName -> Peer -> +query :: Url -> TransportProtocol -> Maybe 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 +query url proto hname p@(addr, hname') tmo = do + let name = fromMaybe hname' hname + man <- getManager proto name + (p, ) <$> getUrl (mkAddr addr url) man name tmo where mkAddr = ((getPrefix proto ++) .) . (++) . T.unpack getPrefix Http = "http://" getPrefix Https = "https://" - getManager Http = return httpManager - getManager Https = + getManager Http _ = return httpManager + getManager Https name = #ifdef HEALTHCHECK_HTTPS - M.lookup skey <$> readIORef httpsManager >>= + HM.lookup name <$> readIORef httpsManager >>= maybe (throwUserError $ - "Secure manager for service key " ++ - T.unpack skey ++ " was not found!" + "Https manager for name " ++ T.unpack name ++ + " wasn't found!" ) return #else - skey `seq` undefined + name `seq` undefined #endif catchBadResponse :: Peer -> IO (Peer, HttpStatus) -> IO (Peer, HttpStatus) @@ -230,11 +286,13 @@ {-# SPECIALIZE INLINE lookupServiceKey :: ServiceKey -> MServiceKey NamedPeers -> MUpstream NamedPeers #-} -toHostName :: ServiceKey -> PeerHostName -toHostName key = let (_, t) = T.break (== ':') key +toHostName :: ServiceKey -> Maybe PeerHostName +toHostName key = let (_, t) = T.break (== '/') key in if T.length t > 1 - then T.tail t - else key + then Just $ T.tail t + else if T.length t == 1 + then Nothing + else Just key throwUserError :: String -> IO a throwUserError = ioError . userError @@ -283,13 +341,7 @@ 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' + mkHttpsManager us hname #else terminateWorkerProcess "Healthcheck plugin wasn't built with support for https" @@ -312,14 +364,14 @@ let (hname, !ps) = fromJust $ M.lookup u peers' ps' <- forConcurrently ps $ \p -> catchBadResponse p $ - query (epUrl ep') (epProto ep') skey' hname p pto + query (epUrl ep') (epProto ep') hname p pto let (psGood, psBad) = both (map fst) $ partition (byPassRule (epPassRule ep') . (\st -> defaultPassRuleParams { responseHttpStatus = st } ) . snd - ) ps' + ) $ map (first fst) ps' ic = T.intercalate "," return $ T.concat [u, "|", ic psBad, "/", ic psGood] return $ concatResult ["1", skey, "\n", B.concat peers''] @@ -363,7 +415,10 @@ then do v <- peek pv (fromIntegral -> l) <- peek pl - (filter (not . T.null) . T.split (== ',') + (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'') = @@ -424,8 +479,8 @@ return "done" ngxExportAsyncOnReqBody 'receiveStats -sendStats' :: IO (Map Int32 (UTCTime, MServiceKey Peers)) -sendStats' = snd <$> readIORef stats +sendStats' :: IO (Map Int32 (UTCTime, MServiceKey FlatPeers)) +sendStats' = M.map (second $ M.map $ M.map $ map fst) . snd <$> readIORef stats sendStats :: ByteString -> IO ContentHandlerResult sendStats = const $ @@ -434,7 +489,7 @@ <$> sendStats' ngxExportAsyncHandler 'sendStats -sendMergedStats' :: IO (MServiceKey AnnotatedPeers) +sendMergedStats' :: IO (MServiceKey AnnotatedFlatPeers) sendMergedStats' = merge <$> sendStats' where merge = M.foldl (ML.unionWith $ M.unionWith pickLatest) ML.empty . M.map (\(t, s) -> ML.map (M.map $ map (t,)) s) @@ -513,7 +568,8 @@ reportPeers :: ByteString -> IO ContentHandlerResult reportPeers = const $ do - (M.map $ M.filter (not . null) . M.map snd -> peers') <- readIORef peers + (M.map $ M.map (map fst) . 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 @@ -1,8 +1,11 @@ module NgxExport.Healthcheck.Types (ServiceKey ,Upstream + ,PeerName + ,PeerHostName ,Peer ,Peers - ,AnnotatedPeers + ,FlatPeers + ,AnnotatedFlatPeers ,MUpstream ,MServiceKey ) where @@ -15,13 +18,19 @@ type ServiceKey = Text -- | Upstream name. type Upstream = Text --- | Peer identifier (actually, IP address of the peer). -type Peer = Text +-- | Peer name (actually, IP address of the peer). +type PeerName = Text +-- | Peer host name (normally, FQDN). +type PeerHostName = Text +-- | Peer identifier. +type Peer = (PeerName, PeerHostName) -- | List of peers. type Peers = [Peer] --- | List of peers annotated by timestamps. -type AnnotatedPeers = [(UTCTime, Peer)] +-- | List of peers without host names. +type FlatPeers = [PeerName] +-- | List of peers without host names annotated by timestamps. +type AnnotatedFlatPeers = [(UTCTime, PeerName)] -- | Map over 'Upstream' keys. type MUpstream a = Map Upstream a 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.1 +version: 1.6.2 synopsis: Active health checks and monitoring of Nginx upstreams description: Active health checks and monitoring of Nginx upstreams. . @@ -49,7 +49,12 @@ if flag(HealthcheckHttps) build-depends: http-client-tls >= 0.3.4 + , unordered-containers + , data-default-class , crypton-connection + , crypton-x509 + , crypton-x509-system + , crypton-x509-validation , tls >= 1.4.0 cpp-options: -DHEALTHCHECK_HTTPS