diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -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*. diff --git a/NgxExport/Tools/PCRE.hs b/NgxExport/Tools/PCRE.hs --- a/NgxExport/Tools/PCRE.hs +++ b/NgxExport/Tools/PCRE.hs @@ -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 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 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 $ 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.4 +version: 1.2.5 synopsis: More extra tools for Nginx haskell module description: More extra tools for . @@ -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