ngx-export-healthcheck 1.6.1 → 1.6.2

raw patch · 4 files changed

+126/−46 lines, 4 filesdep +crypton-x509dep +crypton-x509-systemdep +crypton-x509-validationPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: crypton-x509, crypton-x509-system, crypton-x509-validation, data-default-class, unordered-containers

API changes (from Hackage documentation)

Files

• Changelog.md +10/−0
• NgxExport/Healthcheck.hs +96/−40
• NgxExport/Healthcheck/Types.hs +14/−5
• ngx-export-healthcheck.cabal +6/−1

@@ -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

@@ -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 

@@ -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

@@ -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