diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,8 @@ +### 0.8.0.0 + +- Added module *NgxExport.Tools.PCRE*, this requires *nginx-haskell-module* + *2.8.4* or newer. + ### 0.7.0.0 - Added module *NgxExport.Tools.ServiceHookAdaptor* to maintain custom global diff --git a/NgxExport/Tools/EDE.hs b/NgxExport/Tools/EDE.hs --- a/NgxExport/Tools/EDE.hs +++ b/NgxExport/Tools/EDE.hs @@ -30,7 +30,11 @@ import Text.EDE import Text.EDE.Filters #if EDE_USE_PRETTYPRINTER +#if MIN_VERSION_prettyprinter(1,7,0) +import Prettyprinter (unAnnotate) +#else import Data.Text.Prettyprint.Doc (unAnnotate) +#endif #else import Text.PrettyPrint.ANSI.Leijen (plain) #endif diff --git a/NgxExport/Tools/PCRE.hs b/NgxExport/Tools/PCRE.hs new file mode 100644 --- /dev/null +++ b/NgxExport/Tools/PCRE.hs @@ -0,0 +1,419 @@ +{-# LANGUAGE TemplateHaskell, BangPatterns, OverloadedStrings #-} +{-# LANGUAGE ForeignFunctionInterface, CApiFFI #-} + +{-# OPTIONS_GHC -fno-warn-dodgy-foreign-imports #-} + +----------------------------------------------------------------------------- +-- | +-- Module : NgxExport.Tools.PCRE +-- Copyright : (c) Alexey Radkov 2021 +-- License : BSD-style +-- +-- Maintainer : alexey.radkov@gmail.com +-- Stability : experimental +-- Portability : non-portable (requires Template Haskell) +-- +-- PCRE matching and substitution from the more extra tools collection +-- for . +-- +----------------------------------------------------------------------------- + +module NgxExport.Tools.PCRE ( + -- * Matching against regular expressions + -- $matchingPCRE + matchRegex + -- * Substitution with regular expressions + -- $substitutionPCRE + ,SubPasteF + ,subRegex + ,subRegexWith + ,gsubRegex + ,gsubRegexWith + ) where + +import NgxExport +import NgxExport.Tools + +import qualified Data.HashMap.Strict as HM +import Data.HashMap.Strict (HashMap) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Lazy as L +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 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 +-- +-- This module provides a simple handler __/matchRegex/__ to match a value +-- against a PCRE regex preliminary declared and compiled in +-- /configuration service/ __/simpleService_declareRegexes/__ (which is an +-- 'ignitionService' in terms of module "NgxExport.Tools") and the corresponding +-- /service update hook/ (in terms of module "NgxExport") __/compileRegexes/__ +-- at the start of the service. +-- +-- Below is a simple example. +-- +-- ==== File /test_tools_extra_pcre.hs/ +-- @ +-- module TestToolsExtraPCRE where +-- +-- import NgxExport.Tools.PCRE () +-- @ +-- +-- The file does not contain any significant declarations as we are going to use +-- only the exporters of the handlers. +-- +-- ==== File /nginx.conf/ +-- @ +-- user nobody; +-- worker_processes 2; +-- +-- events { +-- worker_connections 1024; +-- } +-- +-- http { +-- default_type application\/octet-stream; +-- sendfile on; +-- +-- haskell load \/var\/lib\/nginx\/test_tools_extra_pcre.so; +-- +-- haskell_run_service __/simpleService_declareRegexes/__ $hs_regexes +-- \'[(\"__/userArea/__\", \"(?:\\\\\\\\|)(\\\\\\\\d+)$\", \"\") +-- ,(\"__/keyValue/__\", \"(k\\\\\\\\w+)(\\\\\\\\|)(v\\\\\\\\w+)\", \"i\") +-- ]\'; +-- +-- haskell_service_update_hook __/compileRegexes/__ $hs_regexes; +-- +-- server { +-- listen 8010; +-- server_name main; +-- error_log \/tmp\/nginx-test-haskell-error.log; +-- access_log \/tmp\/nginx-test-haskell-access.log; +-- +-- location \/ { +-- haskell_run __/matchRegex/__ $hs_user_area '__/userArea|/__$arg_user'; +-- rewrite ^ \/internal\/user\/area\/$hs_user_area last; +-- } +-- +-- location ~ ^\/internal\/user\/area\/(PCRE\ ERROR:.*) { +-- internal; +-- echo_status 404; +-- echo \"Bad input: $1\"; +-- } +-- +-- location = \/internal\/user\/area\/ { +-- internal; +-- echo_status 404; +-- echo \"No user area attached\"; +-- } +-- +-- location ~ ^\/internal\/user\/area\/(.+) { +-- internal; +-- echo \"User area: $1\"; +-- } +-- } +-- } +-- @ +-- +-- In this example, we expect requests with argument /user/ which should +-- supposedly be tagged with an /area/ code containing digits only. The /user/ +-- value should match against regex /userArea/ declared alongside with another +-- regex /keyValue/ (the latter has an option /i/ which corresponds to +-- 'caseless'; the regex compiler has also support for options /s/ and /m/ which +-- correspond to 'dotall' and 'multiline' respectively). Notice that regex +-- declarations require 4-fold backslashes as they are getting shrunk while +-- interpreted sequentially by the Nginx configuration interpreter and then by +-- the Haskell compiler too. +-- +-- Handler /matchRegex/ finds the named regex /userArea/ from the beginning of +-- its argument: the second part of the argument is delimited by a /bar/ symbol +-- and contains the value to match against. If the regex contains captures, then +-- the matched value shall correspond to the contents of the first capture (in +-- case of /userArea/, this is the area code), otherwise it must correspond to +-- the whole matched value. +-- +-- ==== A simple test +-- +-- > $ curl 'http://localhost:8010/' +-- > No user area attached +-- > $ curl 'http://localhost:8010/?user=peter|98' +-- > User area: 98 +-- > $ curl 'http://localhost:8010/?user=peter|98i' +-- > No user area attached + +type InputRegexes = [(ByteString, ByteString, ByteString)] +type Regexes = HashMap ByteString Regex + +newtype MatchRegexError = MatchRegexError String + +instance Exception MatchRegexError +instance Show MatchRegexError where + show (MatchRegexError s) = "PCRE ERROR: " ++ s + +regexes :: IORef Regexes +regexes = unsafePerformIO $ newIORef HM.empty +{-# NOINLINE regexes #-} + +declareRegexes :: InputRegexes -> Bool -> IO L.ByteString +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 + !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 + return "" + where md 'i' = Just caseless + md 's' = Just dotall + md 'm' = Just multiline + md _ = Nothing + mods = map head . group . sort . mapMaybe md + +ngxExportServiceHook 'compileRegexes + +type InputSubs = [(ByteString, ByteString)] +type Subs = HashMap ByteString ByteString + +substitutions :: IORef Subs +substitutions = unsafePerformIO $ newIORef HM.empty +{-# NOINLINE substitutions #-} + +mapSubs :: InputSubs -> Bool -> IO L.ByteString +mapSubs = ignitionService $ \isubs -> do + writeIORef substitutions $ + foldl (\a (k, v) -> HM.insert k v a) HM.empty isubs + return "" + +ngxExportSimpleServiceTyped 'mapSubs ''InputSubs SingleShotService + +type RegexF = Regex -> ByteString -> IO ByteString + +rtRegex :: RegexF -> ByteString -> IO L.ByteString +rtRegex f = fmap L.fromStrict . uncurry doRtRegex . + second C8.tail . C8.break (== '|') + where doRtRegex k v = do + rgxs <- readIORef regexes + case HM.lookup k rgxs of + Nothing -> throwIO $ MatchRegexError $ + "Regex " ++ C8.unpack k ++ " was not found" + Just r -> f r v + +doMatchRegex :: RegexF +doMatchRegex r v = return $ + case match r v [] of + Nothing -> "" + Just cs -> if captureCount r == 0 + then head cs + else head $ tail cs + +-- | Matches a value against a named regex. +-- +-- The regex must be preliminary declared and compiled by service handlers +-- /simpleService_declareRegexes/ and /compileRegexes/. The name of the regex +-- and the value are passed in a single argument: the two parts are delimited by +-- the first /bar/ symbol met from the left, e.g. /key|value/. +-- +-- This is the core function of the /matchRegex/ handler. +matchRegex + :: ByteString -- ^ Key to find the regex, and the value + -> IO L.ByteString +matchRegex = rtRegex doMatchRegex + +ngxExportIOYY 'matchRegex + +-- $substitutionPCRE +-- +-- There are handlers to make substitutions using PCRE regexes. An +-- 'ignitionService' __/simpleService_mapSubs/__ declares named /plain/ +-- substitutions which are made in run-time by handlers __/subRegex/__ and +-- __/gsubRegex/__. Functions 'subRegexWith' and 'gsubRegexWith' make it +-- possible to write custom /functional/ substitutions. +-- +-- Let's extend our example by adding ability to erase the captured area code. +-- We also going to implement a /functional/ substitution to swap the keys and +-- the values matched in the /keyValue/ regex. +-- +-- ==== File /test_tools_extra_pcre.hs/ +-- @ +-- {-\# LANGUAGE TemplateHaskell \#-} +-- +-- module TestToolsExtraPCRE where +-- +-- import NgxExport +-- import NgxExport.Tools.PCRE +-- +-- import Data.ByteString (ByteString) +-- import qualified Data.ByteString as B +-- import qualified Data.ByteString.Lazy as L +-- +-- gsubSwapAround :: ByteString -> IO L.ByteString +-- __/gsubSwapAround/__ = 'gsubRegexWith' $ \\_ (a : d : b : _) -> B.concat [b, d, a] +-- +-- 'ngxExportIOYY' \'gsubSwapAround +-- @ +-- +-- Functional substitution handler /gsubSwapAround/ expects a regular expression +-- with at least 3 capture groups to swap the contents of the first and the +-- third groups around. We are going to apply this handler against regex +-- /keyValue/. +-- +-- ==== File /nginx.conf/: erase area code and swap keys and values +-- @ +-- haskell_run_service __/simpleService_mapSubs/__ $hs_subs +-- \'[(\"__/erase/__\", \"\")]\'; +-- +-- haskell_var_empty_on_error $hs_kv; +-- @ +-- @ +-- location \/erase\/area { +-- haskell_run __/subRegex/__ $hs_user_no_area \'__/userArea|erase|/__$arg_user\'; +-- rewrite ^ \/internal\/user\/noarea\/$hs_user_no_area last; +-- } +-- +-- location ~ ^\/internal\/user\/noarea\/(PCRE\\ ERROR:.*) { +-- internal; +-- echo_status 404; +-- echo \"Bad input: $1\"; +-- } +-- +-- location ~ ^\/internal\/user\/noarea\/(.*) { +-- internal; +-- echo \"User without area: $1\"; +-- } +-- +-- location \/swap { +-- haskell_run __/gsubSwapAround/__ $hs_kv \'__/keyValue|/__$arg_kv\'; +-- echo \"Swap $arg_kv = $hs_kv\"; +-- } +-- @ +-- +-- Service /simpleService_mapSubs/ declares a list of named /plain/ +-- substitutions. In this example, it declares only one substitution /erase/ +-- which substitutes an empty string, i.e. /erases/ the matched text. Notice +-- that the argument of handler /subRequest/ requires three parts delimited by +-- /bar/ symbols: the named regex, the named substitution, and the value to +-- match against. +-- +-- ==== A simple test +-- +-- > $ curl 'http://localhost:8010/erase/area?user=peter|98' +-- > User without area: peter +-- > $ curl 'http://localhost:8010/swap?kv=kid|v0012a +-- > Swap kid|v0012a = v0012a|kid + +-- | Type of functions to perform /functional/ substitutions. +type SubPasteF = + ByteString -- ^ The full match + -> [ByteString] -- ^ List of captures + -> ByteString + +type SubF = Regex -> SubPasteF -> ByteString -> ByteString + +doSubRegex :: SubF -> Maybe SubPasteF -> RegexF +doSubRegex f p r v = + case p of + Nothing -> do + let (k, v') = second C8.tail $ C8.break (== '|') v + subs <- readIORef substitutions + case HM.lookup k subs of + Nothing -> throwIO $ MatchRegexError $ + "Substitution " ++ C8.unpack k ++ " was not found" + Just s -> return $ f r (const . const s) v' + Just paste -> return $ f r paste v + +-- | Pastes a named /plain/ substitution using a named regex. +-- +-- The substitution and the regex must be preliminary declared and compiled by +-- service handlers /simpleService_declareRegexes/, /compileRegexes/, and +-- /simpleService_mapSubs/. The names of the regex and the substitution, and +-- the value are passed in a single argument: the three parts are delimited by +-- /bar/ symbols, e.g. /regex|sub|value/. The substitution gets applied only to +-- the first occurrence of the match. +-- +-- This is the core function of the /subRegex/ handler. +subRegex + :: ByteString -- ^ Keys to find the regex and the sub, and the value + -> 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. +subRegexWith + :: SubPasteF -- ^ Function to paste substitutions + -> ByteString -- ^ Keys to find the regex and the sub, and the value + -> IO L.ByteString +subRegexWith = rtRegex . doSubRegex sub . Just + +-- | Pastes a named /plain/ substitution using a named regex. +-- +-- The same as 'subRegex' except that the substitution gets applied +-- globally, wherever the match occurs. +-- +-- This is the core function of the /gsubRegex/ handler. +gsubRegex + :: ByteString -- ^ Keys to find the regex and the sub, and the value + -> 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 +-- globally, wherever the match occurs. +gsubRegexWith + :: SubPasteF -- ^ Function to paste substitutions + -> ByteString -- ^ Keys to find the regex and the sub, and the value + -> IO L.ByteString +gsubRegexWith = rtRegex . doSubRegex gsub . Just + diff --git a/NgxExport/Tools/Prometheus.hs b/NgxExport/Tools/Prometheus.hs --- a/NgxExport/Tools/Prometheus.hs +++ b/NgxExport/Tools/Prometheus.hs @@ -247,7 +247,7 @@ -- ,\"cnt_uptime\": $cnt_uptime -- ,\"cnt_uptime_reload\": $cnt_uptime_reload -- } --- ]'; +-- ]\'; -- -- if ($hs_prom_metrics = \'\') { -- return 503; @@ -259,10 +259,12 @@ -- } -- -- location \/counters { +-- default_type application/json; -- echo $cnt_collection; -- } -- -- location \/histograms { +-- default_type application/json; -- echo $cnt_histograms; -- } -- @@ -320,7 +322,7 @@ -- ,\"cnt_uptime\": $cnt_uptime -- ,\"cnt_uptime_reload\": $cnt_uptime_reload -- } --- ]'; +-- ]\'; -- } -- @ -- @@ -731,7 +733,7 @@ -- server. -- -- @ --- haskell_run___/service simpleService_prometheusConf/__ $hs_prometheus_conf +-- haskell_run_service __/simpleService_prometheusConf/__ $hs_prometheus_conf -- \'__/PrometheusConf/__ -- { __/pcMetrics/__ = fromList -- [(\"cnt_4xx\", \"Number of responses with 4xx status\") @@ -947,7 +949,7 @@ -- haskell_run ! $hs_bytes_sent $bytes_sent; -- -- histogram $__/hst_request_time\@scope=(total)/__ 11 $request_time_bucket; --- haskell_run__/ scale1000 $hs_request_time_scaled $hs_request_time; +-- haskell_run scale1000 $hs_request_time_scaled $hs_request_time; -- counter $hst_request_time\@scope=(total)_sum inc $hs_request_time_scaled; -- -- histogram $hst_bytes_sent 6 $bytes_sent_bucket; diff --git a/NgxExport/Tools/ServiceHookAdaptor.hs b/NgxExport/Tools/ServiceHookAdaptor.hs --- a/NgxExport/Tools/ServiceHookAdaptor.hs +++ b/NgxExport/Tools/ServiceHookAdaptor.hs @@ -75,7 +75,7 @@ -- -- Here we are going to maintain a /secret word/ of type 'ByteString' in -- run-time. When a worker process starts, the word is empty. The word can be --- changed in run-time by triggering /service hook/ /changeSecretWord/. Client +-- changed in run-time by triggering service hook /changeSecretWord/. Client -- requests are managed differently depending on their knowledge of the secret -- which is tested in handler /testSecretWord/. -- @@ -98,7 +98,7 @@ -- -- haskell load \/var\/lib\/nginx\/test_tools_extra_servicehookadaptor.so; -- --- haskell_run_service __/simpleService_hookAdaptor/__ $hs_hook_adaptor 32k; +-- haskell_run_service __/simpleService_hookAdaptor/__ $hs_hook_adaptor \'\'; -- -- haskell_service_hooks_zone hooks 32k; -- @@ -135,7 +135,8 @@ -- } -- @ -- --- Notice that service /simpleService_hookAdaptor/ is not shared. +-- Notice that service /simpleService_hookAdaptor/ is not shared, however this +-- is not such important because shared services must work as well. -- -- ==== A simple test -- After starting Nginx, the secret word service must be not ready. 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: 0.7.0.0 +version: 0.8.0.0 synopsis: More extra tools for Nginx haskell module description: More extra tools for . @@ -30,6 +30,9 @@ from [ansi-wl-pprint](https://hackage.haskell.org/package/ansi-wl-pprint) to [prettyprinter](https://hackage.haskell.org/package/prettyprinter). +flag PCRE + description: Build PCRE module. + library default-language: Haskell2010 build-depends: base >= 4.8 && < 5 @@ -67,6 +70,10 @@ , ansi-wl-pprint >= 0.6.3 , trifecta <= 2 + if flag(PCRE) + build-depends: pcre-light >= 0.4 + , pcre-heavy + exposed-modules: NgxExport.Tools.Prometheus , NgxExport.Tools.Subrequest , NgxExport.Tools.ServiceHookAdaptor @@ -76,6 +83,9 @@ if flag(EDE) exposed-modules: NgxExport.Tools.EDE + + if flag(PCRE) + exposed-modules: NgxExport.Tools.PCRE ghc-options: -Wall