ngx-export-tools-extra 1.2.4 → 1.2.5

raw patch · 4 files changed

+68/−88 lines, 4 filesdep ~pcre-lightPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: pcre-light

API changes (from Hackage documentation)

Files

• Changelog.md +12/−0
• NgxExport/Tools/PCRE.hs +3/−40
• NgxExport/Tools/Resolve.hs +51/−46
• ngx-export-tools-extra.cabal +2/−2

@@ -1,3 +1,15 @@+### 1.2.5++- Module *NgxExport.Tools.Resolve*.+  + Function *collectSrv* now returns a *TTL* with a list of pairs+    *(Domain name, IP address)* wrapped in an *SRV* container.+  + Collection *ServerData* now contains the host name.+  + Allow multiple *upconf* endpoints, secure and insecure.+  + Removed *instance FromJSON ServerData*.+- Module *NgxExport.Tools.PCRE*.+  + Removed internal implementation of function *compile* which now requires+    *pcre-light ≥ 0.4.1.2*.+ ### 1.2.4  - Added support for *https* connections in module *NgxExport.Tools.Subrequest*.

@@ -1,12 +1,9 @@ {-# LANGUAGE TemplateHaskell, BangPatterns, OverloadedStrings #-}-{-# LANGUAGE ForeignFunctionInterface, CApiFFI #-} -{-# OPTIONS_GHC -fno-warn-dodgy-foreign-imports #-}- ----------------------------------------------------------------------------- -- | -- Module      :  NgxExport.Tools.PCRE--- Copyright   :  (c) Alexey Radkov 2021-2022+-- Copyright   :  (c) Alexey Radkov 2021-2023 -- License     :  BSD-style -- -- Maintainer  :  alexey.radkov@gmail.com@@ -43,16 +40,10 @@ import           Data.List import           Data.Maybe import           Data.IORef-import           Text.Regex.PCRE.Light hiding (compile, compileM)-import           Text.Regex.PCRE.Light.Base-import           Text.Regex.PCRE.Heavy hiding (compileM)+import           Text.Regex.PCRE.Light+import           Text.Regex.PCRE.Heavy import           Control.Exception (Exception, throwIO) import           Control.Arrow-import           Foreign.Ptr-import           Foreign.ForeignPtr-import           Foreign.C.String-import           Foreign.Storable-import           Foreign.Marshal.Alloc import           System.IO.Unsafe  -- $matchingPCRE@@ -172,34 +163,6 @@ declareRegexes = ignitionService $ const $ return ""  ngxExportSimpleServiceTyped 'declareRegexes ''InputRegexes SingleShotService---{- SPLICE: compile with pcre_free finalizer, mostly adopted from pcre-light -}--foreign import capi "pcre.h value pcre_free" c_pcre_free' :: FinalizerPtr a--compile :: ByteString -> [PCREOption] -> Regex-compile s o = case compileM s o of-    Right r -> r-    Left e -> error ("Text.Regex.PCRE.Light: Error in regex: " ++ e)--compileM :: ByteString -> [PCREOption] -> Either String Regex-compileM str os = unsafePerformIO $-    C8.useAsCString str $ \ptn ->-        alloca $ \errptr ->-            alloca $ \erroffset -> do-                pcre_ptr <- c_pcre_compile ptn (combineOptions os)-                    errptr erroffset nullPtr-                if pcre_ptr == nullPtr-                    then do-                        err <- peekCString =<< peek errptr-                        return (Left err)-                    else do-                        reg <- newForeignPtr c_pcre_free' pcre_ptr-                        return (Right (Regex reg str))--{- SPLICE: END -}-  compileRegexes :: ByteString -> IO L.ByteString compileRegexes = const $ do

@@ -1,5 +1,5 @@ {-# LANGUAGE TemplateHaskell, RecordWildCards, BangPatterns, NumDecimals #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections, OverloadedStrings #-}  ----------------------------------------------------------------------------- -- |@@ -40,12 +40,16 @@  import           Network.DNS import           Network.HTTP.Client+import           Network.HTTP.Client.TLS (newTlsManager)+import           Network.HTTP.Client.BrReadWithTimeout+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           Data.IORef import           Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.Encoding as T import           Data.Maybe import           Data.Aeson import           Data.Function@@ -131,8 +135,7 @@ --     haskell_service_var_in_shm upstreams 64k \/tmp $hs_upstreams; -- --     haskell_service_var_update_callback __/simpleService_signalUpconf/__ $hs_upstreams---         \'Upconf { upconfAddr = (\"__/\/upconf/__\", \"127.0.0.1:8010\")---                 }\';+--         \'[\"http:\/\/127.0.0.1:8010__/\/upconf/__\"]\'; -- --     server { --         listen          localhost:8010;@@ -174,14 +177,17 @@ -- which reports /Not configured/, but so soon as service /collectUpstreams/ -- collects servers for the upstream in variable __/$hs_upstreams/__, and then -- the /upconf/ module gets notified about this via callback /signalUpconf/, the--- upstream gets inhabited by the collected servers. The upstream contents will--- be re-checked within the time interval of /(1 or waitOnException, maxWait)/.--- Particularly, if an exception happens during the collection of the servers,--- then the service will restart in /waitOnException/. If there were no--- exceptions and the smallest value of /TTL/ calculated from all collected--- servers does not exceed the value of /maxWait/, then the service will restart--- in this time.+-- upstream gets inhabited by the collected servers. Notice that /signalUpconf/+-- accepts a /list/ of URLs which means that it can broadcast collected servers+-- to multiple /upconf/ endpoints listening on this or other hosts. --+-- The upstream contents will be re-checked within the time interval of+-- /(1 or waitOnException, maxWait)/. Particularly, if an exception happens+-- during the collection of the servers, then the service will restart in+-- /waitOnException/. If there were no exceptions and the smallest value of+-- /TTL/ calculated from all collected servers does not exceed the value of+-- /maxWait/, then the service will restart in this time.+-- -- Too big response times may also cause exceptions during the collection of the -- servers. The timeout is defined by the value of /responseTimeout/. In our -- example, the timeout is not set.@@ -247,9 +253,6 @@ -- | Upstream name. type UName = Text --- URL, normally starts with /-type SUrl = Text- -- | Domain name or IP address with or without port. type SAddress = Text @@ -294,28 +297,20 @@                  , responseTimeout :: TimeInterval                  } deriving Read -newtype Upconf = Upconf { upconfAddr :: (SUrl, SAddress) } deriving Read- -- | Server data. -- -- The fields map exactly to parameters from Nginx /server/ description. data ServerData = ServerData { sAddr        :: SAddress   -- ^ Server address+                             , sHost        :: SAddress   -- ^ Server host name                              , sWeight      :: Maybe Int  -- ^ /weight/                              , sMaxFails    :: Maybe Int  -- ^ /max_fails/                              , sFailTimeout :: Maybe Int  -- ^ /fail_timeout/                              } deriving (Show, Eq, Ord) -instance FromJSON ServerData where-    parseJSON = withObject "server_options" $ \o -> do-        sAddr        <- o .:  "addr"-        sWeight      <- o .:? "weight"-        sMaxFails    <- o .:? "max_fails"-        sFailTimeout <- o .:? "fail_timeout"-        return ServerData {..}- instance ToJSON ServerData where     toJSON ServerData {..} =         object $ catMaybes [ pure $ "addr"   .=      sAddr+                           , pure $ "host"   .=      sHost                            , ("weight"       .=) <$> sWeight                            , ("max_fails"    .=) <$> sMaxFails                            , ("fail_timeout" .=) <$> sFailTimeout@@ -329,7 +324,7 @@ {-# NOINLINE collectedServerData #-}  httpManager :: Manager-httpManager = unsafePerformIO $ newManager defaultManagerSettings+httpManager = unsafePerformIO newTlsManager {-# NOINLINE httpManager #-}  getResponse :: Text -> (Request -> IO (Response L.ByteString)) ->@@ -337,11 +332,7 @@ getResponse url = fmap responseBody . (parseUrlThrow (T.unpack url) >>=)  getUrl :: Text -> IO L.ByteString-getUrl url = getResponse url $ flip httpLbs httpManager--queryHTTP :: Text -> Text -> IO L.ByteString-queryHTTP = (getUrl .) . flip mkAddr-    where mkAddr = (("http://" `T.append`) .) . T.append+getUrl url = getResponse url $ flip httpLbsBrReadWithTimeout httpManager  minimumTTL :: TTL -> [TTL] -> TTL minimumTTL lTTL [] = lTTL@@ -364,25 +355,34 @@ -- -- After getting the /SRV/ record, runs 'collectA' for each collected element. ----- Returns a list of IP addresses wrapped in an 'SRV' container and the minimum--- value of their TTLs. If the list is empty, then the returned TTL value gets--- taken from the first argument.+-- Returns a list of pairs /(Domain name, IP address)/ wrapped in an 'SRV'+-- container and the minimum value of their TTLs. If the list is empty, then+-- the returned TTL value gets taken from the first argument. Note that trailing+-- dots in the collected domain names (as in /www.mycompany.com./) get removed+-- in the returned list. collectSRV     :: TTL                      -- ^ Fallback TTL value     -> Name                     -- ^ Service name-    -> IO (TTL, [SRV IPv4])+    -> IO (TTL, [SRV (Name, IPv4)]) collectSRV lTTL name = do     !srv <- querySRV name     !srv' <- mapConcurrently                  ((\s@SRV {..} -> do                      (t, is) <- collectA lTTL srvTarget-                     return (t, map (\v -> s { srvTarget = v }) is)+                     return (t+                            ,map (\v ->+                                     s { srvTarget =+                                           (removeTrailingDot srvTarget, v)+                                       }+                                 ) is+                            )                   ) . 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  showIPv4 :: IPv4 -> String showIPv4 (IPv4 w) =@@ -392,15 +392,17 @@   shows ( w                    .&. 0xff)   "" -ipv4ToServerData :: UData -> IPv4 -> ServerData-ipv4ToServerData UData {..} i =-    ServerData (T.pack $ show i) Nothing (Just uMaxFails) (Just uFailTimeout)+ipv4ToServerData :: UData -> Name -> IPv4 -> ServerData+ipv4ToServerData UData {..} (Name n) i =+    ServerData (T.pack $ show i) (T.decodeUtf8 n)+        Nothing (Just uMaxFails) (Just uFailTimeout) -srvToServerData :: UData -> SRV IPv4 -> ServerData+srvToServerData :: UData -> SRV (Name, IPv4) -> ServerData srvToServerData UData {..} SRV {..} =-    ServerData (T.pack $ showAddr srvTarget srvPort)-        (Just $ fromIntegral srvWeight) (Just uMaxFails) (Just uFailTimeout)-    where showAddr i p = showIPv4 i ++ ':' : show p+    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)  -- | Collects server data for the given upstream configuration. --@@ -415,15 +417,15 @@ collectServerData lTTL (UData (QueryA [] _) _ _) =     return (lTTL, M.empty) collectServerData lTTL ud@(UData (QueryA ns u) _ _) = do-    a <- mapConcurrently (collectA lTTL) ns+    a <- mapConcurrently (\n -> (n, ) <$> collectA lTTL n) ns     return $         minimum *** M.singleton u . concat $-            foldr (\(t, s) (ts, ss) ->+            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) s) : ss)+                      (t : ts, sort (map (ipv4ToServerData ud n) s) : ss)                   ) ([], []) a collectServerData lTTL ud@(UData (QuerySRV n (SinglePriority u)) _ _) = do     (wt, srv) <- collectSRV lTTL n@@ -474,9 +476,12 @@ ngxExportSimpleServiceTyped 'collectUpstreams ''Conf $     PersistentService Nothing +-- a list of fully qualified URLs such as 'http://../..' or 'https://../..'+type Upconf = [Text]+ signalUpconf :: Upconf -> Bool -> IO L.ByteString-signalUpconf Upconf {..} = const $ do-    void $ uncurry queryHTTP upconfAddr+signalUpconf upconf = const $ do+    mapConcurrently_ getUrl upconf     return ""  ngxExportSimpleServiceTyped 'signalUpconf ''Upconf $

@@ -1,5 +1,5 @@ name:                       ngx-export-tools-extra-version:                    1.2.4+version:                    1.2.5 synopsis:                   More extra tools for Nginx haskell module description:                More extra tools for         <https://github.com/lyokha/nginx-haskell-module Nginx haskell module>.@@ -78,7 +78,7 @@                           , aeson >= 1.0.0.0 && < 2.0.0.0    if flag(PCRE)-    build-depends:          pcre-light >= 0.4+    build-depends:          pcre-light >= 0.4.1.2                           , pcre-heavy    exposed-modules:          NgxExport.Tools.Aggregate