diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,19 @@ +### 1.2.9 + +- Module *NgxExport.Tools.Resolve*. + + Correctly print IP addresses in the server data collected in *A* queries. + + Allow setting weights to names in *QueryA* data. + + Allow priority policies in *QueryA* data. + + Now, if the number of upstreams in the priority list is greater than the + number of variations of weights collected in *SRV* queries or set in + *QueryA* data, the remainder of upstreams get servers with the lowest + weight rather than not being specified at all in the collected data. + + Now, with the *PriorityList* policy, weights of servers in the collected + data are deliberately not specified. + + Names in the *QueryA* name list may contain suffix *:port* where *port* is + a port number, this suffix is ignored at resolving step in *collectA* and + only appended to values of the collected server addresses. + ### 1.2.8.1 - Module *NgxExport.Tools.PCRE*. diff --git a/NgxExport/Tools/Aggregate.hs b/NgxExport/Tools/Aggregate.hs --- a/NgxExport/Tools/Aggregate.hs +++ b/NgxExport/Tools/Aggregate.hs @@ -381,9 +381,6 @@ -- have already been terminated. The inactive PIDs get checked every -- /asPurgeInterval/, and data which correspond to PIDs with timestamps older -- than /asPurgeInterval/ get removed. --- --- Be aware that due to limitations of Template Haskell, this name must be --- imported unqualified! data AggregateServerConf = AggregateServerConf { asPort :: Int , asPurgeInterval :: TimeInterval @@ -509,9 +506,6 @@ ] ] #ifdef SNAP_AGGREGATE_SERVER - -- FIXME: name AggregateServerConf must be imported from the user's - -- module unqualified (see details in NgxExport/Tools/SimpleService.hs, - -- function ngxExportSimpleService')! ,ngxExportSimpleServiceTyped fName ''AggregateServerConf SingleShotService #endif diff --git a/NgxExport/Tools/PCRE.hs b/NgxExport/Tools/PCRE.hs --- a/NgxExport/Tools/PCRE.hs +++ b/NgxExport/Tools/PCRE.hs @@ -308,7 +308,7 @@ -- -- > $ curl 'http://localhost:8010/erase/area?user=peter|98' -- > User without area: peter --- > $ curl 'http://localhost:8010/swap?kv=kid|v0012a +-- > $ curl 'http://localhost:8010/swap?kv=kid|v0012a' -- > Swap kid|v0012a = v0012a|kid -- | Type of functions to perform /functional/ substitutions. 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,5 @@ {-# LANGUAGE TemplateHaskell, RecordWildCards, BangPatterns, NumDecimals #-} -{-# LANGUAGE TupleSections, OverloadedStrings #-} +{-# LANGUAGE DeriveFoldable, TupleSections, LambdaCase, OverloadedStrings #-} ----------------------------------------------------------------------------- -- | @@ -24,7 +24,10 @@ UName ,SAddress ,UQuery (..) + ,WeightedList (..) + ,NameList ,PriorityPolicy (..) + ,UNamePriorityPolicy ,UData (..) ,ServerData (..) ,CollectedServerData @@ -75,9 +78,9 @@ -- __/collectUpstreams/__ and signals about this in service callback -- __/signalUpconf/__. Collecting upstreams encompasses DNS queries of /A/ and -- /SRV/ records. The queries are configured independently for each managed --- upstream. With /SRV/ queries, the module allows configuration of complex --- hierarchies of priorities given that compound upstream containers named --- /upstrands/ are in use (they are implemented in +-- upstream. With both /A/ and /SRV/ queries, the module allows configuration +-- of complex hierarchies of priorities given that compound upstream containers +-- named /upstrands/ are in use (they are implemented in -- [nginx-combined-upstreams-module](https://github.com/lyokha/nginx-combined-upstreams-module)). -- -- Additionally, the module exports a number of functions and data types which @@ -222,22 +225,28 @@ -- priority list may contain more than two upstreams, in which case upstreams -- at the beginning of the list will take higher priorities found in the -- collected servers, while the last upstream will take the remainder of the --- priorities. +-- priorities. Generally, given the number of upstreams in the priority list is +-- /N/ and the number of all variations of server priorities collected in the +-- response is /M/, and /N/ is less than /M/, then the remainder of servers with +-- the lowest priorities will inhabit the last upstream in the priority list, +-- and vice versa, if /N/ is greater than /M/, then more than one upstreams at +-- the end of the priority list will contain the same servers of the lowest +-- priority. -- -- Upstreams in the priority list can be put inside of an /upstrand/ to form the -- main and the backup layers of servers. -- -- ==== File /nginx.conf/: upstrand /utest/ -- @ --- upstream utest1 { +-- upstream __/utest1/__ { -- zone utest1 64k; -- upconf_round_robin; -- server localhost:9000; -- } -- -- __/upstrand utest/__ { --- upstream utest; --- upstream utest1; +-- upstream __/utest/__; +-- upstream __/utest1/__; -- order per_request; -- next_upstream_statuses error timeout 5xx; -- next_upstream_timeout 60s; @@ -259,17 +268,38 @@ -- | DNS query model of the upstream(s). -- --- There are 3 ways to get the list of server addresses: +-- There are 4 ways to get the list of server addresses: -- --- - query /A/ records for a list of domain names, --- - query an /SRV/ record for a single service name and then query /A/ records --- for the collected list of domain names, +-- - query /A/ records on a weighted list of domain names, -- - the same as the previous, but distribute collected servers among a list of +-- upstreams according to the weights set in the name list, +-- - query an /SRV/ record on a single service name and then query /A/ records +-- on the collected list of domain names, +-- - the same as the previous, but distribute collected servers among a list of -- upstreams according to the collected priorities. -data UQuery = QueryA [Name] UName -- ^ Query /A/ records - | QuerySRV Name (PriorityPolicy UName) -- ^ Query an /SRV/ record +-- +-- Note that +-- +-- - names in /QueryA/ name list may contain suffix /:port/ (a port number) +-- which is ignored in 'collectA' and only appended to values of 'sAddr' +-- collected by 'collectServerData', +-- - when priority policy is 'PriorityList', vaues of 'sWeight' collected by +-- 'collectServerData' are deliberately /Nothing/. +data UQuery = QueryA NameList UNamePriorityPolicy -- ^ Query /A/ records + | QuerySRV Name UNamePriorityPolicy -- ^ Query an /SRV/ record deriving Read +-- | Weighted list. +-- +-- A list of elements optionally annotated by weight values. +data WeightedList a = Singleton a -- ^ List with a single element + | PlainList [a] -- ^ Plain list without weights + | WeightedList [(a, Word)] -- ^ Weighted list + deriving (Read, Foldable) + +-- | Weighted list of domain names. +type NameList = WeightedList Name + -- | Priority policy. -- -- Specifies how to distribute collected items by priorities. In particular, @@ -279,14 +309,17 @@ | PriorityList [a] -- ^ Distribute items by priorities deriving Read +-- | Priority policy of upstream names. +type UNamePriorityPolicy = PriorityPolicy UName + -- | Upstream configuration. -- -- Includes DNS query model and parameters for Nginx /server/ description. -- Values of /uMaxFails/ and /uFailTimeout/ get assigned to each collected --- server as /max_fails/ and /fail_timeout/ respectively. The weight of an --- individual server gets picked from the value of 'srvWeight' collected in --- /SRV/ queries. Note that setting of parameters /max_conns/, /backup/ and --- /down/ is not supported. +-- server as /max_fails/ and /fail_timeout/ respectively. For /SRV/ queries, +-- weights of individual servers will be picked from the values of 'srvWeight' +-- collected in the query. Note that setting of parameters /max_conns/, +-- /backup/ and /down/ is not supported. data UData = UData { uQuery :: UQuery -- ^ DNS query model , uMaxFails :: Int -- ^ /max_fails/ , uFailTimeout :: Int -- ^ /fail_timeout/ @@ -348,8 +381,8 @@ :: TTL -- ^ Fallback TTL value -> Name -- ^ Domain name -> IO (TTL, [IPv4]) -collectA lTTL name = do - !srv <- queryA name +collectA lTTL (Name n) = do + !srv <- queryA $ Name $ C8.takeWhile (':' /=) n return (minimumTTL lTTL $ map fst srv, map snd srv) -- | Queries an /SRV/ record for the given service name. @@ -368,22 +401,17 @@ collectSRV lTTL name = do !srv <- querySRV name !srv' <- mapConcurrently - ((\s@SRV {..} -> do - (t, is) <- collectA lTTL srvTarget - return (t - ,map (\v -> - s { srvTarget = - (removeTrailingDot srvTarget, v) - } - ) is - ) + ((\s@SRV {..} -> + second (map $ \v -> (, v) . removeTrailingDot <$> s) <$> + collectA lTTL srvTarget ) . snd ) srv return (min (minimumTTL lTTL $ map fst srv) (minimumTTL lTTL $ map fst srv') ,concatMap snd srv' ) - where removeTrailingDot (Name v) = Name $ maybe v fst $ C8.unsnoc v + where removeTrailingDot (Name v) = Name $ + maybe v (\case (v', '.') -> v'; _ -> v) $ C8.unsnoc v showIPv4 :: IPv4 -> String showIPv4 (IPv4 w) = @@ -393,17 +421,43 @@ shows ( w .&. 0xff) "" -ipv4ToServerData :: UData -> Name -> IPv4 -> ServerData -ipv4ToServerData UData {..} (Name n) i = - ServerData (T.pack $ show i) (T.decodeUtf8 n) - Nothing (Just uMaxFails) (Just uFailTimeout) +partitionByPriority :: (Eq b, Ord b) => (a -> b) -> [a] -> [[a]] +partitionByPriority f = groupBy ((==) `on` f) . sortOn f -srvToServerData :: UData -> SRV (Name, IPv4) -> ServerData -srvToServerData UData {..} SRV {..} = +zipWithPriorityList :: UNamePriorityPolicy -> [a] -> [(UName, a)] +zipWithPriorityList (PriorityList []) _ = [] +zipWithPriorityList (PriorityList _) [] = [] +zipWithPriorityList (PriorityList pl) vs = + let (lpl, lastp) = lengthAndLast pl + (lvs, lastv) = lengthAndLast vs + in uncurry zip $ if lpl > lvs + then (pl, vs ++ repeat lastv) + else (pl ++ repeat lastp, vs) + where lengthAndLast = + foldl' (\(l, _) v -> (succ l, v)) (0 :: Int, undefined) +zipWithPriorityList _ _ = undefined + +ipv4ToServerData :: UData -> UNamePriorityPolicy -> Name -> Maybe Word -> + IPv4 -> ServerData +ipv4ToServerData UData {..} policy (Name n) weight a = + let (n', port) = C8.span (':' /=) n + showAddr i p = showIPv4 i ++ C8.unpack p + in ServerData (T.pack $ showAddr a port) (T.decodeUtf8 n') + (case policy of + SinglePriority _ -> fromIntegral <$> weight + PriorityList _ -> Nothing + ) (Just uMaxFails) (Just uFailTimeout) + +srvToServerData :: UData -> UNamePriorityPolicy -> SRV (Name, IPv4) -> + ServerData +srvToServerData UData {..} policy SRV {..} = let (Name n, a) = srvTarget showAddr i p = showIPv4 i ++ ':' : show p in ServerData (T.pack $ showAddr a srvPort) (T.decodeUtf8 n) - (Just $ fromIntegral srvWeight) (Just uMaxFails) (Just uFailTimeout) + (case policy of + SinglePriority _ -> Just $ fromIntegral srvWeight + PriorityList _ -> Nothing + ) (Just uMaxFails) (Just uFailTimeout) -- | Collects server data for the given upstream configuration. -- @@ -415,33 +469,55 @@ :: TTL -- ^ Fallback TTL value -> UData -- ^ Upstream configuration -> IO (TTL, CollectedServerData) -collectServerData lTTL (UData (QueryA [] _) _ _) = - return (lTTL, M.empty) -collectServerData lTTL ud@(UData (QueryA ns u) _ _) = do - a <- mapConcurrently (\n -> (n, ) <$> collectA lTTL n) ns +collectServerData lTTL (UData (QueryA ns p) _ _) + | null ns = return (lTTL, M.empty) + | PriorityList [] <- p = return (lTTL, M.empty) +collectServerData lTTL ud@(UData (QueryA + (WeightedList ns) p@(PriorityList _) + ) _ _ + ) = do + a <- mapConcurrently (\nw@(n, _) -> (nw, ) <$> collectA lTTL n) ns return $ - minimum *** M.singleton u . concat $ - foldr (\(n, (t, s)) (ts, ss) -> - -- sort is required because resolver may rotate servers - -- which means that the same data may differ after every - -- single check; this note regards to other clauses of - -- this function as well - (t : ts, sort (map (ipv4ToServerData ud n) s) : ss) + minimum *** + M.fromList . zipWithPriorityList p + . map (map snd) . partitionByPriority fst . concat $ + foldr (\((n, w), (t, s)) (ts, ss) -> + (t : ts + -- sort is required because resolver may rotate + -- servers which means that the same data may differ + -- after every single check; this note regards to + -- other clauses of this function as well + ,sort (map ((w ,) . + ipv4ToServerData ud p n (Just w) + ) s + ) : ss + ) + ) ([], []) a +collectServerData lTTL ud@(UData (QueryA ns p) _ _) = do + let ns' = case ns of + Singleton n -> pure (n, Nothing) + PlainList ns'' -> map (, Nothing) ns'' + WeightedList ns'' -> map (second Just) ns'' + a <- mapConcurrently (\nw@(n, _) -> (nw, ) <$> collectA lTTL n) ns' + let f = case p of + SinglePriority u -> M.singleton u + PriorityList pl -> \v -> M.fromList $ map (, v) pl + return $ + minimum *** f . concat $ + foldr (\((n, w), (t, s)) (ts, ss) -> + (t : ts, sort (map (ipv4ToServerData ud p n w) s) : ss) ) ([], []) a -collectServerData lTTL ud@(UData (QuerySRV n (SinglePriority u)) _ _) = do +collectServerData lTTL ud@(UData (QuerySRV n p@(SinglePriority u)) _ _) = do (wt, srv) <- collectSRV lTTL n - return (wt, M.singleton u $ sort $ map (srvToServerData ud) srv) + return (wt, M.singleton u $ sort $ map (srvToServerData ud p) srv) collectServerData lTTL (UData (QuerySRV _ (PriorityList [])) _ _) = return (lTTL, M.empty) -collectServerData lTTL ud@(UData (QuerySRV n (PriorityList pl)) _ _ ) = do +collectServerData lTTL ud@(UData (QuerySRV n p@(PriorityList _)) _ _ ) = do (wt, srv) <- collectSRV lTTL n - let srv' = zip (withTrail pl) $ partitionByPriority srv + let srv' = zipWithPriorityList p $ partitionByPriority srvPriority srv return (wt - ,M.fromList $ map (second $ sort . map (srvToServerData ud)) srv' + ,M.fromList $ map (second $ sort . map (srvToServerData ud p)) srv' ) - where partitionByPriority = - groupBy ((==) `on` srvPriority) . sortOn srvPriority - withTrail = uncurry (++) . (id &&& repeat . last) collectUpstreams :: Conf -> NgxExportService collectUpstreams Conf {..} = const $ do diff --git a/NgxExport/Tools/Subrequest.hs b/NgxExport/Tools/Subrequest.hs --- a/NgxExport/Tools/Subrequest.hs +++ b/NgxExport/Tools/Subrequest.hs @@ -597,11 +597,12 @@ -- | Registers a custom HTTP manager with a given key. -- --- The right place to register a custom manager is a custom service handler that --- runs just after the start of an Nginx worker process. Registered managers can --- then be referred to from subrequest configurations by the key in field --- /manager/ (in JSON-encoded configurations) or as /srManager = Custom \"key\"/ --- (in /read/-encoded configurations). +-- The right place to register a custom manager is a custom service handler or +-- the initialization hook (see 'ngxExportInitHook') which runs soon after the +-- start of an Nginx worker process. Registered managers can then be referred to +-- from subrequest configurations by the key in field /manager/ (in JSON-encoded +-- configurations) or as /srManager = Custom \"key\"/ (in /read/-encoded +-- configurations). -- -- Below is an example of a JSON-encoded subrequest configuration. -- 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.8.1 +version: 1.2.9 synopsis: More extra tools for Nginx Haskell module description: More extra tools for .