diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,7 @@ +### 1.2.12.1 + +- Group Template Haskell declarations to fix Haddock out-of-scope errors. + ### 1.2.12 - Module *NgxExport.Tools.Resolve*. diff --git a/NgxExport/Tools/Aggregate.hs b/NgxExport/Tools/Aggregate.hs --- a/NgxExport/Tools/Aggregate.hs +++ b/NgxExport/Tools/Aggregate.hs @@ -210,7 +210,7 @@ -- -- The aggregate service /stats/ must be referred from the Nginx configuration -- file with prefix __/simpleService_aggregate_/__. Its configuration is typed, --- the type is 'AggregateServerConf'. Though its only constructor +-- the type is t'AggregateServerConf'. Though its only constructor -- /AggregateServerConf/ is not exported from this module, the service is still -- configurable from an Nginx configuration. Here, the aggregate service listens -- on TCP port /8100/, and its /purge interval/ is 5 minutes. Notice that an @@ -447,7 +447,7 @@ -- -- The service is implemented via -- 'NgxExport.Tools.SimpleService.ngxExportSimpleServiceTyped' with --- 'AggregateServerConf' as the name of its custom type. This is an +-- t'AggregateServerConf' as the name of its custom type. This is an -- 'NgxExport.Tools.SplitService.ignitionService' with an HTTP server based on -- the [Snap framework](http://snapframework.com/) running inside. The internal -- HTTP server collects data from worker processes at URL diff --git a/NgxExport/Tools/PCRE.hs b/NgxExport/Tools/PCRE.hs --- a/NgxExport/Tools/PCRE.hs +++ b/NgxExport/Tools/PCRE.hs @@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : NgxExport.Tools.PCRE --- Copyright : (c) Alexey Radkov 2021-2024 +-- Copyright : (c) Alexey Radkov 2021-2026 -- License : BSD-style -- -- Maintainer : alexey.radkov@gmail.com @@ -160,28 +160,6 @@ regexes = unsafePerformIO $ newIORef HM.empty {-# NOINLINE regexes #-} -declareRegexes :: InputRegexes -> NgxExportService -declareRegexes = voidService - -ngxExportSimpleServiceTyped 'declareRegexes ''InputRegexes restartPromptly - -compileRegexes :: ByteString -> IO L.ByteString -compileRegexes = voidHandler' $ do - !inputRegexes <- fromJust <$> readIORef storage_InputRegexes_declareRegexes - let !compiledRegexes = - foldl' (\a (!k, !v, !m) -> let !r = compile v $ mods $ C8.unpack m - !hm = HM.insert k r a - in hm - ) HM.empty inputRegexes - writeIORef regexes compiledRegexes - where md 'i' = Just caseless - md 's' = Just dotall - md 'm' = Just multiline - md _ = Nothing - mods = map NE.head . NE.group . sort . mapMaybe md - -ngxExportServiceHook 'compileRegexes - type InputSubs = [(ByteString, ByteString)] type Subs = HashMap ByteString ByteString @@ -189,12 +167,6 @@ substitutions = unsafePerformIO $ newIORef HM.empty {-# NOINLINE substitutions #-} -mapSubs :: InputSubs -> NgxExportService -mapSubs = ignitionService $ voidHandler . - writeIORef substitutions . foldl (\a (k, v) -> HM.insert k v a) HM.empty - -ngxExportSimpleServiceTyped 'mapSubs ''InputSubs SingleShotService - type RegexF = Regex -> ByteString -> IO ByteString rtRegex :: RegexF -> ByteString -> IO L.ByteString @@ -227,8 +199,6 @@ -> IO L.ByteString matchRegex = rtRegex doMatchRegex -ngxExportIOYY 'matchRegex - -- $substitutionPCRE -- -- There are handlers to make substitutions using PCRE regexes. An @@ -255,7 +225,7 @@ -- import qualified Data.ByteString.Lazy as L -- -- gsubSwapAround :: ByteString -> IO L.ByteString --- __/gsubSwapAround/__ = 'gsubRegexWith' $ const $ \\case +-- __/gsubSwapAround/__ = 'gsubRegexWith' $ const $ \\case -- a : d : b : _ -> B.concat [b, d, a] -- \_ -> B.empty -- @@ -346,8 +316,6 @@ -> IO L.ByteString subRegex = rtRegex $ doSubRegex sub Nothing -ngxExportIOYY 'subRegex - -- | Pastes /functional/ substitutions using a named regex and a function. -- -- The substitutions get applied only to the first occurrence of the match. @@ -368,8 +336,6 @@ -> IO L.ByteString gsubRegex = rtRegex $ doSubRegex gsub Nothing -ngxExportIOYY 'gsubRegex - -- | Pastes /functional/ substitutions using a named regex and a function. -- -- The same as 'subRegexWith' except that the substitutions get applied @@ -379,4 +345,41 @@ -> ByteString -- ^ Keys to find the regex and the sub, and the value -> IO L.ByteString gsubRegexWith = rtRegex . doSubRegex gsub . Just + + +-- TH: services and handlers + +declareRegexes :: InputRegexes -> NgxExportService +declareRegexes = voidService + +ngxExportSimpleServiceTyped 'declareRegexes ''InputRegexes restartPromptly + +compileRegexes :: ByteString -> IO L.ByteString +compileRegexes = voidHandler' $ do + !inputRegexes <- fromJust <$> readIORef storage_InputRegexes_declareRegexes + let !compiledRegexes = + foldl' (\a (!k, !v, !m) -> let !r = compile v $ mods $ C8.unpack m + !hm = HM.insert k r a + in hm + ) HM.empty inputRegexes + writeIORef regexes compiledRegexes + where md 'i' = Just caseless + md 's' = Just dotall + md 'm' = Just multiline + md _ = Nothing + mods = map NE.head . NE.group . sort . mapMaybe md + +ngxExportServiceHook 'compileRegexes + +mapSubs :: InputSubs -> NgxExportService +mapSubs = ignitionService $ voidHandler . + writeIORef substitutions . foldl (\a (k, v) -> HM.insert k v a) HM.empty + +ngxExportSimpleServiceTyped 'mapSubs ''InputSubs SingleShotService + +ngxExportIOYY 'matchRegex + +ngxExportIOYY 'subRegex + +ngxExportIOYY 'gsubRegex diff --git a/NgxExport/Tools/Resolve.hs b/NgxExport/Tools/Resolve.hs --- a/NgxExport/Tools/Resolve.hs +++ b/NgxExport/Tools/Resolve.hs @@ -131,13 +131,13 @@ -- -- haskell_run_service __/simpleService_collectUpstreams/__ $hs_upstreams -- \'Conf { upstreams = --- ['UData' { 'uQuery' = --- 'QuerySRV' --- ('Name' \"_http._tcp.mycompany.com\") --- ('SinglePriority' \"__/utest/__\") --- , 'uMaxFails' = 1 --- , 'uFailTimeout' = 10 --- } +-- [ v'UData' { 'uQuery' = +-- 'QuerySRV' +-- ( v'Name' \"_http._tcp.mycompany.com\" ) +-- ( 'SinglePriority' \"__/utest/__\" ) +-- , 'uMaxFails' = 1 +-- , 'uFailTimeout' = 10 +-- } -- ] -- , maxWait = 'Sec' 300 -- , waitOnException = 'Sec' 2 @@ -214,13 +214,13 @@ -- @ -- haskell_run_service __/simpleService_collectUpstreams/__ $hs_upstreams -- \'Conf { upstreams = --- ['UData' { 'uQuery' = --- 'QuerySRV' --- ('Name' \"_http._tcp.mycompany.com\") --- ('PriorityList' [\"__/utest/__\", \"__/utest1/__\"]) --- , 'uMaxFails' = 1 --- , 'uFailTimeout' = 10 --- } +-- [ v'UData' { 'uQuery' = +-- 'QuerySRV' +-- ( v'Name' \"_http._tcp.mycompany.com\" ) +-- ( 'PriorityList' [\"__/utest/__\", \"__/utest1/__\"] ) +-- , 'uMaxFails' = 1 +-- , 'uFailTimeout' = 10 +-- } -- ] -- , maxWait = 'Sec' 300 -- , waitOnException = 'Sec' 2 @@ -300,8 +300,8 @@ -- - /priority list, SRV query/: weights are taken from 'srvWeight'. -- -- Names in the /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'. +-- which is ignored in 'NgxExport.Tools.Resolve.collectA' and only appended to +-- values of 'sAddr' collected by 'NgxExport.Tools.Resolve.collectServerData'. data UQuery = QueryA NameList UNamePriorityPolicy -- ^ Query /A/ records | QuerySRV Name UNamePriorityPolicy -- ^ Query an /SRV/ record deriving Read @@ -451,9 +451,10 @@ -- | Queries an /SRV/ record for the given service name. -- --- After getting the /SRV/ record, runs 'collectA' for each collected element. +-- After getting the /SRV/ record, runs 'NgxExport.Tools.Resolve.collectA' for +-- each collected element. -- --- Returns a list of pairs /(Domain name, IP address)/ wrapped in an 'SRV' +-- Returns a list of pairs /(Domain name, IP address)/ wrapped in an t'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 diff --git a/NgxExport/Tools/Subrequest.hs b/NgxExport/Tools/Subrequest.hs --- a/NgxExport/Tools/Subrequest.hs +++ b/NgxExport/Tools/Subrequest.hs @@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | -- Module : NgxExport.Tools.Subrequest --- Copyright : (c) Alexey Radkov 2020-2024 +-- Copyright : (c) Alexey Radkov 2020-2026 -- License : BSD-style -- -- Maintainer : alexey.radkov@gmail.com @@ -411,8 +411,6 @@ maybe (throwIO SubrequestParseError) subrequestBody . readFromByteStringAsJSON @SubrequestConf -ngxExportAsyncIOYY 'makeSubrequest - -- | Makes an HTTP request. -- -- Behaves exactly as 'makeSubrequest' except it parses Haskell terms @@ -441,8 +439,6 @@ maybe (throwIO SubrequestParseError) subrequestBody . readFromByteString @SubrequestConf -ngxExportAsyncIOYY 'makeSubrequestWithRead - -- $internalHTTPSubrequests -- -- Making HTTP subrequests to the own Nginx service via the loopback interface @@ -516,8 +512,6 @@ S.connect s (S.SockAddrUnix path) makeConnection (SB.recv s 4096) (SB.sendAll s) (S.close s) -ngxExportSimpleServiceTyped 'configureUDS ''UDSConf SingleShotService - -- $subrequestsWithCustomManager -- -- To serve subrequests, a custom HTTP manager can be implemented and then @@ -769,8 +763,6 @@ (400, [], "", "Unreadable subrequest data") ) subrequestFull . readFromByteStringAsJSON @SubrequestConf -ngxExportAsyncIOYY 'makeSubrequestFull - -- | Makes an HTTP request. -- -- The same as 'makeSubrequestWithRead' except it returns a binary encoded @@ -788,8 +780,6 @@ (400, [], "", "Unreadable subrequest data") ) subrequestFull . readFromByteString @SubrequestConf -ngxExportAsyncIOYY 'makeSubrequestFullWithRead - -- | Extracts the HTTP status from an encoded response. -- -- Must be used to extract response data encoded by 'makeSubrequestFull' or @@ -801,8 +791,6 @@ extractStatusFromFullResponse = C8L.pack . show . (\(a, _, _, _) -> a) . Binary.decode @FullResponse . L.fromStrict -ngxExportYY 'extractStatusFromFullResponse - -- | Extracts a specified header from an encoded response. -- -- Must be used to extract response data encoded by 'makeSubrequestFull' or @@ -821,8 +809,6 @@ (_, hs, _, _) = Binary.decode @FullResponse $ L.fromStrict b in maybe "" L.fromStrict $ lookup h $ map (first mk) hs -ngxExportYY 'extractHeaderFromFullResponse - -- | Extracts the body from an encoded response. -- -- Must be used to extract response data encoded by 'makeSubrequestFull' or @@ -834,8 +820,6 @@ extractBodyFromFullResponse = (\(_, _, a, _) -> a) . Binary.decode @FullResponse . L.fromStrict -ngxExportYY 'extractBodyFromFullResponse - -- | Extracts the exception from an encoded response. -- -- Must be used to extract response data encoded by 'makeSubrequestFull' or @@ -850,8 +834,6 @@ extractExceptionFromFullResponse = L.fromStrict . (\(_, _, _, a) -> a) . Binary.decode @FullResponse . L.fromStrict -ngxExportYY 'extractExceptionFromFullResponse - -- $forwardingFullResponse -- -- Data encoded in the full response can be translated to 'ContentHandlerResult' @@ -981,16 +963,12 @@ fromFullResponse = contentFromFullResponse notForwardableResponseHeaders True const -ngxExportHandler 'fromFullResponse - fromFullResponseWithException :: ByteString -> ContentHandlerResult fromFullResponseWithException = contentFromFullResponse notForwardableResponseHeaders True f where f "" = L.fromStrict f b = const b -ngxExportHandler 'fromFullResponseWithException - -- $makingBridgedHTTPSubrequests -- -- A bridged HTTP subrequest streams the response body from the /source/ end of @@ -1224,8 +1202,6 @@ maybe (throwIO BridgeParseError) bridgedSubrequestBody . readFromByteStringAsJSON @BridgeConf -ngxExportAsyncIOYY 'makeBridgedSubrequest - -- | Makes a bridged HTTP request. -- -- Behaves exactly as 'makeBridgedSubrequest' except it parses Haskell terms @@ -1268,8 +1244,6 @@ maybe (throwIO BridgeParseError) bridgedSubrequestBody . readFromByteString @BridgeConf -ngxExportAsyncIOYY 'makeBridgedSubrequestWithRead - -- | Makes a bridged HTTP request. -- -- The same as 'makeBridgedSubrequest' except it returns a binary encoded @@ -1287,8 +1261,6 @@ (400, [], "", "Unreadable bridged subrequest data") ) bridgedSubrequestFull . readFromByteStringAsJSON @BridgeConf -ngxExportAsyncIOYY 'makeBridgedSubrequestFull - -- | Makes a bridged HTTP request. -- -- The same as 'makeBridgedSubrequestWithRead' except it returns a binary @@ -1305,6 +1277,37 @@ Binary.encode @FullResponse (400, [], "", "Unreadable bridged subrequest data") ) bridgedSubrequestFull . readFromByteString @BridgeConf + + +-- TH: services and handlers + +ngxExportAsyncIOYY 'makeSubrequest + +ngxExportAsyncIOYY 'makeSubrequestWithRead + +ngxExportSimpleServiceTyped 'configureUDS ''UDSConf SingleShotService + +ngxExportAsyncIOYY 'makeSubrequestFull + +ngxExportAsyncIOYY 'makeSubrequestFullWithRead + +ngxExportYY 'extractStatusFromFullResponse + +ngxExportYY 'extractHeaderFromFullResponse + +ngxExportYY 'extractBodyFromFullResponse + +ngxExportYY 'extractExceptionFromFullResponse + +ngxExportHandler 'fromFullResponse + +ngxExportHandler 'fromFullResponseWithException + +ngxExportAsyncIOYY 'makeBridgedSubrequest + +ngxExportAsyncIOYY 'makeBridgedSubrequestWithRead + +ngxExportAsyncIOYY 'makeBridgedSubrequestFull ngxExportAsyncIOYY 'makeBridgedSubrequestFullWithRead 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.12 +version: 1.2.12.1 synopsis: More extra tools for Nginx Haskell module description: More extra tools for .