diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,16 @@ +### 1.2.10 + +- Module *NgxExport.Tools.Resolve*. + + Parameterize collected server data by query data to avoid getting wrong + values when multiple instances of the resolve service are running. + + Use exporters from *ngx-export-tools ≥ 1.2.5* which do not share + configurations between multiple instances of the resolve service. + + Append port numbers to values of collected host names as Nginx directive + *server* accepts such a notation. +- Module *NgxExport.Tools.PCRE*. + + Replace *SingleShotService* mode declaration in service *declareRegexes* by + *rareService* declaration from *ngx-export-tools ≥ 1.2.5*. + ### 1.2.9.1 - Module *NgxExport.Tools.Resolve*. diff --git a/NgxExport/Tools/PCRE.hs b/NgxExport/Tools/PCRE.hs --- a/NgxExport/Tools/PCRE.hs +++ b/NgxExport/Tools/PCRE.hs @@ -163,7 +163,7 @@ declareRegexes :: InputRegexes -> NgxExportService declareRegexes = voidService -ngxExportSimpleServiceTyped 'declareRegexes ''InputRegexes SingleShotService +ngxExportSimpleServiceTyped 'declareRegexes ''InputRegexes rareService compileRegexes :: ByteString -> IO L.ByteString compileRegexes = voidHandler' $ do diff --git a/NgxExport/Tools/Resolve.hs b/NgxExport/Tools/Resolve.hs --- a/NgxExport/Tools/Resolve.hs +++ b/NgxExport/Tools/Resolve.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell, RecordWildCards, BangPatterns, NumDecimals #-} -{-# LANGUAGE DeriveFoldable, TupleSections, LambdaCase, OverloadedStrings #-} +{-# LANGUAGE DerivingStrategies, DeriveAnyClass, DeriveFoldable #-} +{-# LANGUAGE DeriveGeneric, TupleSections, LambdaCase, OverloadedStrings #-} ----------------------------------------------------------------------------- -- | @@ -46,10 +47,14 @@ import Network.HTTP.Client import Network.HTTP.Client.TLS (newTlsManager) import Network.HTTP.Client.BrReadWithTimeout +import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M +import qualified Data.HashMap.Strict as HM +import Data.HashMap.Strict (HashMap) +import Data.Hashable import Data.IORef import Data.Text (Text) import qualified Data.Text as T @@ -67,6 +72,8 @@ import Control.Monad import System.IO.Unsafe import System.Timeout +import Unsafe.Coerce +import GHC.Generics -- $dynamicUpstreams -- @@ -304,7 +311,8 @@ data WeightedList a = Singleton a -- ^ List with a single element | PlainList [a] -- ^ Plain list without weights | WeightedList [(a, Word)] -- ^ Weighted list - deriving (Read, Foldable) + deriving (Read, Eq, Generic, Foldable) + deriving anyclass Hashable -- | Weighted list of domain names. type NameList = WeightedList Name @@ -316,11 +324,24 @@ -- the given upstreams. data PriorityPolicy a = SinglePriority a -- ^ All items go to a single element | PriorityList [a] -- ^ Distribute items by priorities - deriving Read + deriving (Read, Eq, Generic) + deriving anyclass Hashable -- | Priority policy of upstream names. type UNamePriorityPolicy = PriorityPolicy UName +-- FIXME: an awkward hack to avoid using orphan instance Hashable Name, +-- make sure that HashUQuery and UQuery have the same internal representation! +data UQueryGen a = UQueryAGen (WeightedList a) UNamePriorityPolicy + | UQerySRVGen a UNamePriorityPolicy + deriving (Read, Eq, Generic) + deriving anyclass Hashable + +type HashUQuery = UQueryGen ByteString + +hashUQuery :: UQuery -> HashUQuery +hashUQuery = unsafeCoerce + -- | Upstream configuration. -- -- Includes DNS query model and parameters for Nginx /server/ description. @@ -360,8 +381,9 @@ -- | Collected server data. type CollectedServerData = Map UName [ServerData] -collectedServerData :: IORef (TimeInterval, CollectedServerData) -collectedServerData = unsafePerformIO $ newIORef (Unset, M.empty) +collectedServerData :: + IORef (TimeInterval, HashMap HashUQuery CollectedServerData) +collectedServerData = unsafePerformIO $ newIORef (Unset, HM.empty) {-# NOINLINE collectedServerData #-} httpManager :: Manager @@ -438,9 +460,9 @@ ipv4ToServerData :: UData -> UNamePriorityPolicy -> Name -> Maybe Word -> IPv4 -> ServerData ipv4ToServerData UData {..} policy (Name n) weight a = - let (n', port) = C8.span (':' /=) n + let port = snd $ C8.span (':' /=) n showAddr i p = showIPv4 i ++ C8.unpack p - in ServerData (T.pack $ showAddr a port) (T.decodeUtf8 n') + in ServerData (T.pack $ showAddr a port) (T.decodeUtf8 n) (case policy of SinglePriority _ -> fromIntegral <$> weight PriorityList _ -> Nothing @@ -522,25 +544,35 @@ (wt, old) <- readIORef collectedServerData when (wt /= Unset) $ threadDelaySec $ toSec wt let (lTTL, hTTL) = (toTTL waitOnException, toTTL maxWait) - srv <- handleCollectErrors $ - mapConcurrently (withTimeout . collectServerData lTTL) upstreams - let nwt = fromTTL $ max (TTL 1) $ min hTTL $ minimumTTL lTTL $ map fst srv - new = mconcat $ map snd srv - if new == old + srv <- handleCollectErrors waitOnException $ + mapConcurrently (\u@UData {..} -> (hashUQuery uQuery, ) <$> + withTimeout responseTimeout + (collectServerData lTTL u) + ) upstreams + let nwt = fromTTL $ max (TTL 1) $ min hTTL $ minimumTTL lTTL $ + map (fst . snd) srv + new = HM.fromList $ map (second snd) srv + -- FIXME: when there are multiple instances of the service, a healthy + -- instance may overwrite a short TTL written by an unhealthy instance which + -- causes the latter restarts later, and vice versa, an unhealthy instance + -- may write a short TTL which causes a healthy instance restarts sooner + if new `HM.isSubmapOf` old then do when (nwt /= wt) $ - modifyIORef' collectedServerData $ first $ const nwt + atomicModifyIORef' collectedServerData $ + (, ()) . first (const nwt) return "" else do - writeIORef collectedServerData (nwt, new) - return $ encode new + atomicModifyIORef' collectedServerData $ + (, ()) . (const nwt *** (new `HM.union`)) + return $ encode $ M.unions $ HM.elems new where toTTL = TTL . fromIntegral . toSec fromTTL (TTL ttl) = Sec $ fromIntegral ttl - handleCollectErrors = handleAny $ \e -> do - writeIORef collectedServerData (waitOnException, M.empty) + handleCollectErrors t = handleAny $ \e -> do + atomicModifyIORef' collectedServerData $ (, ()) . first (const t) throwIO e - withTimeout act = do - r <- timeout (toTimeout responseTimeout) act + withTimeout t act = do + r <- timeout (toTimeout t) act case r of Nothing -> throwIO $ userError "Collection of server data was timed out" @@ -548,7 +580,7 @@ toTimeout Unset = -1 toTimeout v = toSec v * 1e6 -ngxExportSimpleServiceTyped 'collectUpstreams ''Conf $ +ngxExportSimpleServiceTyped' 'collectUpstreams ''Conf $ PersistentService Nothing -- a list of fully qualified URLs such as 'http://../..' or 'https://../..' @@ -557,6 +589,6 @@ signalUpconf :: Upconf -> NgxExportService signalUpconf = voidHandler' . mapConcurrently_ getUrl -ngxExportSimpleServiceTyped 'signalUpconf ''Upconf $ +ngxExportSimpleServiceTyped' 'signalUpconf ''Upconf $ PersistentService Nothing diff --git a/NgxExport/Tools/Subrequest.hs b/NgxExport/Tools/Subrequest.hs --- a/NgxExport/Tools/Subrequest.hs +++ b/NgxExport/Tools/Subrequest.hs @@ -54,7 +54,7 @@ import NgxExport.Tools.SimpleService import NgxExport.Tools.TimeInterval -import Network.HTTP.Client hiding (ResponseTimeout) +import Network.HTTP.Client hiding (ResponseTimeout, path) import qualified Network.HTTP.Client (HttpExceptionContent (ResponseTimeout)) import Network.HTTP.Client.TLS (newTlsManager) import Network.HTTP.Client.BrReadWithTimeout @@ -212,8 +212,8 @@ -- > $ curl 'http://localhost:8010/?a=Value' -- > In backend, Custom-Header is 'Value' -- --- Let's do a nasty thing. By injecting a comma into the argument /a/ we shall --- break JSON parsing. +-- Let's do a nasty thing. By injecting a double quote into the argument /a/ we +-- shall break JSON parsing. -- -- > $ curl -D- 'http://localhost:8010/?a=Value"' -- > HTTP/1.1 404 Not Found @@ -540,7 +540,7 @@ -- import Data.ByteString (ByteString) -- import qualified Data.ByteString.Lazy as L -- --- import Network.HTTP.Client +-- import Network.HTTP.Client hiding (path) -- import qualified Network.Socket as S -- import qualified Network.Socket.ByteString as SB -- import qualified Data.ByteString.Char8 as C8 @@ -696,7 +696,7 @@ -- -- ==== A simple test -- --- > $ curl -D- 'http://localhost:8010/full/?a=Value"' +-- > $ curl -D- 'http://localhost:8010/full?a=Value"' -- > HTTP/1.1 400 Bad Request -- > Server: nginx/1.17.9 -- > Date: Sat, 04 Apr 2020 12:44:36 GMT @@ -706,9 +706,10 @@ -- > -- > Bad request -- --- Good. Now we see that adding a comma into a JSON field is a bad request. +-- Good. Now we see that injecting a double quote into a JSON field makes a bad +-- request. -- --- > $ curl -D- 'http://localhost:8010/full/?a=Value' +-- > $ curl -D- 'http://localhost:8010/full?a=Value' -- > HTTP/1.1 500 Internal Server Error -- > Server: nginx/1.17.9 -- > Date: Sat, 04 Apr 2020 12:47:11 GMT @@ -722,7 +723,7 @@ -- argument /$arg_p/. Skipping this makes URI look unparsable -- (/http:\/\/127.0.0.1:\//) which leads to the error. -- --- > $ curl -D- 'http://localhost:8010/full/?a=Value&p=8020' +-- > $ curl -D- 'http://localhost:8010/full?a=Value&p=8020' -- > HTTP/1.1 200 OK -- > Server: nginx/1.17.9 -- > Date: Sat, 04 Apr 2020 12:52:03 GMT @@ -739,7 +740,7 @@ -- -- Let's try another port. -- --- > $ curl -D- 'http://localhost:8010/full/?a=Value&p=8021' +-- > $ curl -D- 'http://localhost:8010/full?a=Value&p=8021' -- > HTTP/1.1 502 Bad Gateway -- > Server: nginx/1.17.9 -- > Date: Sat, 04 Apr 2020 12:56:02 GMT @@ -883,7 +884,7 @@ -- -- ==== A simple test -- --- > $ curl -D- 'http://localhost:8010/full/?a=Value&p=8020&proxy=yes' +-- > $ curl -D- 'http://localhost:8010/full?a=Value&p=8020&proxy=yes' -- > HTTP/1.1 200 OK -- > Server: nginx/1.17.9 -- > Date: Fri, 24 Jul 2020 13:14:33 GMT @@ -897,7 +898,7 @@ -- Now let's get an error message in the response after feeding a wrong port -- value. -- --- > $ curl -D- 'http://localhost:8010/full/?a=Value&p=8021&proxy=yes&exc=yes' +-- > $ curl -D- 'http://localhost:8010/full?a=Value&p=8021&proxy=yes&exc=yes' -- > HTTP/1.1 502 Bad Gateway -- > Server: nginx/1.19.4 -- > Date: Mon, 14 Dec 2020 08:24:22 GMT diff --git a/ngx-export-tools-extra.cabal b/ngx-export-tools-extra.cabal --- a/ngx-export-tools-extra.cabal +++ b/ngx-export-tools-extra.cabal @@ -1,5 +1,5 @@ name: ngx-export-tools-extra -version: 1.2.9.1 +version: 1.2.10 synopsis: More extra tools for Nginx Haskell module description: More extra tools for . @@ -40,7 +40,7 @@ , bytestring >= 0.10.0.0 , base64 >= 0.3.0.0 , ngx-export - , ngx-export-tools >= 1.2.3.1 + , ngx-export-tools >= 1.2.5 , http-types >= 0.7.0 , http-client >= 0.5.3 , http-client-tls >= 0.3.4 @@ -55,6 +55,7 @@ , case-insensitive , containers , unordered-containers + , hashable , array , text , safe