{-# LANGUAGE TemplateHaskell, BangPatterns, OverloadedStrings #-}
{-# LANGUAGE ForeignFunctionInterface, CApiFFI #-}
{-# OPTIONS_GHC -fno-warn-dodgy-foreign-imports #-}
module NgxExport.Tools.PCRE (
matchRegex
,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
type InputRegexes = [(ByteString, ByteString, ByteString)]
type Regexes = HashMap ByteString Regex
newtype MatchRegexError = MatchRegexError String
instance Exception MatchRegexError
instance Show MatchRegexError where
show :: MatchRegexError -> String
show (MatchRegexError s :: String
s) = "PCRE ERROR: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
regexes :: IORef Regexes
regexes :: IORef Regexes
regexes = IO (IORef Regexes) -> IORef Regexes
forall a. IO a -> a
unsafePerformIO (IO (IORef Regexes) -> IORef Regexes)
-> IO (IORef Regexes) -> IORef Regexes
forall a b. (a -> b) -> a -> b
$ Regexes -> IO (IORef Regexes)
forall a. a -> IO (IORef a)
newIORef Regexes
forall k v. HashMap k v
HM.empty
{-# NOINLINE regexes #-}
declareRegexes :: InputRegexes -> Bool -> IO L.ByteString
declareRegexes :: InputRegexes -> Bool -> IO ByteString
declareRegexes = (InputRegexes -> IO ByteString)
-> InputRegexes -> Bool -> IO ByteString
forall a. (a -> IO ByteString) -> a -> Bool -> IO ByteString
ignitionService ((InputRegexes -> IO ByteString)
-> InputRegexes -> Bool -> IO ByteString)
-> (InputRegexes -> IO ByteString)
-> InputRegexes
-> Bool
-> IO ByteString
forall a b. (a -> b) -> a -> b
$ IO ByteString -> InputRegexes -> IO ByteString
forall a b. a -> b -> a
const (IO ByteString -> InputRegexes -> IO ByteString)
-> IO ByteString -> InputRegexes -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ""
ngxExportSimpleServiceTyped 'declareRegexes ''InputRegexes SingleShotService
foreign import capi "pcre.h value pcre_free" c_pcre_free' :: FinalizerPtr a
compile :: ByteString -> [PCREOption] -> Regex
compile :: ByteString -> [PCREOption] -> Regex
compile s :: ByteString
s o :: [PCREOption]
o = case ByteString -> [PCREOption] -> Either String Regex
compileM ByteString
s [PCREOption]
o of
Right r :: Regex
r -> Regex
r
Left e :: String
e -> String -> Regex
forall a. HasCallStack => String -> a
error ("Text.Regex.PCRE.Light: Error in regex: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e)
compileM :: ByteString -> [PCREOption] -> Either String Regex
compileM :: ByteString -> [PCREOption] -> Either String Regex
compileM str :: ByteString
str os :: [PCREOption]
os = IO (Either String Regex) -> Either String Regex
forall a. IO a -> a
unsafePerformIO (IO (Either String Regex) -> Either String Regex)
-> IO (Either String Regex) -> Either String Regex
forall a b. (a -> b) -> a -> b
$
ByteString
-> (CString -> IO (Either String Regex))
-> IO (Either String Regex)
forall a. ByteString -> (CString -> IO a) -> IO a
C8.useAsCString ByteString
str ((CString -> IO (Either String Regex)) -> IO (Either String Regex))
-> (CString -> IO (Either String Regex))
-> IO (Either String Regex)
forall a b. (a -> b) -> a -> b
$ \ptn :: CString
ptn ->
(Ptr CString -> IO (Either String Regex))
-> IO (Either String Regex)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CString -> IO (Either String Regex))
-> IO (Either String Regex))
-> (Ptr CString -> IO (Either String Regex))
-> IO (Either String Regex)
forall a b. (a -> b) -> a -> b
$ \errptr :: Ptr CString
errptr ->
(Ptr CInt -> IO (Either String Regex)) -> IO (Either String Regex)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO (Either String Regex))
-> IO (Either String Regex))
-> (Ptr CInt -> IO (Either String Regex))
-> IO (Either String Regex)
forall a b. (a -> b) -> a -> b
$ \erroffset :: Ptr CInt
erroffset -> do
Ptr ()
pcre_ptr <- CString
-> PCREOption
-> Ptr CString
-> Ptr CInt
-> Ptr Word8
-> IO (Ptr ())
c_pcre_compile CString
ptn ([PCREOption] -> PCREOption
combineOptions [PCREOption]
os)
Ptr CString
errptr Ptr CInt
erroffset Ptr Word8
forall a. Ptr a
nullPtr
if Ptr ()
pcre_ptr Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
nullPtr
then do
String
err <- CString -> IO String
peekCString (CString -> IO String) -> IO CString -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr CString -> IO CString
forall a. Storable a => Ptr a -> IO a
peek Ptr CString
errptr
Either String Regex -> IO (Either String Regex)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String Regex
forall a b. a -> Either a b
Left String
err)
else do
ForeignPtr ()
reg <- FinalizerPtr () -> Ptr () -> IO (ForeignPtr ())
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr ()
forall a. FinalizerPtr a
c_pcre_free' Ptr ()
pcre_ptr
Either String Regex -> IO (Either String Regex)
forall (m :: * -> *) a. Monad m => a -> m a
return (Regex -> Either String Regex
forall a b. b -> Either a b
Right (ForeignPtr () -> ByteString -> Regex
Regex ForeignPtr ()
reg ByteString
str))
compileRegexes :: ByteString -> IO L.ByteString
compileRegexes :: ByteString -> IO ByteString
compileRegexes = IO ByteString -> ByteString -> IO ByteString
forall a b. a -> b -> a
const (IO ByteString -> ByteString -> IO ByteString)
-> IO ByteString -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ do
!InputRegexes
inputRegexes <- Maybe InputRegexes -> InputRegexes
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe InputRegexes -> InputRegexes)
-> IO (Maybe InputRegexes) -> IO InputRegexes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Maybe InputRegexes) -> IO (Maybe InputRegexes)
forall a. IORef a -> IO a
readIORef IORef (Maybe InputRegexes)
storage_InputRegexes_declareRegexes
let !compiledRegexes :: Regexes
compiledRegexes =
(Regexes -> (ByteString, ByteString, ByteString) -> Regexes)
-> Regexes -> InputRegexes -> Regexes
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\a :: Regexes
a (!ByteString
k, !ByteString
v, !ByteString
m) -> let !r :: Regex
r = ByteString -> [PCREOption] -> Regex
compile ByteString
v ([PCREOption] -> Regex) -> [PCREOption] -> Regex
forall a b. (a -> b) -> a -> b
$ String -> [PCREOption]
mods (String -> [PCREOption]) -> String -> [PCREOption]
forall a b. (a -> b) -> a -> b
$ ByteString -> String
C8.unpack ByteString
m
!hm :: Regexes
hm = ByteString -> Regex -> Regexes -> Regexes
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert ByteString
k Regex
r Regexes
a
in Regexes
hm
) Regexes
forall k v. HashMap k v
HM.empty InputRegexes
inputRegexes
IORef Regexes -> Regexes -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Regexes
regexes Regexes
compiledRegexes
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ""
where md :: Char -> Maybe PCREOption
md 'i' = PCREOption -> Maybe PCREOption
forall a. a -> Maybe a
Just PCREOption
caseless
md 's' = PCREOption -> Maybe PCREOption
forall a. a -> Maybe a
Just PCREOption
dotall
md 'm' = PCREOption -> Maybe PCREOption
forall a. a -> Maybe a
Just PCREOption
multiline
md _ = Maybe PCREOption
forall a. Maybe a
Nothing
mods :: String -> [PCREOption]
mods = ([PCREOption] -> PCREOption) -> [[PCREOption]] -> [PCREOption]
forall a b. (a -> b) -> [a] -> [b]
map [PCREOption] -> PCREOption
forall a. [a] -> a
head ([[PCREOption]] -> [PCREOption])
-> (String -> [[PCREOption]]) -> String -> [PCREOption]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PCREOption] -> [[PCREOption]]
forall a. Eq a => [a] -> [[a]]
group ([PCREOption] -> [[PCREOption]])
-> (String -> [PCREOption]) -> String -> [[PCREOption]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PCREOption] -> [PCREOption]
forall a. Ord a => [a] -> [a]
sort ([PCREOption] -> [PCREOption])
-> (String -> [PCREOption]) -> String -> [PCREOption]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Maybe PCREOption) -> String -> [PCREOption]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Char -> Maybe PCREOption
md
ngxExportServiceHook 'compileRegexes
type InputSubs = [(ByteString, ByteString)]
type Subs = HashMap ByteString ByteString
substitutions :: IORef Subs
substitutions :: IORef Subs
substitutions = IO (IORef Subs) -> IORef Subs
forall a. IO a -> a
unsafePerformIO (IO (IORef Subs) -> IORef Subs) -> IO (IORef Subs) -> IORef Subs
forall a b. (a -> b) -> a -> b
$ Subs -> IO (IORef Subs)
forall a. a -> IO (IORef a)
newIORef Subs
forall k v. HashMap k v
HM.empty
{-# NOINLINE substitutions #-}
mapSubs :: InputSubs -> Bool -> IO L.ByteString
mapSubs :: InputSubs -> Bool -> IO ByteString
mapSubs = (InputSubs -> IO ByteString) -> InputSubs -> Bool -> IO ByteString
forall a. (a -> IO ByteString) -> a -> Bool -> IO ByteString
ignitionService ((InputSubs -> IO ByteString)
-> InputSubs -> Bool -> IO ByteString)
-> (InputSubs -> IO ByteString)
-> InputSubs
-> Bool
-> IO ByteString
forall a b. (a -> b) -> a -> b
$ \isubs :: InputSubs
isubs -> do
IORef Subs -> Subs -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Subs
substitutions (Subs -> IO ()) -> Subs -> IO ()
forall a b. (a -> b) -> a -> b
$
(Subs -> (ByteString, ByteString) -> Subs)
-> Subs -> InputSubs -> Subs
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\a :: Subs
a (k :: ByteString
k, v :: ByteString
v) -> ByteString -> ByteString -> Subs -> Subs
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert ByteString
k ByteString
v Subs
a) Subs
forall k v. HashMap k v
HM.empty InputSubs
isubs
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ""
ngxExportSimpleServiceTyped 'mapSubs ''InputSubs SingleShotService
type RegexF = Regex -> ByteString -> IO ByteString
rtRegex :: RegexF -> ByteString -> IO L.ByteString
rtRegex :: RegexF -> ByteString -> IO ByteString
rtRegex f :: RegexF
f = (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
L.fromStrict (IO ByteString -> IO ByteString)
-> (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString -> IO ByteString)
-> (ByteString, ByteString) -> IO ByteString
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> IO ByteString
doRtRegex ((ByteString, ByteString) -> IO ByteString)
-> (ByteString -> (ByteString, ByteString))
-> ByteString
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(ByteString -> ByteString)
-> (ByteString, ByteString) -> (ByteString, ByteString)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ByteString -> ByteString
C8.tail ((ByteString, ByteString) -> (ByteString, ByteString))
-> (ByteString -> (ByteString, ByteString))
-> ByteString
-> (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> (ByteString, ByteString)
C8.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '|')
where doRtRegex :: ByteString -> ByteString -> IO ByteString
doRtRegex k :: ByteString
k v :: ByteString
v = do
Regexes
rgxs <- IORef Regexes -> IO Regexes
forall a. IORef a -> IO a
readIORef IORef Regexes
regexes
case ByteString -> Regexes -> Maybe Regex
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup ByteString
k Regexes
rgxs of
Nothing -> MatchRegexError -> IO ByteString
forall e a. Exception e => e -> IO a
throwIO (MatchRegexError -> IO ByteString)
-> MatchRegexError -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> MatchRegexError
MatchRegexError (String -> MatchRegexError) -> String -> MatchRegexError
forall a b. (a -> b) -> a -> b
$
"Regex " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
C8.unpack ByteString
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ " was not found"
Just r :: Regex
r -> RegexF
f Regex
r ByteString
v
doMatchRegex :: RegexF
doMatchRegex :: RegexF
doMatchRegex r :: Regex
r v :: ByteString
v = ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$
case Regex -> ByteString -> [PCREExecOption] -> Maybe [ByteString]
match Regex
r ByteString
v [] of
Nothing -> ""
Just cs :: [ByteString]
cs -> if Regex -> Int
captureCount Regex
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0
then [ByteString] -> ByteString
forall a. [a] -> a
head [ByteString]
cs
else [ByteString] -> ByteString
forall a. [a] -> a
head ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
forall a. [a] -> [a]
tail [ByteString]
cs
matchRegex
:: ByteString
-> IO L.ByteString
matchRegex :: ByteString -> IO ByteString
matchRegex = RegexF -> ByteString -> IO ByteString
rtRegex RegexF
doMatchRegex
ngxExportIOYY 'matchRegex
type SubPasteF =
ByteString
-> [ByteString]
-> ByteString
type SubF = Regex -> SubPasteF -> ByteString -> ByteString
doSubRegex :: SubF -> Maybe SubPasteF -> RegexF
doSubRegex :: SubF -> Maybe SubPasteF -> RegexF
doSubRegex f :: SubF
f p :: Maybe SubPasteF
p r :: Regex
r v :: ByteString
v =
case Maybe SubPasteF
p of
Nothing -> do
let (k :: ByteString
k, v' :: ByteString
v') = (ByteString -> ByteString)
-> (ByteString, ByteString) -> (ByteString, ByteString)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ByteString -> ByteString
C8.tail ((ByteString, ByteString) -> (ByteString, ByteString))
-> (ByteString, ByteString) -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> (ByteString, ByteString)
C8.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '|') ByteString
v
Subs
subs <- IORef Subs -> IO Subs
forall a. IORef a -> IO a
readIORef IORef Subs
substitutions
case ByteString -> Subs -> Maybe ByteString
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup ByteString
k Subs
subs of
Nothing -> MatchRegexError -> IO ByteString
forall e a. Exception e => e -> IO a
throwIO (MatchRegexError -> IO ByteString)
-> MatchRegexError -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> MatchRegexError
MatchRegexError (String -> MatchRegexError) -> String -> MatchRegexError
forall a b. (a -> b) -> a -> b
$
"Substitution " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
C8.unpack ByteString
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ " was not found"
Just s :: ByteString
s -> ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ SubF
f Regex
r (SubPasteF
forall a b. a -> b -> a
const SubPasteF -> (ByteString -> ByteString) -> SubPasteF
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
forall a b. a -> b -> a
const ByteString
s) ByteString
v'
Just paste :: SubPasteF
paste -> ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ SubF
f Regex
r SubPasteF
paste ByteString
v
subRegex
:: ByteString
-> IO L.ByteString
subRegex :: ByteString -> IO ByteString
subRegex = RegexF -> ByteString -> IO ByteString
rtRegex (RegexF -> ByteString -> IO ByteString)
-> RegexF -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ SubF -> Maybe SubPasteF -> RegexF
doSubRegex SubF
forall a r.
(ConvertibleStrings ByteString a, ConvertibleStrings a ByteString,
RegexReplacement r) =>
Regex -> r -> a -> a
sub Maybe SubPasteF
forall a. Maybe a
Nothing
ngxExportIOYY 'subRegex
subRegexWith
:: SubPasteF
-> ByteString
-> IO L.ByteString
subRegexWith :: SubPasteF -> ByteString -> IO ByteString
subRegexWith = RegexF -> ByteString -> IO ByteString
rtRegex (RegexF -> ByteString -> IO ByteString)
-> (SubPasteF -> RegexF)
-> SubPasteF
-> ByteString
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SubF -> Maybe SubPasteF -> RegexF
doSubRegex SubF
forall a r.
(ConvertibleStrings ByteString a, ConvertibleStrings a ByteString,
RegexReplacement r) =>
Regex -> r -> a -> a
sub (Maybe SubPasteF -> RegexF)
-> (SubPasteF -> Maybe SubPasteF) -> SubPasteF -> RegexF
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SubPasteF -> Maybe SubPasteF
forall a. a -> Maybe a
Just
gsubRegex
:: ByteString
-> IO L.ByteString
gsubRegex :: ByteString -> IO ByteString
gsubRegex = RegexF -> ByteString -> IO ByteString
rtRegex (RegexF -> ByteString -> IO ByteString)
-> RegexF -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ SubF -> Maybe SubPasteF -> RegexF
doSubRegex SubF
forall a r.
(ConvertibleStrings ByteString a, ConvertibleStrings a ByteString,
RegexReplacement r) =>
Regex -> r -> a -> a
gsub Maybe SubPasteF
forall a. Maybe a
Nothing
ngxExportIOYY 'gsubRegex
gsubRegexWith
:: SubPasteF
-> ByteString
-> IO L.ByteString
gsubRegexWith :: SubPasteF -> ByteString -> IO ByteString
gsubRegexWith = RegexF -> ByteString -> IO ByteString
rtRegex (RegexF -> ByteString -> IO ByteString)
-> (SubPasteF -> RegexF)
-> SubPasteF
-> ByteString
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SubF -> Maybe SubPasteF -> RegexF
doSubRegex SubF
forall a r.
(ConvertibleStrings ByteString a, ConvertibleStrings a ByteString,
RegexReplacement r) =>
Regex -> r -> a -> a
gsub (Maybe SubPasteF -> RegexF)
-> (SubPasteF -> Maybe SubPasteF) -> SubPasteF -> RegexF
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SubPasteF -> Maybe SubPasteF
forall a. a -> Maybe a
Just