adblock2privoxy 2.3.1 → 3.0.0
raw patch · 22 files changed
+2133/−1223 lines, 22 filesdep +bytestringdep +extradep +pcre2dep −MissingHdep −case-insensitivedep −networkdep ~basedep ~containersdep ~directorysetup-changed
Dependencies added: bytestring, extra, pcre2
Dependencies removed: MissingH, case-insensitive, network, old-locale
Dependency ranges changed: base, containers, directory, filepath, http-conduit, mtl, network-uri, parsec, text, time
Files
- CHANGELOG.md +9/−0
- Setup.hs +1/−0
- adblock2privoxy.cabal +52/−20
- src/ElementBlocker.hs +124/−81
- src/InputParser.hs +143/−116
- src/Main.hs +78/−77
- src/Network.hs +18/−18
- src/OptionsConverter.hs +117/−92
- src/ParsecExt.hs +51/−44
- src/ParserExtTests.hs +78/−73
- src/PatternConverter.hs +473/−172
- src/PolicyTree.hs +89/−66
- src/PopupBlocker.hs +0/−1
- src/ProgramOptions.hs +125/−98
- src/SourceInfo.hs +89/−64
- src/Statistics.hs +25/−23
- src/Task.hs +15/−14
- src/Templates.hs +31/−28
- src/Test.hs +281/−0
- src/UrlBlocker.hs +211/−154
- src/UrlBlocker.hs-boot +6/−4
- src/Utils.hs +117/−78
CHANGELOG.md view
@@ -1,3 +1,12 @@+3.0.0+ * Speed and memory improvements in tree processing, file output + * Parsing corrections for Adblock Plus, uBlock origin, AdGuard lists+ * Privoxy PCRE syntax checks+ * Use Privoxy FEATURE_PCRE_HOST_PATTERNS+ * Filter out rules that affect TLDs+ * Replace ageing dependencies with modern equivalents+ * Add test suite+ * Multiple bug fixes 2.3.1 * Fix Network.hs compilation 2.3.0
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
adblock2privoxy.cabal view
@@ -1,9 +1,9 @@ name: adblock2privoxy-version: 2.3.1+version: 3.0.0 cabal-version: >= 1.10 build-type: Simple tested-with:- GHC==9.12.2+ GHC==9.14.1 author: Alexey Zubritsky <adblock2privoxy@zubr.me>, Steven Thomas Smith <steve.t.smith@gmail.com> data-files: templates/ab2p.system.action,@@ -64,34 +64,33 @@ GeneralizedNewtypeDeriving, FlexibleContexts build-depends:- base >= 4 && < 9.9,- MissingH >= 1.6.0 && < 1.7,- containers >= 0.6.7 && < 0.7,- directory >= 1.3.8 && < 1.4,- filepath >= 1.4.200 && < 1.5,- mtl >= 2.3.1 && < 2.4,- time >= 1.12.2 && < 1.13,- network >= 3.1.4 && < 3.3,- old-locale >= 1.0.0 && < 1.1,- parsec >= 3.1.16 && < 3.2,- text >= 2.0.2 && < 2.2,- case-insensitive >= 1.2.1 && < 1.3,- http-conduit >= 2.3.8 && < 2.4,- network-uri >= 2.6.4 && < 2.7,+ base >= 4.14 && < 4.23,+ bytestring,+ containers >= 0.6.7 && < 0.9,+ directory >= 1.3.8 && < 1.5,+ extra,+ filepath >= 1.4.200 && < 1.6,+ http-conduit >= 2.3.8 && < 2.5,+ mtl >= 2.3.1 && < 2.5,+ network-uri >= 2.6.4 && < 2.8,+ parsec >= 3.1.17 && < 3.2,+ parsec-permutation >= 0.1.2 && < 0.2,+ pcre2 >= 2.3 && < 2.4, strict >= 0.5 && < 0.6,- parsec-permutation >= 0.1.2 && < 0.2+ text >= 2.1 && < 2.3,+ time >= 1.12.2 && < 1.16 ghc-options: -Wall+ -O2+ -rtsopts other-modules: ElementBlocker, InputParser, Network, OptionsConverter, ParsecExt,- ParserExtTests, Paths_adblock2privoxy, PatternConverter, PolicyTree,- PopupBlocker, ProgramOptions, SourceInfo, Statistics,@@ -100,8 +99,41 @@ UrlBlocker, Utils +test-suite adblock2privoxy-test+ type: exitcode-stdio-1.0+ hs-source-dirs: src+ main-is: Test.hs+ default-language: Haskell2010+ default-extensions:+ RankNTypes,+ ScopedTypeVariables,+ FlexibleInstances,+ GeneralizedNewtypeDeriving,+ FlexibleContexts+ build-depends:+ base >= 4.14 && < 4.23,+ containers >= 0.6.7 && < 0.9,+ extra,+ filepath >= 1.4.200 && < 1.6,+ mtl >= 2.3.1 && < 2.5,+ network-uri >= 2.6.4 && < 2.8,+ parsec >= 3.1.17 && < 3.2,+ parsec-permutation >= 0.1.2 && < 0.2,+ pcre2 >= 2.3 && < 2.4,+ text >= 2.1 && < 2.3+ ghc-options: -Wall+ -O2+ -rtsopts+ other-modules:+ InputParser,+ ParsecExt,+ ParserExtTests,+ PatternConverter,+ PolicyTree,+ Utils+ source-repository this type: git location: https://github.com/essandess/adblock2privoxy.git subdir: adblock2privoxy- tag: v2.3.1+ tag: v3.0.0
src/ElementBlocker.hs view
@@ -1,108 +1,151 @@ {-# LANGUAGE StrictData #-} -module ElementBlocker (-elemBlock-) where-import InputParser hiding (Policy(..))+module ElementBlocker+ ( elemBlock,+ )+where++import Control.Monad+import qualified Data.ByteString.Builder as BSB+import Data.List+import qualified Data.Map.Strict as Map+import Data.Maybe+import InputParser hiding (Policy (..)) import qualified InputParser import PolicyTree-import ProgramOptions (DebugLevel(DebugLevel))-import qualified Data.Map as Map-import Data.Maybe-import Utils-import System.IO-import System.FilePath-import Data.List+import ProgramOptions (DebugLevel (DebugLevel)) import System.Directory+import System.FilePath+import System.IO import qualified Templates-import Control.Monad-import Data.String.Utils (startswith)-+import Utils type BlockedRulesTree = DomainTree [Pattern]-data ElemBlockData = ElemBlockData [Pattern] BlockedRulesTree deriving Show +data ElemBlockData = ElemBlockData [Pattern] BlockedRulesTree deriving (Show)+ elemBlock :: String -> [String] -> DebugLevel -> [Line] -> IO () elemBlock path info debug = writeElemBlock . elemBlockData- where+ where writeElemBlock :: ElemBlockData -> IO () writeElemBlock (ElemBlockData flatPatterns rulesTree) =- do- let debugPath = path </> "debug"- filteredInfo = filter ((||) <$> not . startswith "Url:" <*> startswith "Url: http") info- createDirectoryIfMissing True path- cont <- getDirectoryContents path- mapM_ removeOld cont- when (debug > DebugLevel 0) $ createDirectoryIfMissing True debugPath- writeBlockTree path debugPath rulesTree- writePatterns filteredInfo (path </> "ab2p.common.css") (if debug > DebugLevel 0 then debugPath </> "ab2p.common.css" else "") flatPatterns+ do+ let debugPath = path </> "debug"+ filteredInfo = filter ((||) <$> not . startswith "Url:" <*> startswith "Url: http") info+ createDirectoryIfMissing True path+ cont <- getDirectoryContents path+ mapM_ removeOld cont+ when (debug > DebugLevel 0) $ createDirectoryIfMissing True debugPath+ writeBlockTree path debugPath rulesTree+ writePatterns filteredInfo (path </> "ab2p.common.css") (if debug > DebugLevel 0 then debugPath </> "ab2p.common.css" else "") flatPatterns removeOld entry' =- let entry = path </> entry'- in do- isDir <- doesDirectoryExist entry- if isDir then when (head entry' /= '.') $ removeDirectoryRecursive entry- else when (takeExtension entry == ".css") $ removeFile entry+ let entry = path </> entry'+ in do+ isDir <- doesDirectoryExist entry+ if isDir+ then when (not (startswith "." entry')) $ removeDirectoryRecursive entry+ else when (takeExtension entry == ".css") $ removeFile entry writeBlockTree :: String -> String -> BlockedRulesTree -> IO () writeBlockTree normalNodePath debugNodePath (Node name patterns children) =- do- createDirectoryIfMissing True normalPath- when (debug > DebugLevel 1) $ createDirectoryIfMissing True debugPath- mapM_ (writeBlockTree normalPath debugPath) children- writePatterns ["See ab2p.common.css for sources info"] normalFilename (if debug > DebugLevel 1 then debugFilename else "") patterns- where- normalPath- | null name = normalNodePath- | otherwise = normalNodePath </> name- debugPath- | null name = debugNodePath- | otherwise = debugNodePath </> name- normalFilename = normalPath </> "ab2p.css"- debugFilename = debugPath </> "ab2p.css"+ do+ -- avoid traversing already-created ancestor chain+ createDirectoryIfMissing False normalPath+ when (debug > DebugLevel 1) $ createDirectoryIfMissing False debugPath+ mapM_ (writeBlockTree normalPath debugPath) children+ writePatterns ["See ab2p.common.css for sources info"] normalFilename (if debug > DebugLevel 1 then debugFilename else "") patterns+ where+ normalPath+ | null name = normalNodePath+ | otherwise = normalNodePath </> name+ debugPath+ | null name = debugNodePath+ | otherwise = debugNodePath </> name+ normalFilename = normalPath </> "ab2p.css"+ debugFilename = debugPath </> "ab2p.css" writePatterns :: [String] -> String -> String -> [Pattern] -> IO () writePatterns _ _ _ [] = return () writePatterns info' normalFilename debugFilename patterns =- do- writeCssFile normalFilename $ intercalate "\n" ((++ Templates.blockCss) . intercalate "," <$>- splitEvery 4000 patterns)- when (debugFilename /= "") $- writeCssFile debugFilename $ intercalate "\n" $ (++ Templates.blockCss) <$> patterns- where- splitEvery n = takeWhile (not . null) . unfoldr (Just . splitAt n)- writeCssFile filename content =- do outFile <- openFile filename WriteMode- hSetEncoding outFile utf8- hPutStrLn outFile "/*"- mapM_ (hPutStrLn outFile) info'- hPutStrLn outFile "*/"- hPutStrLn outFile content- hClose outFile+ do+ writeCssFile normalFilename $+ intercalate+ "\n"+ ( (++ Templates.blockCss) . intercalate ","+ <$> splitEvery 4000 patterns+ )+ when (debugFilename /= "")+ $ writeCssFile debugFilename+ $ intercalate "\n"+ $ (++ Templates.blockCss) <$> patterns+ where+ splitEvery n = takeWhile (not . null) . unfoldr (Just . splitAt n)+ writeCssFile :: String -> String -> IO ()+ writeCssFile filename content =+ do+ outFile <- openBinaryFile filename WriteMode+ -- Build the entire file as one Builder and issue a+ -- single hPutBuilder, instead of opening in text mode+ -- (forcing every hPutStrLn through the Handle's UTF-8+ -- transcoding layer) with 3+ separate small writes+ BSB.hPutBuilder outFile $+ mconcat+ [ BSB.stringUtf8 "/*\n",+ foldMap (\l -> BSB.stringUtf8 l <> BSB.char7 '\n') info',+ BSB.stringUtf8 "*/\n",+ BSB.stringUtf8 content,+ BSB.char7 '\n'+ ]+ hClose outFile elemBlockData :: [Line] -> ElemBlockData-elemBlockData input = ElemBlockData- (Map.foldrWithKey appendFlatPattern [] policyTreeMap)- (Map.foldrWithKey appendTreePattern (Node "" [] []) policyTreeMap)- where+elemBlockData input =+ ElemBlockData+ (Map.foldrWithKey appendFlatPattern [] policyTreeMap)+ blockedRulesTree+ where+ -- Per selector/pattern, group all the per-rule domain trees that share it,+ -- then combine each group with ONE balanced merge (mergeBalanced) followed+ -- by one trim. For a selector shared by k rules original was O(k^2) node+ -- operations; this is O(k log k) policyTreeMap :: Map.Map String PolicyTree- policyTreeMap = Map.unionWith (trimTree Block .*. mergePolicyTrees Unblock)- blockLinesMap- (erasePolicy Block <$> unblockLinesMap)- where- blockLinesMap = Map.fromListWith (mergeAndTrim Block) (mapMaybe blockLine input)- unblockLinesMap = Map.fromListWith (mergeAndTrim Unblock) (mapMaybe unblockLine input)- unblockLine (Line _ (ElementHide domains InputParser.Unblock pattern)) = (,) pattern <$> restrictionsTree Unblock domains+ policyTreeMap =+ Map.unionWith+ (trimTree Block .*. mergePolicyTrees Unblock)+ blockLinesMap+ (erasePolicy Block <$> unblockLinesMap)+ where+ blockLinesMap = trimTree Block . mergeBalanced (mergePolicyTrees Block) <$> blockGroups+ unblockLinesMap = trimTree Unblock . mergeBalanced (mergePolicyTrees Unblock) <$> unblockGroups++ blockGroups = Map.fromListWith (++) (mapMaybe blockLine input)+ unblockGroups = Map.fromListWith (++) (mapMaybe unblockLine input)++ unblockLine (Line _ (ElementHide domains InputParser.Unblock pattern)) =+ (\t -> (pattern, [t])) <$> restrictionsTree Unblock domains unblockLine _ = Nothing- blockLine (Line _ (ElementHide domains InputParser.Block pattern)) = (,) pattern <$> restrictionsTree Block domains+ blockLine (Line _ (ElementHide domains InputParser.Block pattern)) =+ (\t -> (pattern, [t])) <$> restrictionsTree Block domains blockLine _ = Nothing - appendTreePattern :: Pattern -> PolicyTree -> BlockedRulesTree -> BlockedRulesTree- appendTreePattern pattern policyTree- | null $ _children policyTree = id- | otherwise = mergeTrees appendPattern policyTree- where appendPattern policy patterns = case policy of- Block -> pattern:patterns- _ -> patterns+ -- Same approach for the final tree+ blockedRulesTree :: BlockedRulesTree+ blockedRulesTree = case patternTrees of+ [] -> Node "" [] []+ ts -> mergeBalanced (mergeTrees (++)) ts+ where+ patternTrees =+ [ singleTree pattern policyTree+ | (pattern, policyTree) <- Map.toList policyTreeMap+ ] - appendFlatPattern :: Pattern -> PolicyTree -> [Pattern] -> [Pattern]+ singleTree pattern policyTree+ | null (_children policyTree) = Node "" [] []+ | otherwise = mergeTrees appendPattern policyTree (Node "" [] [])+ where+ appendPattern policy patterns = case policy of+ Block -> pattern : patterns+ _ -> patterns++ appendFlatPattern :: Pattern -> PolicyTree -> [Pattern] -> [Pattern] appendFlatPattern pattern policyTree patterns- | null (_children policyTree) && _value policyTree == Block = pattern:patterns- | otherwise = patterns+ | null (_children policyTree) && _value policyTree == Block = pattern : patterns+ | otherwise = patterns
src/InputParser.hs view
@@ -1,76 +1,91 @@ {-# LANGUAGE StrictData #-} -module InputParser (-Line (..),-Restrictions (..),-RequestOptions (..),-Record (..),-RequestType (..),-Pattern,-Domain,-Policy (..),-RecordSource (..),-adblockFile,-recordSourceText-)+module InputParser+ ( Line (..),+ Restrictions (..),+ RequestOptions (..),+ Record (..),+ RequestType (..),+ Pattern,+ Domain,+ Policy (..),+ RecordSource (..),+ adblockFile,+ recordSourceText,+ ) where+ import Control.Applicative hiding ((<|>))-import Text.ParserCombinators.Parsec hiding (Line, many, optional)-import Data.List.Utils (split)-import Data.List+import Control.Monad import Data.Char import Data.Containers.ListUtils import Data.Functor+import Data.List import Data.Monoid-import Control.Monad-import Text.Parsec.Permutation import System.FilePath+import Text.Parsec.Permutation+import Text.ParserCombinators.Parsec hiding (Line, many, optional)+import Utils (split) -------------------------------------------------------------------------- ---------------------------- data model --------------------------------- -------------------------------------------------------------------------- --- composite +-- composite data Line = Line RecordSource Record- deriving (Show,Eq)+ deriving (Show, Eq) -data RecordSource = RecordSource { _position :: SourcePos, _rawRecord :: String } deriving (Show,Eq)+data RecordSource = RecordSource {_position :: SourcePos, _rawRecord :: String} deriving (Show, Eq)+ data Policy = Block | Unblock deriving (Show, Eq, Read, Ord)-data Record = Error String |- Comment String |- ElementHide (Restrictions Domain) Policy Pattern |- RequestBlock Policy Pattern RequestOptions- deriving (Read,Show,Eq) -data RequestType = Script | Image | Stylesheet | Object | Xmlhttprequest | Popup |- ObjectSubrequest | Subdocument | Document | Other- deriving (Read,Show,Eq,Ord)+data Record+ = Error String+ | Comment String+ | ElementHide (Restrictions Domain) Policy Pattern+ | RequestBlock Policy Pattern RequestOptions+ deriving (Read, Show, Eq) -data RequestOptions = RequestOptions {- _requestType :: Restrictions RequestType,- _thirdParty :: Maybe Bool,- _domain :: Restrictions Domain,- _matchCase :: Bool,- _collapse :: Maybe Bool,- _doNotTrack :: Bool,- _elemHide :: Bool,- _unknown :: [String]- }- deriving (Read,Show,Eq)+data RequestType+ = Script+ | Image+ | Stylesheet+ | Object+ | Xmlhttprequest+ | Popup+ | ObjectSubrequest+ | Subdocument+ | Document+ | Other+ deriving (Read, Show, Eq, Ord) +data RequestOptions = RequestOptions+ { _requestType :: Restrictions RequestType,+ _thirdParty :: Maybe Bool,+ _domain :: Restrictions Domain,+ _matchCase :: Bool,+ _collapse :: Maybe Bool,+ _doNotTrack :: Bool,+ _elemHide :: Bool,+ _unknown :: [String]+ }+ deriving (Read, Show, Eq)+ -- primitive type Pattern = String+ type Domain = String -- helpers-data Restrictions a = Restrictions {- _positive :: Maybe [a],- _negative :: [a]}- deriving (Read,Show,Eq,Ord)+data Restrictions a = Restrictions+ { _positive :: Maybe [a],+ _negative :: [a]+ }+ deriving (Read, Show, Eq, Ord) recordSourceText :: RecordSource -> String-recordSourceText (RecordSource position rawRecord)- = concat [rawRecord, " (", takeFileName $ sourceName position, ": ", show $ sourceLine position, ")"]+recordSourceText (RecordSource position rawRecord) =+ concat [rawRecord, " (", takeFileName $ sourceName position, ": ", show $ sourceLine position, ")"] -------------------------------------------------------------------------- ---------------------------- parsers ------------------------------------@@ -78,109 +93,122 @@ adblockFile :: Parser [Line] adblockFile = header *> sepEndBy line (oneOf eol)- where- header = string "[Adblock Plus " <* version <* string "]" <* lineEnd- version = join <$> sepBy (many1 digit) (char '.')-+ where+ -- Robust list headers across Adblock Plus, uBlock Origin+ header = optional (try headerLine)+ headerLine = string "[Adblock Plus " <* version <* string "]" <* lineEnd+ version = join <$> sepBy (many1 digit) (char '.') line :: Parser Line line = do- position <- getPosition- let text = lookAhead (manyTill anyChar lineEnd)- sourcePosition = RecordSource position <$> text- Line <$> sourcePosition <*> choice (try <$> [comment, elementHide, match, unknown]) <?> "filtering rule"--+ position <- getPosition+ let text = lookAhead (manyTill anyChar lineEnd)+ sourcePosition = RecordSource position <$> text+ Line <$> sourcePosition <*> choice (try <$> [comment, elementHide, match, unknown]) <?> "filtering rule" elementHide :: Parser Record elementHide = ElementHide <$> domains ',' <*> excludeMatch <*> pattern- where- excludeMatch = char '#' *> ((Block <$ string "#") <|> (Unblock <$ string "@#"))- pattern = manyTill anyChar (lookAhead lineEnd)+ where+ -- Adblock Plus / uBlock Origin / AdGuard cosmetic-filter markers+ excludeMatch = do+ _ <- char '#'+ isException <- option False (True <$ char '@')+ _ <- many (oneOf "$?%")+ _ <- char '#'+ return $ if isException then Unblock else Block+ pattern = manyTill anyChar (lookAhead lineEnd) match :: Parser Record match = RequestBlock <$> excludeMatch <*> pattern <*> options- where- excludeMatch = option Block $ Unblock <$ count 2 (char '@')- patternEnd = try (void (char '$') <* requestOptions <* lineEnd) <|> try (void lineEnd)- pattern = manyTill (noneOf "#") (lookAhead patternEnd)- options = option '$' (char '$') *> requestOptions+ where+ excludeMatch = option Block $ Unblock <$ count 2 (char '@')+ patternEnd = try (void (char '$') <* requestOptions <* lineEnd) <|> try (void lineEnd)+ -- patternEnd looks for a '$' or EOL+ pattern = manyTill anyChar (lookAhead patternEnd)+ options = option '$' (char '$') *> requestOptions comment :: Parser Record-comment = Comment <$> (separatorLine <|> commentText)- where commentText = char '!' *> many notLineEnd- separatorLine = lookAhead lineEnd $> ""+comment = Comment <$> (separatorLine <|> commentText <|> hashComment)+ where+ commentText = char '!' *> many notLineEnd+ separatorLine = lookAhead lineEnd $> ""+ -- Hosts-file-style or informal lists use a single leading '#'+ hashComment = try (char '#' *> notFollowedBy (oneOf "#@$%?") *> many notLineEnd) unknown :: Parser Record unknown = Error "Record type detection failed" <$ skipMany notLineEnd requestOptions :: Parser RequestOptions-requestOptions = runPermParser $ RequestOptions- <$> (fixRestrictions <$> requestTypes)- <*> (getMaybeAll <$> requestOptionNorm "ThirdParty")- <*> (fixRestrictions <$> optionalDomain)- <*> (getAllOrFalse <$> requestOptionNorm "MatchCase")- <*> (getMaybeAll <$> requestOptionNorm "Collapse")- <*> (getAllOrFalse <$> requestOptionNorm "Donottrack")- <*> (getAllOrFalse <$> requestOptionNorm "Elemhide")- <* manyPerm separator- <*> unknownOption- where- optionalDomain = optionPerm noRestrictions $ try domainOption- requestTypes = Restrictions <$> (Just <$> manyPerm (try requestTypeOption)) <*> manyPerm (try notRequestTypeOption)- notRequestTypeOption = char '~' *> requestTypeOption- requestOptionNorm = manyPerm.try.requestOption- separator = try (lineSpaces *> char ',' <* lineSpaces)- unknownOption = manyPerm $ try optionName+requestOptions =+ runPermParser $+ RequestOptions+ <$> (fixRestrictions <$> requestTypes)+ <*> (getMaybeAll <$> requestOptionNorm "ThirdParty")+ <*> (fixRestrictions <$> optionalDomain)+ <*> (getAllOrFalse <$> requestOptionNorm "MatchCase")+ <*> (getMaybeAll <$> requestOptionNorm "Collapse")+ <*> (getAllOrFalse <$> requestOptionNorm "Donottrack")+ <*> (getAllOrFalse <$> requestOptionNorm "Elemhide")+ <* manyPerm separator+ <*> unknownOption+ where+ optionalDomain = optionPerm noRestrictions $ try domainOption+ requestTypes = Restrictions <$> (Just <$> manyPerm (try requestTypeOption)) <*> manyPerm (try notRequestTypeOption)+ notRequestTypeOption = char '~' *> requestTypeOption+ requestOptionNorm = manyPerm . try . requestOption+ separator = try (lineSpaces *> char ',' <* lineSpaces)+ unknownOption = manyPerm $ try unknownOptionItem+ -- Discard unknown options used by some filter-list extensions+ unknownOptionItem = optionName <* optional (char '=' *> many (noneOf (',' : eol))) requestOption :: String -> Parser All requestOption name = All <$> option True (char '~' $> False) <* checkOptionName name -- requestTypeOption :: Parser RequestType-requestTypeOption = do t <- optionName- case reads t of- [(result, "")] -> return result- _ -> pzero <?> "request type"--+requestTypeOption = do+ t <- optionName+ case reads t of+ [(result, "")] -> return result+ _ -> pzero <?> "request type" domainOption :: Parser (Restrictions Domain)-domainOption = checkOptionName "Domain" *> lineSpaces *> char '=' *> lineSpaces *> domains '|'+domainOption = checkOptionName "Domain" *> lineSpaces *> char '=' *> lineSpaces *> domains '|' optionName :: Parser String optionName = asOptionName <$> ((:) <$> letter <*> many (alphaNum <|> char '-'))- where- capitalize [] = ""- capitalize (x:xs) = toUpper x:(toLower<$>xs)- ws = split "-"- asOptionName = capitalize <=< ws+ where+ capitalize [] = ""+ capitalize (x : xs) = toUpper x : (toLower <$> xs)+ ws = split "-"+ asOptionName = capitalize <=< ws checkOptionName :: String -> Parser ()-checkOptionName name = do t <- optionName- when (name /= t) (pzero <?> "option type")+checkOptionName name = do+ t <- optionName+ when (name /= t) (pzero <?> "option type") domain :: Parser Domain domain = join . intersperse "." <$> parts- where- parts = sepBy1 domainPart (char '.')- domainPart = many1 (alphaNum <|> char '-')+ where+ parts = sepBy1 domainPart (char '.')+ -- '*' is a valid wildcard label in Adblock Plus / uBlock Origin+ domainPart = many1 (alphaNum <|> char '-' <|> char '*') domains :: Char -> Parser (Restrictions Domain) domains sep = fixRestrictions <$> runPermParser restrictions- where- restrictions = Restrictions <$> (Just <$> manyPerm (try domain)) <*> manyPerm (try notDomain) <* manyPerm (try separator)- separator = lineSpaces *> char sep <* lineSpaces- notDomain = char '~' *> domain+ where+ restrictions = Restrictions <$> (Just <$> manyPerm (try domain)) <*> manyPerm (try notDomain) <* manyPerm (try separator)+ separator = lineSpaces *> char sep <* lineSpaces+ notDomain = char '~' *> domain ---helpers+-- helpers eol :: String eol = "\r\n" lineSpaces :: Parser () lineSpaces = skipMany (satisfy isLineSpace) <?> "white space"- where isLineSpace c = c == ' ' || c == '\t'+ where+ isLineSpace c = c == ' ' || c == '\t' lineEnd :: Parser Char lineEnd = oneOf eol <|> ('\0' <$ eof)@@ -188,7 +216,6 @@ notLineEnd :: Parser Char notLineEnd = noneOf eol - getMaybeAll :: [All] -> Maybe Bool getMaybeAll [] = Nothing getMaybeAll list = Just $ getAll $ mconcat list@@ -201,9 +228,9 @@ noRestrictions = Restrictions Nothing [] fixRestrictions :: (Eq a, Ord a) => Restrictions a -> Restrictions a-fixRestrictions = deduplicate.allowAll- where- allowAll (Restrictions (Just []) n) = Restrictions Nothing n- allowAll a = a- deduplicate (Restrictions (Just p) n) = Restrictions (Just $ nubOrd p) (nubOrd n)- deduplicate a = a+fixRestrictions = deduplicate . allowAll+ where+ allowAll (Restrictions (Just []) n) = Restrictions Nothing n+ allowAll a = a+ deduplicate (Restrictions (Just p) n) = Restrictions (Just $ nubOrd p) (nubOrd n)+ deduplicate a = a
src/Main.hs view
@@ -1,90 +1,91 @@ module Main where-import InputParser-import ElementBlocker-import UrlBlocker-import Text.ParserCombinators.Parsec hiding (Line, many, optional)-import Task-import SourceInfo as Source-import ProgramOptions as Options-import System.Environment-import Templates+ import Control.Monad import Data.Time.Clock+import ElementBlocker+import GHC.IO.Encoding+import InputParser+import Network import Network.HTTP.Conduit import Network.URI+import ProgramOptions as Options+import SourceInfo as Source import System.Directory+import System.Environment import System.IO-import Network-import GHC.IO.Encoding+import Task+import Templates+import Text.ParserCombinators.Parsec hiding (Line, many, optional)+import UrlBlocker getFileContent :: String -> IO String getFileContent url = do- handle <- openFile url ReadMode- hSetEncoding handle utf8- hGetContents handle+ handle <- openFile url ReadMode+ hSetEncoding handle utf8+ hGetContents handle -processSources :: Options -> String -> [SourceInfo]-> IO ()+processSources :: Options -> String -> [SourceInfo] -> IO () processSources options taskFile sources = do- manager <- newManager tlsManagerSettings- (parsed, sourceInfo) <- mapAndUnzipM (parseSource manager) sources- let parsed' = concat parsed- sourceInfoText = showInfo sourceInfo- optionsText = logOptions options- createDirectoryIfMissing True $ _privoxyDir options- writeTask taskFile (sourceInfoText ++ optionsText) parsed'- if null._cssDomain $ options- then putStrLn "WARNING: CSS generation is not run because webserver domain is not specified"- else elemBlock (_webDir options) sourceInfoText (_debugLevel options) parsed'- urlBlock (_privoxyDir options) sourceInfoText parsed'- writeTemplateFiles (_privoxyDir options) (_cssDomain options) (_useHTTP options)- putStrLn $ "Run 'adblock2privoxy -t " ++ taskFile ++ "' every 1-2 days to process data updates."- where- parseSource manager sourceInfo = do- let- url = _url sourceInfo- loader = if isURI url then downloadHttp manager 5 else getFileContent- putStrLn $ "process " ++ url- text <- loader url- now <- getCurrentTime- let strictParse = text `seq` parse adblockFile url text- case strictParse of- Right parsed ->- let sourceInfo' = updateInfo now parsed sourceInfo- url' = _url sourceInfo'- in if url == url'- then return (parsed, sourceInfo')- else parseSource manager sourceInfo'- Left msg -> return ([], sourceInfo) <$ putStrLn $ show msg+ manager <- newManager tlsManagerSettings+ (parsed, sourceInfo) <- mapAndUnzipM (parseSource manager) sources+ let parsed' = concat parsed+ sourceInfoText = showInfo sourceInfo+ optionsText = logOptions options+ createDirectoryIfMissing True $ _privoxyDir options+ writeTask taskFile (sourceInfoText ++ optionsText) parsed'+ if null . _cssDomain $ options+ then putStrLn "WARNING: CSS generation is not run because webserver domain is not specified"+ else elemBlock (_webDir options) sourceInfoText (_debugLevel options) parsed'+ urlBlock (_privoxyDir options) sourceInfoText parsed'+ writeTemplateFiles (_privoxyDir options) (_cssDomain options) (_useHTTP options)+ putStrLn $ "Run 'adblock2privoxy -t " ++ taskFile ++ "' every 1-2 days to process data updates."+ where+ parseSource manager sourceInfo = do+ let url = _url sourceInfo+ loader = if isURI url then downloadHttp manager 5 else getFileContent+ putStrLn $ "process " ++ url+ text <- loader url+ now <- getCurrentTime+ let strictParse = text `seq` parse adblockFile url text+ case strictParse of+ Right parsed ->+ let sourceInfo' = updateInfo now parsed sourceInfo+ url' = _url sourceInfo'+ in if url == url'+ then return (parsed, sourceInfo')+ else parseSource manager sourceInfo'+ Left msg -> ([], sourceInfo) <$ putStrLn (show msg) -main::IO()-main = do- setLocaleEncoding utf8- setFileSystemEncoding utf8- setForeignEncoding utf8- now <- getCurrentTime- args <- getArgs- (options@(Options printVersion _ _ taskFile _ _ _ forced), urls) <- parseOptions args- (options', task) <- do- fileExists <- doesFileExist taskFile- if fileExists- then do task <- readTask taskFile- return (fillFromLog options task, Just task)- else return (options, Nothing)- let- action- | printVersion = putStrLn versionText- | not . null $ urls- = processSources options' taskFile (makeInfo <$> urls)- | otherwise = case task of- Nothing -> writeError "no input specified"- (Just task') -> do- let sources = Source.readLogInfos task'- if forced || any (infoExpired now) sources- then processSources options' taskFile sources- else putStrLn "all sources are up to date"- debug = _debugLevel options- when (debug > DebugLevel 0) $- putStrLn $ concat ["Debug level '", show debug, "'."]- action- now' <- getCurrentTime- putStrLn $ concat ["Execution done in ", show $ diffUTCTime now' now, " seconds."]+main :: IO ()+main = do+ setLocaleEncoding utf8+ setFileSystemEncoding utf8+ setForeignEncoding utf8+ now <- getCurrentTime+ args <- getArgs+ (options@(Options printVersion _ _ taskFile _ _ _ forced), urls) <- parseOptions args+ (options', task) <- do+ fileExists <- doesFileExist taskFile+ if fileExists+ then do+ task <- readTask taskFile+ return (fillFromLog options task, Just task)+ else return (options, Nothing)+ let action+ | printVersion = putStrLn versionText+ | not . null $ urls =+ processSources options' taskFile (makeInfo <$> urls)+ | otherwise = case task of+ Nothing -> writeError "no input specified"+ (Just task') -> do+ let sources = Source.readLogInfos task'+ if forced || any (infoExpired now) sources+ then processSources options' taskFile sources+ else putStrLn "all sources are up to date"+ debug = _debugLevel options+ when (debug > DebugLevel 0)+ $ putStrLn+ $ concat ["Debug level '", show debug, "'."]+ action+ now' <- getCurrentTime+ putStrLn $ concat ["Execution done in ", show $ diffUTCTime now' now, " seconds."]
src/Network.hs view
@@ -1,24 +1,24 @@-module Network (- downloadHttp-)+module Network+ ( downloadHttp,+ ) where -import Network.HTTP.Conduit-import Data.Text.Lazy.Encoding-import Data.Text.Lazy (unpack) import Control.Exception+import Data.Text.Lazy (unpack)+import Data.Text.Lazy.Encoding+import Network.HTTP.Conduit -- | A simpleHttp alternative that specifies bigger timeout and retries connection attempts-downloadHttp :: Manager -> Int -> String -> IO String+downloadHttp :: Manager -> Int -> String -> IO String downloadHttp manager retries url = do- putStrLn $ "load " ++ url ++ " (" ++ show retries ++ " more attempts)..."- req <- parseUrlThrow url -- parseUrl- let req' = req- -- let req' = req {responseTimeoutMicro = Just 15000000}- result <- try (responseBody <$> httpLbs req' manager)- case result of- Left e@(HttpExceptionRequest _ (ConnectionFailure _)) ->- -- Left e@(FailedConnectionException _ _) ->- if retries > 0 then downloadHttp manager (retries - 1) url else throw e- Left e -> throw e- Right content -> return $ unpack.decodeUtf8 $ content+ putStrLn $ "load " ++ url ++ " (" ++ show retries ++ " more attempts)..."+ req <- parseUrlThrow url -- parseUrl+ let req' = req+ -- let req' = req {responseTimeoutMicro = Just 15000000}+ result <- try (responseBody <$> httpLbs req' manager)+ case result of+ Left e@(HttpExceptionRequest _ (ConnectionFailure _)) ->+ -- Left e@(FailedConnectionException _ _) ->+ if retries > 0 then downloadHttp manager (retries - 1) url else throw e+ Left e -> throw e+ Right content -> return $ unpack . decodeUtf8 $ content
src/OptionsConverter.hs view
@@ -1,26 +1,38 @@ {-# LANGUAGE StrictData #-} -module OptionsConverter (- HeaderFilters,+module OptionsConverter+ ( HeaderFilters, Filter (..), HeaderType (..), HeaderFilter (..),- headerFilters-) where-import InputParser+ headerFilters,+ )+where+ import Control.Monad import Data.Containers.ListUtils import Data.List import Data.Maybe-import Data.String.Utils (replace)-import {-# SOURCE #-} UrlBlocker+import InputParser+import {-# SOURCE #-} UrlBlocker+import Utils (replace) type FilterFabrique = Policy -> RequestOptions -> HeaderPolicy-data HeaderType = HeaderType {_name :: String, _taggerType :: TaggerType, _level :: Int,- _typeCode :: Char, _fabrique :: FilterFabrique}-data Filter = Filter { _code :: String, _regex :: String, _orEmpty :: Bool } deriving Eq-data HeaderPolicy = Specific Filter | Any | None deriving Eq++data HeaderType = HeaderType+ { _name :: String,+ _taggerType :: TaggerType,+ _level :: Int,+ _typeCode :: Char,+ _fabrique :: FilterFabrique+ }++data Filter = Filter {_code :: String, _regex :: String, _orEmpty :: Bool} deriving (Eq)++data HeaderPolicy = Specific Filter | Any | None deriving (Eq)+ data HeaderFilter = HeaderFilter HeaderType Filter+ type HeaderFilters = [[HeaderFilter]] allTypes :: [HeaderType]@@ -32,127 +44,140 @@ requestedWith = HeaderType "x-requested-with" Client 1 'X' requestedWithFilter referer = HeaderType "referer" Client 2 'R' refererFilter - headerFilters :: Policy -> Int -> RequestOptions -> Maybe HeaderFilters headerFilters _ 0 _ = Just []-headerFilters policy level requestOptions@RequestOptions{_requestType = requestType}- = let requestOptions' = requestOptions{_requestType = convertPopup $ convertOther requestType}- in do- nextLevel <- headerFilters policy (level - 1) requestOptions'- let- passthrough = checkPassthrough requestOptions'+headerFilters policy level requestOptions@RequestOptions {_requestType = requestType} =+ let requestOptions' = requestOptions {_requestType = convertPopup $ convertOther requestType}+ in do+ nextLevel <- headerFilters policy (level - 1) requestOptions'+ let passthrough = checkPassthrough requestOptions' filters = do- headerType <- allTypes- guard (_level headerType == level)- case _fabrique headerType policy requestOptions' of- Specific filter' -> return $ Just $ HeaderFilter headerType filter'- None -> return Nothing- Any -> mzero- when (not passthrough && all isNothing filters && not (null filters)) $ fail "filters blocked"- return $ case catMaybes filters of- [] -> nextLevel- filters' -> filters' : nextLevel+ headerType <- allTypes+ guard (_level headerType == level)+ case _fabrique headerType policy requestOptions' of+ Specific filter' -> return $ Just $ HeaderFilter headerType filter'+ None -> return Nothing+ Any -> mzero+ when (not passthrough && all isNothing filters && not (null filters)) $ fail "filters blocked"+ return $ case catMaybes filters of+ [] -> nextLevel+ filters' -> filters' : nextLevel convertPopup :: Restrictions RequestType -> Restrictions RequestType-convertPopup (Restrictions positive negative)= Restrictions positive' negative- where+convertPopup (Restrictions positive negative) = Restrictions positive' negative+ where positiveContentTypes = fromMaybe [] positive >>= contentTypes True- positive' | Popup `elem` negative && null positiveContentTypes = Nothing- | otherwise = positive+ positive'+ | Popup `elem` negative && null positiveContentTypes = Nothing+ | otherwise = positive convertOther :: Restrictions RequestType -> Restrictions RequestType-convertOther (Restrictions positive negative)= Restrictions positive' negative'- where+convertOther (Restrictions positive negative) = Restrictions positive' negative'+ where allContentOptions = [Script, Image, Stylesheet, Object, ObjectSubrequest, Document] positiveList = fromMaybe [] positive- negative' | Other `elem` positiveList = allContentOptions \\ positiveList- | otherwise = negative- positive' | Other `elem` negative = Just $ allContentOptions \\ negative'- | positive == Just [Other] = Nothing- | otherwise = positive+ negative'+ | Other `elem` positiveList = allContentOptions \\ positiveList+ | otherwise = negative+ positive'+ | Other `elem` negative = Just $ allContentOptions \\ negative'+ | positive == Just [Other] = Nothing+ | otherwise = positive checkPassthrough :: RequestOptions -> Bool-checkPassthrough RequestOptions {_requestType = (Restrictions positive _) }- = maybe False (not . null . intersect [Subdocument, Popup]) positive+checkPassthrough RequestOptions {_requestType = (Restrictions positive _)} =+ maybe False (not . null . intersect [Subdocument, Popup]) positive acceptFilter, contentTypeFilter, requestedWithFilter, refererFilter :: FilterFabrique--contentTypeFilter policy (RequestOptions (Restrictions positive negative) thirdParty _ _ _ _ _ _)- | fromMaybe True emptyPositive && isJust positive = None- | result == mempty = Any- | otherwise = Specific $ Filter code regex orEmpty- where- negative' | isNothing positive && fromMaybe False thirdParty = Document : negative- | otherwise = negative+contentTypeFilter policy (RequestOptions (Restrictions positive negative) thirdParty _ _ _ _ _ _)+ | fromMaybe True emptyPositive && isJust positive = None+ | result == mempty = Any+ | otherwise = Specific $ Filter code regex orEmpty+ where+ negative'+ | isNothing positive && fromMaybe False thirdParty = Document : negative+ | otherwise = negative negativePart = mappend ("n", "") <$> convert False negative' positivePart = positive >>= convert True result@(code, regex) = mconcat $ catMaybes [positivePart, negativePart] orEmpty = (policy == Unblock) && isNothing positive emptyPositive = not . any (`notElem` maybe "" fst negativePart) . fst <$> positivePart - convert _ [] = Nothing- convert include requestTypes | null code' = Nothing- | otherwise = Just (code', regex')- where contentTypes' = nubOrd $ requestTypes >>= contentTypes include- code' = sort $ head . dropWhile (`elem` "/(?:x-)") <$> contentTypes'- regex' = lookahead contentTypes' "[\\s\\w]*" include-+ convert _ [] = Nothing+ convert include requestTypes+ | null code' = Nothing+ | otherwise = Just (code', regex')+ where+ contentTypes' = nubOrd $ requestTypes >>= contentTypes include+ code' = sort $ mapMaybe (listToMaybe . dropWhile (`elem` "/(?:x-)")) contentTypes'+ regex' = lookahead contentTypes' "[\\s\\w]*" include acceptFilter excludePattern options = case contentTypeFilter excludePattern options of- Specific res -> Specific res {_orEmpty = False}- other -> other---requestedWithFilter _ RequestOptions{ _requestType = Restrictions positive negative } =- case result of- Nothing -> Any- Just result' -> Specific $ Filter (code result') (lookahead ["xmlhttprequest"] "\\s*" result') (not result')- where+ Specific res -> Specific res {_orEmpty = False}+ other -> other+requestedWithFilter _ RequestOptions {_requestType = Restrictions positive negative} =+ case result of+ Nothing -> Any+ Just result' -> Specific $ Filter (code result') (lookahead ["xmlhttprequest"] "\\s*" result') (not result')+ where code True = "x" code False = "nx"- result | Xmlhttprequest `elem` negative = Just False- | Xmlhttprequest `elem` fromMaybe [] positive = Just True- | hasContentTypes False negative- && maybe True (not . hasContentTypes True) positive = Just True- | otherwise = Nothing+ result+ | Xmlhttprequest `elem` negative = Just False+ | Xmlhttprequest `elem` fromMaybe [] positive = Just True+ | hasContentTypes False negative+ && maybe True (not . hasContentTypes True) positive =+ Just True+ | otherwise = Nothing hasContentTypes include = not . all (null . contentTypes include)---refererFilter policy RequestOptions{ _thirdParty = thirdParty, _domain = Restrictions positive negative }- | fromMaybe False emptyPositive = None- | result == mempty = Any- | otherwise = Specific $ Filter code regex orEmpty- where+refererFilter policy RequestOptions {_thirdParty = thirdParty, _domain = Restrictions positive negative}+ | fromMaybe False emptyPositive = None+ | result == mempty = Any+ | otherwise = Specific $ Filter code regex orEmpty+ where negativePart = mappend ("n", "") <$> convert False negative positivePart = positive >>= convert True- thirdPartyPart tp = (if tp then "t" else "nt",- concat ["(?", lookAheadPolicy $ not tp,- ":\\s*(?:https?:\\/\\/)?(?:[\\w.-]*\\.)?([\\w-]+\\.[\\w-]+)[^\\w.-].*\\1$)",- "\ns@^referer:.*@$&\\t$host@Di"])+ thirdPartyPart tp =+ ( if tp then "t" else "nt",+ concat+ [ "(?",+ lookAheadPolicy $ not tp,+ ":\\s*(?:https?:\\/\\/)?(?:[\\w.-]*\\.)?([\\w-]+\\.[\\w-]+)[^\\w.-].*\\1$)",+ "\ns@^referer:.*@$&\\t$host@Di"+ ]+ ) result@(code, regex) = mconcat $ catMaybes [positivePart, negativePart, thirdPartyPart <$> thirdParty] emptyPositive = not . any (`notElem` negative) <$> positive- orEmpty = (policy == Unblock) && (isNothing positive || not (fromMaybe True thirdParty))+ orEmpty = (policy == Unblock) && (isNothing positive || not (fromMaybe True thirdParty)) convert _ [] = Nothing- convert include domains = let- code' = intercalate "][" $ sort domains- regex' = lookahead domains "[^\\n]*[./]" include- in Just ("[" ++ code' ++ "]", regex')+ convert include domains =+ let code' = intercalate "][" $ sort domains+ regex' = lookahead domains "[^\\n]*[./]" include+ in Just ("[" ++ code' ++ "]", regex') lookAheadPolicy :: Bool -> String lookAheadPolicy True = "=" lookAheadPolicy False = "!" lookahead :: [String] -> String -> Bool -> String-lookahead list prefix include = join ["(?", lookAheadPolicy include,- ":", prefix ,"(?:", intercalate "|" $ excapeRx <$> list, "))"]- where- excapeRx = replace "/" "\\/" . replace "." "\\."+lookahead list prefix include =+ join+ [ "(?",+ lookAheadPolicy include,+ ":",+ prefix,+ "(?:",+ intercalate "|" $ excapeRx <$> list,+ "))"+ ]+ where+ excapeRx = replace "/" "\\/" . replace "." "\\." contentTypes :: Bool -> RequestType -> [String] contentTypes _ Script = ["/(?:x-)?javascript"] contentTypes _ Image = ["image/"] contentTypes _ Stylesheet = ["/css"]-contentTypes _ Object = ["video/","audio/","/(?:x-)?shockwave-flash"]-contentTypes _ ObjectSubrequest = ["video/","audio/","/octet-stream"]+contentTypes _ Object = ["video/", "audio/", "/(?:x-)?shockwave-flash"]+contentTypes _ ObjectSubrequest = ["video/", "audio/", "/octet-stream"] contentTypes _ Document = ["/html", "/xml"] contentTypes False Subdocument = ["/html", "/xml"] contentTypes _ _ = []
src/ParsecExt.hs view
@@ -1,74 +1,81 @@-module ParsecExt (- CasesParser,+module ParsecExt+ ( CasesParser, StateParser, StringStateParser, cases, manyCases, many1Cases,- oneCase-) where+ oneCase,+ )+where -import Utils import Control.Applicative hiding (many)-import Text.ParserCombinators.Parsec hiding ((<|>),State) import Control.Monad import Control.Monad.RWS import Control.Monad.State import Data.Maybe+import Text.ParserCombinators.Parsec hiding (State, (<|>))+import Utils -- parser should consume some input to prevent infinite loop manyCases :: (Monoid a, Monoid st) => Parser a -> StateParser st a-manyCases p = do acc <- get- put $ Just mempty- lift $ if isNothing acc- then return mempty- else p+manyCases p = do+ acc <- get+ put $ Just mempty+ lift $+ if isNothing acc+ then return mempty+ else p oneCase :: (Monoid a, Monoid st) => Parser a -> StateParser st a-oneCase p = do acc <- get- put $ Just mempty- lift $ if isNothing acc- then p- else pzero+oneCase p = do+ acc <- get+ put $ Just mempty+ lift $+ if isNothing acc+ then p+ else pzero many1Cases :: Parser a -> StateParser st a many1Cases = lift type StringStateParser = StateParser String+ type StateParser st = StateT (Maybe st) Parser+ type CasesParser st r = RWST () [r] String (StateParser st) optionMaybeTry :: StateParser st a -> StateParser st (Maybe a) optionMaybeTry p = fmap Just (mapStateT try p) <|> return Nothing -cases :: forall r st.(Monoid r) => [StateParser st r] -> Parser [r]-cases parsers = evalStateT stateParser Nothing- where stateParser = do- input <- lift getInput- let boxedParser = (mapRWST.mapStateT) lookAhead $ casesParser mempty parsers- (input', res) <- execRWST boxedParser () input- lift (setInput input')- return res-+cases :: forall r st. (Monoid r) => [StateParser st r] -> Parser [r]+cases parsers = evalStateT stateParser Nothing+ where+ stateParser = do+ input <- lift getInput+ let boxedParser = (mapRWST . mapStateT) lookAhead $ casesParser mempty parsers+ (input', res) <- execRWST boxedParser () input+ lift (setInput input')+ return res -casesParser :: forall r st.(Monoid r) => r -> [StateParser st r] -> CasesParser st r ()-casesParser _ [] = error "Empty parser list is not accepted"-casesParser acc parsers@(parser:next) = do- maybeRes <- lift (optionMaybeTry parser)- case maybeRes of- Nothing -> return ()- Just res -> do- input <- lift.lift $ getInput- let acc' = acc <> res- if null input || null next- then do- modify (minList input) -- TODO: somehow use processed length to select min input- tell [acc']- else do- st <- lift get- lift (put Nothing)- (mapRWST.mapStateT) lookAhead $ casesParser acc' next- lift (put st)- unless (null input) $ casesParser acc' parsers+casesParser :: forall r st. (Monoid r) => r -> [StateParser st r] -> CasesParser st r ()+casesParser _ [] = error "Empty parser list is not accepted"+casesParser acc parsers@(parser : next) = do+ maybeRes <- lift (optionMaybeTry parser)+ case maybeRes of+ Nothing -> return ()+ Just res -> do+ input <- lift . lift $ getInput+ let acc' = acc <> res+ if null input || null next+ then do+ modify (minList input) -- TODO: somehow use processed length to select min input+ tell [acc']+ else do+ st <- lift get+ lift (put Nothing)+ (mapRWST . mapStateT) lookAhead $ casesParser acc' next+ lift (put st)+ unless (null input) $ casesParser acc' parsers ------------------------------------------------------------------------------------------------
src/ParserExtTests.hs view
@@ -1,15 +1,17 @@-module ParserExtTests (-testParsecExt,-testParseMorse,-encodeMorse-) where-import Utils-import ParsecExt+module ParserExtTests+ ( testParsecExt,+ testParseMorse,+ encodeMorse,+ )+where+ import Control.Applicative hiding (many)-import Text.ParserCombinators.Parsec hiding ((<|>),State)+import Control.Monad.State import Data.List import Data.Maybe-import Control.Monad.State+import ParsecExt+import Text.ParserCombinators.Parsec hiding (State, (<|>))+import Utils --------------------------------------------------------------------------------------------- ------------------------- parsec ext usage samples ------------------------------------------@@ -19,14 +21,13 @@ parsersChain :: [StringStateParser ExampleCase] parsersChain = square3 prefix mid suffix- where -- all parsers except for last one should consume some input and give some output- prefix = manyCases ((:[]) <$> (string "ab" <|> string "zz"))- mid = many1Cases $ (:[]) <$> letter -- list of letters- suffix = many1Cases $ try $ many1 alphaNum-+ where -- all parsers except for last one should consume some input and give some output+ prefix = manyCases ((: []) <$> (string "ab" <|> string "zz"))+ mid = many1Cases $ (: []) <$> letter -- list of letters+ suffix = many1Cases $ try $ many1 alphaNum testParsecExt :: Either ParseError [([String], String, String)]-testParsecExt = parse (cases parsersChain <* string "$$") "x" "abebz12$$"+testParsecExt = parse (cases parsersChain <* string "$$") "x" "abebz12$$" testParseMorse :: Either ParseError [String] testParseMorse = parseMorse "......-...-..---"@@ -36,42 +37,44 @@ -------------------------------------------------------------------------------- morseChars :: [(String, Char)]-morseChars = [ (".-", 'A'),- ("-...", 'B'),- ("-.-.", 'C'),- ("-..", 'D'),- (".", 'E'),- ("..-.", 'F'),- ("--.", 'G'),- ("....", 'H'),- ("..", 'I'),- (".---", 'J'),- ("-.-", 'K'),- (".-..", 'L'),- ("--", 'M'),- ("-.", 'N'),- ("---", 'O'),- (".--.", 'P'),- ("--.-", 'Q'),- (".-.", 'R'),- ("...", 'S'),- ("-", 'T'),- ("..-", 'U'),- ("...-", 'V'),- (".--", 'W'),- ("-..-", 'X'),- ("-.--", 'Y'),- ("--..", 'Z'),- ("-----", '0'),- (".----", '1'),- ("..---", '2'),- ("...--", '3'),- ("....-", '4'),- (".....", '5'),- ("-....", '6'),- ("--...", '7'),- ("---..", '8'),- ("----.", '9')]+morseChars =+ [ (".-", 'A'),+ ("-...", 'B'),+ ("-.-.", 'C'),+ ("-..", 'D'),+ (".", 'E'),+ ("..-.", 'F'),+ ("--.", 'G'),+ ("....", 'H'),+ ("..", 'I'),+ (".---", 'J'),+ ("-.-", 'K'),+ (".-..", 'L'),+ ("--", 'M'),+ ("-.", 'N'),+ ("---", 'O'),+ (".--.", 'P'),+ ("--.-", 'Q'),+ (".-.", 'R'),+ ("...", 'S'),+ ("-", 'T'),+ ("..-", 'U'),+ ("...-", 'V'),+ (".--", 'W'),+ ("-..-", 'X'),+ ("-.--", 'Y'),+ ("--..", 'Z'),+ ("-----", '0'),+ (".----", '1'),+ ("..---", '2'),+ ("...--", '3'),+ ("....-", '4'),+ (".....", '5'),+ ("-....", '6'),+ ("--...", '7'),+ ("---..", '8'),+ ("----.", '9')+ ] morseCharCodes :: [String] morseCharCodes = fst <$> morseChars@@ -79,44 +82,46 @@ -- HELLO = "......-...-..---" encodeMorse :: String -> String encodeMorse s = fst =<< mapMaybe code s- where code c = find (\pair -> snd pair == c) morseChars+ where+ code c = find (\pair -> snd pair == c) morseChars decodeMorse :: [String] -> String decodeMorse ss = snd <$> mapMaybe code ss- where code s = find (\pair -> fst pair == s) morseChars-+ where+ code s = find (\pair -> fst pair == s) morseChars -- find possibilites to continue from a given prefix findMorseSteps :: String -> [String] -> [String] findMorseSteps prefix codes = case find (== prefix) codes of- Nothing -> case filter (isPrefixOf prefix) codes of- [] -> []- filtered -> findMorseSteps (prefix ++ ".") filtered- ++ findMorseSteps (prefix ++ "-") filtered- Just match -> [match]+ Nothing -> case filter (isPrefixOf prefix) codes of+ [] -> []+ filtered ->+ findMorseSteps (prefix ++ ".") filtered+ ++ findMorseSteps (prefix ++ "-") filtered+ Just match -> [match] morseStepParser :: [String] -> Parser String morseStepParser [] = pzero morseStepParser [step] = string step-morseStepParser (step:steps') = string step <|> morseStepParser steps'+morseStepParser (step : steps') = string step <|> morseStepParser steps' morseParser :: Int -> StringStateParser (ZipListM String)-morseParser pos = do acc' <- get- let acc = fromMaybe "" acc'- candidates = filter (\x -> isPrefixOf acc x && acc /= x) morseCharCodes- steps = drop (length acc) <$> findMorseSteps acc candidates- parser = morseStepParser steps- res <- lift parser- put (Just $ acc ++ res)- return (zipListM $ replicate pos "" ++ (res : repeat ""))-+morseParser pos = do+ acc' <- get+ let acc = fromMaybe "" acc'+ candidates = filter (\x -> isPrefixOf acc x && acc /= x) morseCharCodes+ steps = drop (length acc) <$> findMorseSteps acc candidates+ parser = morseStepParser steps+ res <- lift parser+ put (Just $ acc ++ res)+ return (zipListM $ replicate pos "" ++ (res : repeat "")) morseParsers :: [StringStateParser (ZipListM String)] morseParsers = repeat morseParser <*> [0 ..] parseMorse :: String -> Either ParseError [String] parseMorse s = fmap postProcess <$> parseMorseRaw "x" s- where- parseMorseRaw = parse (cases morseParsers)- postProcess = decodeMorse.toLists- toLists = takeWhile (not . null) . getZipListM+ where+ parseMorseRaw = parse (cases morseParsers)+ postProcess = decodeMorse . toLists+ toLists = takeWhile (not . null) . getZipListM
src/PatternConverter.hs view
@@ -1,204 +1,505 @@ {-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeApplications #-} -module PatternConverter (-makePattern,-parseUrl-) where-import InputParser+module PatternConverter+ ( makePattern,+ parseUrl,+ -- expose utility functions for maintenance and testing+ UrlPattern (..),+ RuleShape (..),+ SideBind (..),+ classifyLine,+ globWildcard,+ maxPatternLength,+ bindStart,+ bindEnd,+ patternEnd,+ unparsedHostPrefix,+ repairUnparsedHost,+ splitClosingSlash,+ hasUnsupportedPCRE,+ isOverbroadPattern,+ postfilter,+ urlParts,+ makeUrl,+ makeUrls,+ )+where+ import Control.Applicative hiding (many)-import Text.ParserCombinators.Parsec hiding (Line, (<|>))+import Control.Exception (evaluate, handle) import Control.Monad+import Control.Monad (guard) import Control.Monad.State+import Data.Char (isAlphaNum, isDigit) import Data.List import Data.Maybe-import Data.String.Utils (replace)-import Data.List.Utils (split)+import qualified Data.Text as T+import InputParser import ParsecExt+import System.IO.Unsafe (unsafePerformIO)+import Text.ParserCombinators.Parsec hiding (Line, (<|>))+import Text.Regex.Pcre2 (SomePcre2Exception, match) import Utils +-- https://github.com/AdguardTeam/AdGuardHome/wiki/Hosts-Blocklists+-- https://www.privoxy.org/user-manual/actions-file.html++data UrlPattern = UrlPattern+ { _bindStart :: SideBind,+ _proto :: String,+ _host :: String,+ _path :: String,+ _bindEnd :: SideBind,+ _regex :: Bool+ }+ deriving (Show, Eq)++-- The three mutually-exclusive rule shapes AdGuard's syntax describes,+-- decided once up front rather than by elimination after a failed parse+data RuleShape = Cosmetic | BareRegex String String | Structured Pattern+ deriving (Show, Eq)+ data SideBind = Hard | Soft | None deriving (Show, Eq) -data UrlPattern = UrlPattern {- _bindStart :: SideBind,- _proto :: String,- _host :: String,- _query :: String,- _bindEnd :: SideBind,- _regex :: Bool }- deriving (Show)+-- Lookaround markers PCRE2 accepts fine on their own+lookaroundMarkers :: [String]+lookaroundMarkers = ["(?=", "(?!", "(?<=", "(?<!"] +-- Count non-overlapping occurrences of a substring+countOccurrences :: String -> String -> Int+countOccurrences needle haystack = length (filter (needle `isPrefixOf`) (tails haystack))++-- Two or more chained lookarounds is the shape that can explode Privoxy's backtracking; one alone is fine+hasMultipleLookarounds :: String -> Bool+hasMultipleLookarounds pattern = sum [countOccurrences m pattern | m <- lookaroundMarkers] >= 2++-- True if PCRE2 rejects the pattern outright, or it has the multi-lookaround shape+hasUnsupportedPCRE :: String -> Bool+hasUnsupportedPCRE pattern =+ hasMultipleLookarounds pattern+ || unsafePerformIO+ ( handle @SomePcre2Exception (\_ -> return True) $ do+ _ <- evaluate (match (T.pack pattern) T.empty :: Maybe T.Text)+ return False+ )+{-# NOINLINE hasUnsupportedPCRE #-}++-- Maximum reasonable pattern length for Privoxy+maxPatternLength :: Int+maxPatternLength = 8000++-- possessive wildcard .*+ is more efficient in PCRE2+globWildcard :: String+globWildcard = ".*+"++caretSeparator :: String+caretSeparator = "[^\\w%.-]"++-- A host-unrestricted pattern whose path is just the wildcard expansion matches every URL+isOverbroadPattern :: String -> String -> Bool+isOverbroadPattern host' path' = null host' && path' `elem` [globWildcard, globWildcard ++ "$"]+ makePattern :: Bool -> UrlPattern -> Pattern-makePattern matchCase (UrlPattern bindStart proto host query bindEnd isRegex)- | query' == "" = host'- | otherwise = host' ++ separator' ++ query'- where- separator'- | matchCase = "/(?-i)"- | otherwise = "/"- host' = case host of- "" -> ""- _ -> changeFirst.changeLast $ host- where- changeLast [] = []- changeLast ['.', '*']- | query' == "" = "."- | otherwise = ".*"- changeLast ['*', '.']- | query' == "" = "*."- | otherwise = "*.*"- changeLast [lst]- | lst == '|' || lst `elem` hostSeparators = []- | lst == '*' && query' == "" = "*."- | lst == '*' && query' /= "" = "*"- | lst == '.' = "."- | otherwise = lst : "*."- changeLast (c:cs) = c : changeLast cs+makePattern matchCase (UrlPattern bindStart proto host path bindEnd isRegex)+ -- host and path both collapsed to nothing (e.g. *$doc): matches every URL, not a real rule+ | host' == "" && path' == "" =+ "# FILTERED: Pattern is over-broad (matches every path)"+ | path' == "" = host'+ -- Filter out patterns with unsupported PCRE+ | hasUnsupportedPCRE path' =+ "# FILTERED: Pattern contains PCRE features unsupported by Privoxy (lookahead/lookbehind/etc.)"+ -- Filter out rules that match every path on every host+ | isOverbroadPattern host' path' =+ "# FILTERED: Pattern is over-broad (matches every path)"+ -- Filter out excessively long patterns+ | length fullPattern > maxPatternLength =+ "# FILTERED: Pattern exceeds maximum length (" ++ show maxPatternLength ++ " chars)"+ | otherwise = host' ++ separator' ++ path'+ where+ fullPattern = host' ++ separator' ++ path'+ separator'+ | matchCase = "/(?-i)"+ | otherwise = "/"+ -- Privoxy host pattern with FEATURE_PCRE_HOST_PATTERNS+ host' = case host of+ "" -> ""+ -- Drop unnecessary wildcard for Privoxy hosts+ "*" -> ""+ _ ->+ let (domainPart, portPart) = splitHostPort host+ -- A port is a fixed, non-continuable token: don't glue the+ -- subdomain-continuation glob onto it, or it lands between+ -- the port and the path instead of terminating the host+ domainGlob = if null portPart then changeLast domainPart else domainPart+ hostGlob = changeFirst domainGlob ++ portPart+ in if hostNeedsPCRE hostGlob+ then "PCRE-HOST-PATTERN:" ++ pcreHostPattern hostGlob+ else hostGlob+ where+ -- A parsed host has at most one :, marking an explicit port+ splitHostPort s = case break (== ':') s of+ (domain, port@(':' : _)) -> (domain, port)+ _ -> (s, "") - changeFirst [] = []- changeFirst (first:cs)- | first == '*' = '.' : '*' : cs- | first == '.' || bindStart == Hard || proto /= "" = first : cs- | bindStart == Soft = '.' : first : cs- | otherwise = '.' : '*' : first : cs+ changeLast [] = []+ changeLast ['.', '*']+ | path' == "" = "."+ | otherwise = ".*"+ changeLast ['*', '.']+ | path' == "" = "*."+ | otherwise = "*.*"+ changeLast [lst]+ | lst == '|' || lst `elem` hostSeparators = []+ | lst == '*' && path' == "" = "*."+ | lst == '*' && path' /= "" = "*"+ | lst == '-' = "-*" -- trailing '-' can't be a real DNS label char; it's a prefix wildcard+ | otherwise = lst : []+ changeLast (c : cs) = c : changeLast cs - query' = case query of- "" -> ""- (start:other) ->- if isRegex then query- else case query of- '*' : '/' : other' -> replaceQuery '/' other' True- '*' : '^' : other' -> replaceQuery '^' other' True- _ -> replaceQuery start other (bindStart == None && host == "")- where- replaceQuery c cs openStart = replaceFirst c openStart ++ (join . map replaceWildcard $ cs) ++ queryEnd- {- http://blogs.perl.org/users/mauke/2017/05/converting-glob-patterns-to-efficient-regexes-in-perl-and-javascript.html -}- replaceFirst '*' _ = "(*PRUNE).*?"- replaceFirst c openStart- | c == '/' || c == '^' = if openStart- then "(?:(*PRUNE).*?" ++ replaceWildcard c ++ ")?"- else ""- | otherwise = if openStart- then "(*PRUNE).*?" ++ replaceWildcard c- else replaceWildcard c+ changeFirst [] = []+ changeFirst (first : cs)+ | first == '*' = '.' : '*' : cs+ | first == '.' || bindStart == Hard || proto /= "" = first : cs+ | bindEnd == Hard = '.' : '*' : first : cs+ | bindStart == Soft = '.' : first : cs+ | otherwise = '.' : '*' : first : cs - queryEnd = if bindEnd == None then "" else "$"+ path' = case path of+ "" -> ""+ (start : other) ->+ if isRegex+ then path+ else case path of+ '*' : '/' : other' -> replacePath '/' other' True True+ '*' : '^' : other' -> replacePath '^' other' True True+ -- a bare trailing ^ means non-word char OR end of address, not a required char+ _+ | bindEnd == None,+ "^" `isSuffixOf` path ->+ ( case init path of+ "" -> ""+ (s : o) -> replacePath s o (bindStart == None && host == "" && not (isPathAnchored (init path))) False+ )+ ++ "(?:"+ ++ caretSeparator+ ++ "|$)"+ -- a literal leading / is its own anchor+ _ -> replacePath start other (bindStart == None && host == "" && not (isPathAnchored path)) False+ where+ isPathAnchored q = "/" `isPrefixOf` q+ where+ replacePath c cs openStart collapsed =+ replaceFirst c openStart collapsed+ ++ concatMap renderChunk (tokenizeBracketClasses cs)+ ++ pathEndAnchor+ replaceFirst '*' _ _ = globWildcard+ -- collapsed=True only for an explicit */ or *^ prefix, where the+ -- separator can be folded into the preceding wildcard as optional;+ -- a bare leading / or ^ with no wildcard must stay a required literal+ replaceFirst c openStart collapsed+ | collapsed && (c == '/' || c == '^') =+ if openStart+ then "(?:" ++ globWildcard ++ replaceWildcard c ++ ")?"+ else ""+ -- makePattern will insert /+ | c == '/' && not openStart = ""+ | otherwise =+ if openStart+ then globWildcard ++ replaceWildcard c+ else replaceWildcard c - replaceWildcard c- | c == '^' = "[^\\w%.-]"- | c == '*' = "(*PRUNE).*?"- | c `elem` special = '\\' : [c]- | otherwise = [c]- where special = "?$.+[]{}()\\|" -- also ^ and * are special+ pathEndAnchor = if bindEnd == None then "" else "$" + replaceWildcard c+ | c == '^' = caretSeparator+ | c == '*' = globWildcard+ | c `elem` special = '\\' : [c]+ | otherwise = [c]+ where+ special = "?$.+[{}()\\|" -- also ^ and * are special+ -- Note: lone ']' outside a bracket class is not special in PCRE + -- Split a path string into alternating plain-text runs and bracket character classes+ tokenizeBracketClasses :: String -> [Either String String]+ tokenizeBracketClasses [] = []+ tokenizeBracketClasses s@(x : xs)+ | x == '[',+ Just (cls, rest) <- matchClass xs =+ Right ('[' : cls ++ "]") : tokenizeBracketClasses rest+ | otherwise =+ let (plain, rest) = breakNextBracket s+ in Left plain : tokenizeBracketClasses rest+ where+ -- Like 'break (== \'[\')', but always consumes at least the first character first+ breakNextBracket :: String -> (String, String)+ breakNextBracket [] = ([], [])+ breakNextBracket (c : cs) =+ let (p, r) = break (== '[') cs in (c : p, r)+ matchClass ys = case break (== ']') ys of+ (body, ']' : rest')+ | not (null body) && all isClassChar body -> Just (body, rest')+ _ -> Nothing+ isClassChar ch = isAlphaNum ch || ch `elem` "-^"++ renderChunk :: Either String String -> String+ renderChunk (Left plain) = concatMap replaceWildcard plain+ renderChunk (Right cls) = cls+ hostSeparators :: String hostSeparators = "^/" -parseUrl :: Pattern -> Either ParseError [UrlPattern]-parseUrl =- let raw = makeUrls <$> bindStart <*> cases urlParts <*> bindEnd- in parse (join <$> (fmap.fmap) postfilter raw) "url"- where- makeUrls start mid end = (makeUrl start <$> mid) <*> pure end- makeUrl start (proto, host, query) end = UrlPattern start proto (trimTrailingNul host) query end False+-- Privoxy's non-PCRE host glob syntax+isPlainHostChar :: Char -> Bool+isPlainHostChar c = isAlphaNum c || c `elem` "-.*?:" - bindStart = (try (Soft <$ string "||") <|> try (Hard <$ string "|") <|> return None) <?> "query start"- queryEnd = (char '|' <* eof) <|> ('\0' <$ eof) <|> char '\0' <?> "query end"- bindEnd = (\c -> if c == '|' then Hard else None) <$> queryEnd- port = option False $ many1 (noneOf ":") *> char ':' *> many1 (digit <|> char '*') *> optionMaybe (oneOf "/^") *> (True <$ queryEnd)+hostNeedsPCRE :: String -> Bool+hostNeedsPCRE = any (not . isPlainHostChar) - trimTrailingNul :: String -> String- trimTrailingNul [] = []- trimTrailingNul (c:cs)- | null cs && c == '\0' = []- | otherwise = c : trimTrailingNul cs+-- Translate a host glob into an equivalent PCRE+pcreHostPattern :: String -> String+pcreHostPattern s = anchorStart ++ concatMap esc s ++ anchorEnd+ where+ anchorStart = if any (`isPrefixOf` s) ["*", "."] then "" else "^"+ anchorEnd = if any (`isSuffixOf` s) ["*", "."] then "" else "$"+ esc '*' = globWildcard+ esc '?' = "."+ esc '.' = "\\."+ esc c = [c] - hostChar :: Parser Char- hostChar = alphaNum <|> oneOf ".-:"+-- Parses a leading | / || URL-anchor prefix, if present+bindStart = (try (Soft <$ string "||") <|> try (Hard <$ string "|") <|> return None) <?> "query start" - protocols :: [String]- protocols = ["https://", "http://"]+-- Parses the end of a pattern: a trailing | right before end-of-input,+-- or the '\0' sentinel used to mark end-of-line, without consuming it in+-- the '\0' case (so callers can still lookAhead it)+patternEnd = (char '|' <* eof) <|> ('\0' <$ eof) <|> char '\0' <?> "pattern end" - protocolsSeparator :: String- protocolsSeparator = ";"+-- Parses a trailing | URL-anchor suffix, if present+bindEnd = (\c -> if c == '|' then Hard else None) <$> patternEnd - protocolChar :: Parser Char- protocolChar = oneOf (delete '/' $ nub $ join protocols)+-- Parses an explicit :port suffix on a host, where the port may itself+-- contain * wildcards (e.g. :80*)+portSuffix = (:) <$> char ':' <*> many1 (digit <|> char '*') - postfilter :: UrlPattern -> [UrlPattern]- postfilter url@(UrlPattern bs proto host query be _) = regular ++ regex -- ++ www- where- regex = if proto == ""- && host == ""- && "/" `isPrefixOf` query- && length query > 2- && "/" `isSuffixOf` query- then- let query' = take (length query - 2) . drop 1 $ query- in [UrlPattern bs "" "" query' be True]- else []- regular = let- leftBound = bs /= None || proto /= ""- rightBound = be /= None || query /= ""- orphanQuery = leftBound && host == "" && query /= "" && not ("*" `isPrefixOf` query)- duplicateHostStar = host == "*"- hostHasDot = isJust $ find (\c -> c == '.' || c == '*') host- firstLevelHost = host /= "" && not hostHasDot && leftBound && rightBound- hasLegalPort = case parse port "host" host of- Right val -> val- _ -> False- hasIllegalPort = not hasLegalPort && ":" `isInfixOf` host- in if not (orphanQuery || duplicateHostStar || firstLevelHost || hasIllegalPort)- then- let- query' = if "*" `isSuffixOf` host && query /= "" then '*' : query else query- in [url {_query = query'}]- else []+-- Strips a single trailing '\0' end-of-line sentinel, if present+trimTrailingNul :: String -> String+trimTrailingNul [] = []+trimTrailingNul (c : cs)+ | null cs && c == '\0' = []+ | otherwise = c : trimTrailingNul cs - -- TODO: process port as an url part- urlParts :: [StringStateParser (String,String,String)]- urlParts = square3 proto (manyCases host) (oneCase query)- where- append xs x = xs ++ [x]- proto :: StringStateParser String- proto = do- masksString <- get- case masksString of- Nothing ->- do- put $ Just $ intercalate protocolsSeparator protocols- return "" --allow to skip proto- Just masksString' ->- do- let masks = split protocolsSeparator masksString'- if null masks- then lift pzero -- no continuations available (parser have finished on previous iteration)- else- do- lift $ skipMany $ char '*' --skip leading * if presented- name <- lift $ many1 protocolChar- sep <- lift $ many $ oneOf hostSeparators- let chars = name ++ replace "^" "//" sep -- concatenate input and expand separator wildcard- nextChar <- lift $ lookAhead anyChar- let masks' = filterProtoMasks masks chars nextChar -- find possible continuations for current input- if null masks' || null chars- then lift pzero -- fail parser if no continuations or no chars read- else- do- put $ Just $ if isJust (find null masks') -- if empty continuation found (i.e. parser finished)- then "" -- make no continuations available next time- else intercalate protocolsSeparator masks'- return $ if nextChar == '*' then chars ++ "*" else chars- host = try (append <$> many hostChar <*> char '*') <|>- try (append <$> many1 hostChar <*> lookAhead separator) <?> "host"- separator = (oneOf hostSeparators <|> queryEnd) <?> "separator"- query = notFollowedBy (try $ string "//") *> manyTill anyChar (lookAhead (try queryEnd)) <?> "query"+-- Characters legal in an (unglobbed) host label+hostChar = alphaNum <|> oneOf ".-" - filterProtoMasks :: [String] -> String -> Char -> [String]- filterProtoMasks masks chars nextChar = mapMaybe filterProtoMask masks- where filterProtoMask mask = if nextChar /= '*'- then if chars `isSuffixOf` mask- then Just ""- else Nothing- else let tailFound = find (chars `isPrefixOf`) (tails mask)- in drop (length chars) <$> tailFound+-- Recognized URL schemes, longest/most-specific match preferred by callers+protocols :: [String]+protocols = ["https://", "http://"]++-- Separator between alternative continuations tracked while parsing 'proto'+protocolsSeparator :: String+protocolsSeparator = ";"++-- Characters that can appear inside one of 'protocols' (minus the slash,+-- which is handled separately via 'hostSeparators')+protocolChar = oneOf (delete '/' $ nub $ join protocols)++-- If 'host' is empty but 'path' actually starts with a+-- [.]domain[:port]/ prefix, that domain was mis-captured as path text+-- by the main grammar+repairUnparsedHost :: String -> String -> (String, String)+repairUnparsedHost "" path+ | Just (hostPrefix, rest) <- unparsedHostPrefix path = (hostPrefix, rest)+repairUnparsedHost host path = (host, path)++-- Detects a domain[:port]/ prefix (optionally preceded by a single+-- leading . or /) at the start of a path string, and if found,+-- splits it into the domain/port prefix and the remaining path+-- (still starting with /)+unparsedHostPrefix :: String -> Maybe (String, String)+unparsedHostPrefix path = case break (== '/') afterLead of+ (candidate, rest@('/' : _)) | isHostCandidate candidate -> Just (leadPrefix ++ candidate, rest)+ _ -> Nothing+ where+ (leadPrefix, afterLead) = case path of+ ('.' : rest') -> (".", rest')+ _ -> ("", path)+ -- leading '/' means a genuine path rule+ isHostCandidate candidate = case break (== ':') candidate of+ (domainPart, ':' : portDigits) ->+ not (null portDigits)+ && all (\c -> isDigit c || c == '*') portDigits+ && (null domainPart || isPlainDomain domainPart) -- empty domain + port is a valid host (e.g. :443)+ (domainPart, "") -> isPlainDomain domainPart -- no port: still a host if it's a plain multi-label domain+ _ -> False+ isPlainDomain domainPart =+ all (\c -> isAlphaNum c || c == '-' || c == '.') domainPart+ && length (filter (not . null) (split "." domainPart)) >= 2++-- Finds the unescaped / that closes a leading /regex/ body, per+-- AdGuard hosts-blocklist syntax, returning the regex body and whatever+-- follows the closing slash (e.g. $modifiers), if any+splitClosingSlash :: String -> Maybe (String, String)+splitClosingSlash ('/' : rest) = go rest ""+ where+ go [] _ = Nothing+ go ('\\' : c : cs) acc = go cs (c : '\\' : acc)+ go ('/' : cs) acc = Just (reverse acc, cs)+ go (c : cs) acc = go cs (c : acc)+splitClosingSlash _ = Nothing++-- Classifies a raw line before any bind/proto/host/path grammar runs+classifyLine :: Pattern -> RuleShape+classifyLine pattern+ -- ##, ##+js(...) etc. is a cosmetic/scriptlet rule, not a network rule+ | "##" `isInfixOf` pattern = Cosmetic+ -- /regex/ delimiters must be found on the RAW line, before any+ -- modifier-stripping: a $ anchor inside the regex body (e.g.+ -- /^example\.com$/) is otherwise indistinguishable from a real+ -- \$modifiers separator and gets sliced off along with the closing+ -- slash, corrupting the body. Only what follows the true closing+ -- slash are modifiers, so splitModifiers is applied there, not first+ | not ("|" `isPrefixOf` pattern),+ Just (body, rest) <- splitClosingSlash pattern,+ not (null body),+ rest == "" || "$" `isPrefixOf` rest =+ BareRegex body rest+ -- structured rules have no slash-delimited body to protect, so+ -- \$modifiers can be stripped directly here+ | otherwise = Structured (fst (splitModifiers pattern))++-- Finds the unescaped $ starting a $modifiers suffix+splitModifiers :: String -> (String, String)+splitModifiers = go ""+ where+ go acc [] = (reverse acc, "")+ go acc ('\\' : c : cs) = go (c : '\\' : acc) cs+ go acc ('$' : cs) = (reverse acc, '$' : cs)+ go acc (c : cs) = go (c : acc) cs++-- Turns one raw parsed (bindStart, proto, host, path, bindEnd) tuple+-- into zero, one, or two UrlPattern's+postfilter :: UrlPattern -> [UrlPattern]+postfilter url@(UrlPattern bs proto rawHost rawPath be _) = regular+ where+ -- host text can get swallowed into path when nothing forces+ -- host parsing (see host/urlParts); heuristically recovered here+ -- when a domain[:port]/ prefix makes the intent unambiguous+ (host, repairedPath) = repairUnparsedHost rawHost rawPath+ -- A lone trailing '^' is just the end-of-host separator+ path = if repairedPath == "^" then "" else repairedPath++ -- bare /regex/ lines are classified and built by classifyLine before+ -- parseUrl ever runs urlParts, so that shape can't reach this function+ regular =+ let leftBound = bs /= None || proto /= ""+ rightBound = be /= None || path /= ""+ orphanPath = leftBound && host == "" && path /= "" && not ("*" `isPrefixOf` path)+ duplicateHostStar = host == "*"+ -- Do not block tld hosts, i.e. reject tld-only here; n.b. independent of leftBound / rightBound to avoid partially-anchored TLD-only hosts+ hostLabels = filter (\l -> l /= "" && l /= "*") (split "." host)+ -- trailing . (any-tld) or an explicit * mean "prefix", not a bare TLD; don't reject those+ tldOnlyHost =+ host /= ""+ && length hostLabels < 2+ && '*' `notElem` host+ && not ("." `isSuffixOf` host)+ && not ("-" `isSuffixOf` host)+ -- An unanchored .domain.tld/path (no | / proto forcing host+ -- parsing) is the Adblock convention for "this domain and any+ -- subdomain"; the leading . is the signal. When cases also+ -- produced a sibling that actually captured the domain as host,+ -- this "no host at all" reading is a spurious duplicate of it+ leadingDotHost = case break (`elem` hostSeparators) path of+ (candidate@('.' : _), _ : _) ->+ let labels = filter (not . null) (split "." candidate)+ in length labels >= 2+ && all (all (\c -> isAlphaNum c || c == '-')) labels+ _ -> False+ unanchoredDottedHost = host == "" && leadingDotHost+ in if not (orphanPath || tldOnlyHost || unanchoredDottedHost)+ then+ let path' = if "*" `isSuffixOf` host && path /= "" then '*' : path else path+ in [url {_host = host, _path = path'}]+ else []++-- Combines a leading bind, the parsed (proto, host, path) cases, and a+-- trailing bind into the list of raw UrlPattern's for a line+makeUrls :: SideBind -> [(String, String, String)] -> SideBind -> [UrlPattern]+makeUrls start mid end = (makeUrl start <$> mid) <*> pure end++-- Builds a single raw (pre-postfilter) UrlPattern from one parsed case+makeUrl :: SideBind -> (String, String, String) -> SideBind -> UrlPattern+makeUrl start (proto, host, path) end = UrlPattern start proto (trimTrailingNul host) path end False++-- The core proto/host/path grammar. Each of proto/host/path is+-- individually optional-ish (see the parsers below); host in+-- particular must be able to match nothing at all, or a bare-path+-- pattern (a plain /path rule, or a bare /regex/ rule with no+-- domain) fails to produce any case here at all, and the whole line is+-- silently dropped rather than emitted or erroring+urlParts :: [StringStateParser (String, String, String)]+urlParts = square3 proto (manyCases host) (oneCase path)+ where+ proto :: StringStateParser String+ proto = do+ masksString <- get+ case masksString of+ Nothing ->+ do+ put $ Just $ intercalate protocolsSeparator protocols+ return "" -- allow to skip proto+ Just masksString' ->+ do+ let masks = split protocolsSeparator masksString'+ if null masks+ then lift pzero -- no continuations available (parser have finished on previous iteration)+ else do+ lift $ skipMany $ char '*' -- skip leading * if presented+ name <- lift $ many1 protocolChar+ sep <- lift $ many $ oneOf hostSeparators+ let chars = name ++ replace "^" "//" sep -- concatenate input and expand separator wildcard+ nextChar <- lift $ lookAhead anyChar+ let masks' = filterProtoMasks masks chars nextChar -- find possible continuations for current input+ if null masks' || null chars+ then lift pzero -- fail parser if no continuations or no chars read+ else do+ put+ $ Just+ $ if isJust (find null masks') -- if empty continuation found (i.e. parser finished)+ then "" -- make no continuations available next time+ else intercalate protocolsSeparator masks'+ return $ if nextChar == '*' then chars ++ "*" else chars+ -- N.b. no domain for rules like /regex/, /path+ -- '*' is an ordinary host-glob char, not a terminator: it can be+ -- followed by more literal host labels (test*.example.com is one host)+ host =+ try ((++) <$> many1 (hostChar <|> char '*') <*> option "" (try portSuffix) <* lookAhead separator)+ <|>+ -- bare :port with no domain label, e.g. :443/path+ try (portSuffix <* lookAhead separator) <?> "host"++ separator = (oneOf hostSeparators <|> patternEnd) <?> "separator"+ path = notFollowedBy (try $ string "//") *> manyTill anyChar (lookAhead (try patternEnd)) <?> "path"++ filterProtoMasks :: [String] -> String -> Char -> [String]+ filterProtoMasks masks chars nextChar = mapMaybe filterProtoMask masks+ where+ filterProtoMask mask =+ if nextChar /= '*'+ then+ if chars `isSuffixOf` mask+ then Just ""+ else Nothing+ else+ let tailFound = find (chars `isPrefixOf`) (tails mask)+ in drop (length chars) <$> tailFound++-- Parses one line into its component UrlPattern's+parseUrl :: Pattern -> Either ParseError [UrlPattern]+parseUrl pattern = case classifyLine pattern of+ Cosmetic -> Right []+ BareRegex body _ -> Right [UrlPattern None "" "" body None True]+ Structured body -> parse (nub . join <$> (fmap . fmap) postfilter raw) "url" body -- collapse identical cases+ where+ raw = makeUrls <$> bindStart <*> cases urlParts <*> bindEnd
src/PolicyTree.hs view
@@ -1,106 +1,129 @@ {-# LANGUAGE StrictData #-} -module PolicyTree (-NodePolicy (..),-DomainTree (..),-PolicyTree,-restrictionsTree,-mergeTrees,-mergePolicyTrees,-trimTree,-mergeAndTrim,-erasePolicy+module PolicyTree+ ( NodePolicy (..),+ DomainTree (..),+ PolicyTree,+ restrictionsTree,+ mergeTrees,+ mergePolicyTrees,+ trimTree,+ erasePolicy,+ domainTree,+ )+where -,domainTree-) where---import Control.Applicative-import InputParser hiding (Policy(..))-import Data.String.Utils (split)+-- import Control.Applicative++import Data.List (filter)+import InputParser hiding (Policy (..)) import Utils data NodePolicy = None | Block | Unblock deriving (Eq, Show)-data DomainTree a = Node { _name :: String, _value :: a, _children :: [DomainTree a] }++data DomainTree a = Node {_name :: String, _value :: a, _children :: [DomainTree a]}+ type PolicyTree = DomainTree NodePolicy -showTree :: Show a => Int -> DomainTree a -> String-showTree lvl (Node name value children)- = concat $- [replicate (lvl * 2) ' ', "\"", name, "\" - ", show value]- ++ (('\n':) . showTree (lvl + 1) <$> children)+showTree :: (Show a) => Int -> DomainTree a -> String+showTree lvl (Node name value children) =+ concat $+ [replicate (lvl * 2) ' ', "\"", name, "\" - ", show value]+ ++ (('\n' :) . showTree (lvl + 1) <$> children) -instance Show a => Show (DomainTree a) where- show = showTree 0+instance (Show a) => Show (DomainTree a) where+ show = showTree 0 +-- Check against TLDs+isValidDomain :: Domain -> Bool+isValidDomain domain = length meaningfulLabels >= 2+ where+ labels = split "." domain+ meaningfulLabels = filter isMeaningful labels+ isMeaningful label = label /= "" && label /= "*"++-- Filter out invalid domains from a list+filterValidDomains :: [Domain] -> [Domain]+filterValidDomains = filter isValidDomain++-- Filter out invalid domains from Restrictions+filterValidRestrictions :: Restrictions Domain -> Restrictions Domain+filterValidRestrictions (Restrictions positive negative) =+ Restrictions (filterValidDomains <$> positive) (filterValidDomains negative)+ restrictionsTree :: NodePolicy -> Restrictions Domain -> Maybe PolicyTree-restrictionsTree positivePolicy (Restrictions p n) = trimTree positivePolicy <$> mergedTree- where+restrictionsTree positivePolicy restrictions = trimTree positivePolicy <$> mergedTree+ where+ -- Filter out bare TLDs and invalid domains+ Restrictions p n = filterValidRestrictions restrictions negativePolicy = case positivePolicy of- Block -> Unblock- _ -> Block+ Block -> Unblock+ _ -> Block positiveTree = case p of- Nothing -> Just $ Node "" positivePolicy []- Just p' -> concatTrees positivePolicy $ domainTree positivePolicy <$> p'- negativeTree = concatTrees negativePolicy $ domainTree negativePolicy <$> n+ Nothing -> Just $ Node "" positivePolicy []+ Just [] -> Nothing -- All domains were filtered out+ Just p' -> concatTrees positivePolicy $ domainTree positivePolicy <$> p'+ negativeTree = case n of+ [] -> Nothing+ n' -> concatTrees negativePolicy $ domainTree negativePolicy <$> n' mergedTree = case negativeTree of- Nothing -> positiveTree- Just negativeTree' -> mergePolicyTrees negativePolicy negativeTree' <$> positiveTree+ Nothing -> positiveTree+ Just negativeTree' -> mergePolicyTrees negativePolicy negativeTree' <$> positiveTree erasePolicy :: NodePolicy -> PolicyTree -> PolicyTree erasePolicy policy (Node n p c) = Node n policy' (erasePolicy policy <$> c)- where policy'- | p == policy = None- | otherwise = p+ where+ policy'+ | p == policy = None+ | otherwise = p domainTree :: NodePolicy -> Domain -> PolicyTree-domainTree policy domain = makeTree policy $ ("":) $ reverse $ split "." domain+domainTree policy domain+ | not (isValidDomain domain) = error $ "Invalid domain (TLD-only or insufficient labels): " ++ domain+ | otherwise = makeTree policy $ ("" :) $ reverse $ split "." domain makeTree :: NodePolicy -> [String] -> PolicyTree makeTree _ [] = error "No nodes proviced" makeTree policy [node] = Node node policy []-makeTree policy (node:nodes) = Node node None [makeTree policy nodes]--mergeAndTrim :: NodePolicy -> PolicyTree -> PolicyTree -> PolicyTree-mergeAndTrim trump = trimTree trump .*. mergePolicyTrees trump+makeTree policy (node : nodes) = Node node None [makeTree policy nodes] concatTrees :: NodePolicy -> [PolicyTree] -> Maybe PolicyTree concatTrees _ [] = Nothing-concatTrees _ [tree] = Just tree-concatTrees trump (tree:trees) = mergePolicyTrees trump tree <$> concatTrees trump trees+concatTrees trump trees = Just $ mergeBalanced (mergePolicyTrees trump) trees mergePolicyTrees :: NodePolicy -> PolicyTree -> PolicyTree -> PolicyTree mergePolicyTrees trump = mergeTrees mergePolicy- where+ where mergePolicy policy1 policy2- | policy1 == None = policy2- | policy2 == None = policy1- | policy1 == trump = policy1- | otherwise = policy2+ | policy1 == None = policy2+ | policy2 == None = policy1+ | policy1 == trump = policy1+ | otherwise = policy2 mergeTrees :: (a -> b -> b) -> DomainTree a -> DomainTree b -> DomainTree b-mergeTrees mergeValue t1@(Node name1 value1 children1) t2@(Node name2 value2 children2)- = Node mergeName (mergeValue value1 value2) (mergeChildren children1 children2)- where- -- names expected to be equal and/or empty- mergeName- | name1 == "" = name2- | otherwise = name1-- t1Default = t1{_name = "", _children = []}- t2Default = t2{_name = "", _children = []}+mergeTrees mergeValue t1@(Node name1 value1 children1) t2@(Node name2 value2 children2) =+ Node mergeName (mergeValue value1 value2) (mergeChildren children1 children2)+ where+ -- names expected to be equal and/or empty+ mergeName+ | name1 == "" = name2+ | otherwise = name1 - mergeChildren [] [] = []- mergeChildren (t1Child:t1Children') [] = mergeTrees mergeValue t1Child t2Default : mergeChildren t1Children' []- mergeChildren [] (t2Child:t2Children') = mergeTrees mergeValue t1Default t2Child : mergeChildren [] t2Children'- mergeChildren t1Children@(t1Child:t1Children') t2Children@(t2Child:t2Children')- | _name t1Child == _name t2Child = mergeTrees mergeValue t1Child t2Child : mergeChildren t1Children' t2Children'- | _name t1Child > _name t2Child = mergeTrees mergeValue t1Child t2Default : mergeChildren t1Children' t2Children- | otherwise = mergeTrees mergeValue t1Default t2Child : mergeChildren t1Children t2Children'+ t1Default = t1 {_name = "", _children = []}+ t2Default = t2 {_name = "", _children = []} + mergeChildren [] [] = []+ mergeChildren (t1Child : t1Children') [] = mergeTrees mergeValue t1Child t2Default : mergeChildren t1Children' []+ mergeChildren [] (t2Child : t2Children') = mergeTrees mergeValue t1Default t2Child : mergeChildren [] t2Children'+ mergeChildren t1Children@(t1Child : t1Children') t2Children@(t2Child : t2Children')+ | _name t1Child == _name t2Child = mergeTrees mergeValue t1Child t2Child : mergeChildren t1Children' t2Children'+ | _name t1Child > _name t2Child = mergeTrees mergeValue t1Child t2Default : mergeChildren t1Children' t2Children+ | otherwise = mergeTrees mergeValue t1Default t2Child : mergeChildren t1Children t2Children' trimTree :: NodePolicy -> PolicyTree -> PolicyTree trimTree trump (Node name policy children) = Node name policy childrenFiltered- where- childrenFiltered = filter (not.redundantChild) childrenTrimmed+ where+ childrenFiltered = filter (not . redundantChild) childrenTrimmed childrenTrimmed = trimTree trump <$> children redundantChild (Node _ childPolicy childChildren) = samePolicy childPolicy && null childChildren samePolicy childPolicy = childPolicy == policy || (policy == None && childPolicy /= trump)
− src/PopupBlocker.hs
@@ -1,1 +0,0 @@-module PopupBlocker where
src/ProgramOptions.hs view
@@ -1,110 +1,138 @@ {-# LANGUAGE StrictData #-} module ProgramOptions-(-Options(..),-DebugLevel(DebugLevel),-fillFromLog,-parseOptions,-logOptions,-writeError,-versionText-) where-import Paths_adblock2privoxy (version)-import Control.Monad.State+ ( Options (..),+ DebugLevel (DebugLevel),+ fillFromLog,+ parseOptions,+ logOptions,+ writeError,+ versionText,+ )+where+ import Control.Applicative hiding (many)-import Text.ParserCombinators.Parsec hiding ((<|>),State,Line)-import System.Console.GetOpt-import System.FilePath ( (</>) )+import Control.Monad.State import Data.Version (showVersion)-+import Paths_adblock2privoxy (version)+import System.Console.GetOpt+import System.FilePath ((</>))+import Text.ParserCombinators.Parsec hiding (Line, State, (<|>)) newtype DebugLevel = DebugLevel Int deriving (Enum, Eq, Ord, Show) readDebugLevel :: String -> DebugLevel-readDebugLevel x = fst $ parseDebugLevel (reads x :: [(Int, String)]) where- parseDebugLevel :: [(Int, String)] -> (DebugLevel, IO ())- parseDebugLevel y = case y of- [(dl,"")] -> (DebugLevel dl, return ())- _ -> (DebugLevel 0, writeError "Debug level must be an integer.\n")+readDebugLevel x = fst $ parseDebugLevel (reads x :: [(Int, String)])+ where+ parseDebugLevel :: [(Int, String)] -> (DebugLevel, IO ())+ parseDebugLevel y = case y of+ [(dl, "")] -> (DebugLevel dl, return ())+ _ -> (DebugLevel 0, writeError "Debug level must be an integer.\n") data Options = Options- { _showVersion :: Bool- , _privoxyDir :: FilePath- , _webDir :: FilePath- , _taskFile :: FilePath- , _cssDomain :: String- , _useHTTP :: Bool- , _debugLevel :: DebugLevel- , _forced :: Bool- }+ { _showVersion :: Bool,+ _privoxyDir :: FilePath,+ _webDir :: FilePath,+ _taskFile :: FilePath,+ _cssDomain :: String,+ _useHTTP :: Bool,+ _debugLevel :: DebugLevel,+ _forced :: Bool+ } options :: [OptDescr (Options -> Options)] options =- [ Option "v" ["version"]- (NoArg (\ opts -> opts { _showVersion = True }))- "Show version number"- , Option "p" ["privoxyDir"]- (ReqArg (\ f opts -> opts { _privoxyDir = f })- "PATH")- "Privoxy config output path"- , Option "w" ["webDir"]- (ReqArg (\ f opts -> opts { _webDir = f })- "PATH")- "Css files output path (optional, privoxyDir is used by default)"- , Option "d" ["domainCSS"]- (ReqArg (\ d opts -> opts { _cssDomain = d })- "DOMAIN")- "Domain of CSS web server (required for Element Hide functionality)"- , Option "u" ["useHTTP"]- (NoArg (\ opts -> opts { _useHTTP = True }))- "Use HTTP for CSS web server; the default is HTTPS to avoid mixed content"- , Option "g" ["debugLevel"]- (ReqArg (\ dL opts -> opts { _debugLevel = readDebugLevel dL })- "INT")- "Debug Level. 0: Off; 1: top directory CSS; 2: full directory."- , Option "t" ["taskFile"]- (ReqArg (\ f opts -> opts { _taskFile = f })- "PATH")- "Path to task file containing urls to process and options. privoxyDir, webDir and domainCSS values are taken from this file if not specified explicitly"- , Option "f" ["forced"]- (NoArg (\ opts -> opts { _forced = True }))- "Run even if no sources are expired"- ]+ [ Option+ "v"+ ["version"]+ (NoArg (\opts -> opts {_showVersion = True}))+ "Show version number",+ Option+ "p"+ ["privoxyDir"]+ ( ReqArg+ (\f opts -> opts {_privoxyDir = f})+ "PATH"+ )+ "Privoxy config output path",+ Option+ "w"+ ["webDir"]+ ( ReqArg+ (\f opts -> opts {_webDir = f})+ "PATH"+ )+ "Css files output path (optional, privoxyDir is used by default)",+ Option+ "d"+ ["domainCSS"]+ ( ReqArg+ (\d opts -> opts {_cssDomain = d})+ "DOMAIN"+ )+ "Domain of CSS web server (required for Element Hide functionality)",+ Option+ "u"+ ["useHTTP"]+ (NoArg (\opts -> opts {_useHTTP = True}))+ "Use HTTP for CSS web server; the default is HTTPS to avoid mixed content",+ Option+ "g"+ ["debugLevel"]+ ( ReqArg+ (\dL opts -> opts {_debugLevel = readDebugLevel dL})+ "INT"+ )+ "Debug Level. 0: Off; 1: top directory CSS; 2: full directory.",+ Option+ "t"+ ["taskFile"]+ ( ReqArg+ (\f opts -> opts {_taskFile = f})+ "PATH"+ )+ "Path to task file containing urls to process and options. privoxyDir, webDir and domainCSS values are taken from this file if not specified explicitly",+ Option+ "f"+ ["forced"]+ (NoArg (\opts -> opts {_forced = True}))+ "Run even if no sources are expired"+ ] parseOptions :: [String] -> IO (Options, [String]) parseOptions argv =- case getOpt Permute options argv of- (opts,nonOpts,[] ) ->- case foldr id emptyOptions opts of- Options False "" _ "" _ _ _ _ -> writeError "Privoxy dir or task file should be specified.\n"- opts'@Options{_showVersion = True} -> return (opts', nonOpts)- opts' -> return (setDefaults opts', nonOpts)- (_,_,errs) -> writeError $ concat errs- where- setDefaults opts@(Options _ privoxyDir@(_:_) "" _ _ _ _ _) = setDefaults opts{ _webDir = privoxyDir }- setDefaults opts@(Options _ privoxyDir _ "" _ _ _ _) = setDefaults opts{ _taskFile = privoxyDir </> "ab2p.task" }- setDefaults opts = opts+ case getOpt Permute options argv of+ (opts, nonOpts, []) ->+ case foldr id emptyOptions opts of+ Options False "" _ "" _ _ _ _ -> writeError "Privoxy dir or task file should be specified.\n"+ opts'@Options {_showVersion = True} -> return (opts', nonOpts)+ opts' -> return (setDefaults opts', nonOpts)+ (_, _, errs) -> writeError $ concat errs+ where+ setDefaults opts@(Options _ privoxyDir@(_ : _) "" _ _ _ _ _) = setDefaults opts {_webDir = privoxyDir}+ setDefaults opts@(Options _ privoxyDir _ "" _ _ _ _) = setDefaults opts {_taskFile = privoxyDir </> "ab2p.task"}+ setDefaults opts = opts versionText :: String versionText = "adblock2privoxy version " ++ showVersion version writeError :: String -> IO a writeError msg = ioError $ userError $ msg ++ "\n" ++ usageInfo header options- where- header = versionText ++- "\nSee home page for more details and updates: https://github.com/essandess/adblock2privoxy\n" ++- "Usage: adblock2privoxy [OPTION...] [URL...]"-+ where+ header =+ versionText+ ++ "\nSee home page for more details and updates: https://github.com/essandess/adblock2privoxy\n"+ ++ "Usage: adblock2privoxy [OPTION...] [URL...]" logOptions :: Options -> [String]-logOptions options' = [- startMark,- "Privoxy path: " ++ _privoxyDir options',- "Web path: " ++ _webDir options',- "CSS web server domain: " ++ _cssDomain options',- endMark,- ""]+logOptions options' =+ [ startMark,+ "Privoxy path: " ++ _privoxyDir options',+ "Web path: " ++ _webDir options',+ "CSS web server domain: " ++ _cssDomain options',+ endMark,+ ""+ ] startMark :: String startMark = "----- options -----"@@ -115,24 +143,23 @@ emptyOptions :: Options emptyOptions = Options False "" "" "" "" False (DebugLevel 0) False - fillFromLog :: Options -> [String] -> Options fillFromLog existing lns = execState (mapM parseLogOptions lns') existing- where- lns' = filter (not.null) $ takeWhile (/= endMark).dropWhile (/= startMark) $ lns+ where+ lns' = filter (not . null) $ takeWhile (/= endMark) . dropWhile (/= startMark) $ lns parseLogOptions :: String -> State Options () parseLogOptions text = do- info <- get- let- ifEmpty getter x =- let oldValue = getter info in- if null oldValue then x else oldValue- privoxyPathParser = (\x -> info{_privoxyDir = ifEmpty _privoxyDir x}) <$> (string "Privoxy path: " *> many1 anyChar)- webPathParser = (\x -> info{_webDir = ifEmpty _webDir x}) <$> (string "Web path: " *> many1 anyChar)- cssDomainParser = (\x -> info{_cssDomain = ifEmpty _cssDomain x}) <$> (string "CSS web server domain: " *> many1 anyChar)- stringParser = skipMany (char ' ') *>- (try privoxyPathParser <|> try webPathParser <|> cssDomainParser)- case parse stringParser "" text of- Left _ -> return ()- Right info' -> put info'+ info <- get+ let ifEmpty getter x =+ let oldValue = getter info+ in if null oldValue then x else oldValue+ privoxyPathParser = (\x -> info {_privoxyDir = ifEmpty _privoxyDir x}) <$> (string "Privoxy path: " *> many1 anyChar)+ webPathParser = (\x -> info {_webDir = ifEmpty _webDir x}) <$> (string "Web path: " *> many1 anyChar)+ cssDomainParser = (\x -> info {_cssDomain = ifEmpty _cssDomain x}) <$> (string "CSS web server domain: " *> many1 anyChar)+ stringParser =+ skipMany (char ' ')+ *> (try privoxyPathParser <|> try webPathParser <|> cssDomainParser)+ case parse stringParser "" text of+ Left _ -> return ()+ Right info' -> put info'
src/SourceInfo.hs view
@@ -2,32 +2,38 @@ {-# LANGUAGE StrictData #-} module SourceInfo-(-SourceInfo(_url),-showInfo,-updateInfo,-makeInfo,-readLogInfos,-infoExpired-) where-import InputParser-import Control.Monad.State+ ( SourceInfo (_url),+ showInfo,+ updateInfo,+ makeInfo,+ readLogInfos,+ infoExpired,+ )+where+ import Control.Applicative hiding (many)-import Text.ParserCombinators.Parsec hiding ((<|>),State,Line)+import Control.Monad.State import Data.List-import Data.Time.Clock+-- import System.Locale++import Data.Maybe (catMaybes) import Data.Time.Calendar---import System.Locale+import Data.Time.Clock import Data.Time.Format-import Data.Maybe (catMaybes)-import Data.String.Utils (split)-+import InputParser+import Text.ParserCombinators.Parsec hiding (Line, State, (<|>))+import Utils (split) -data SourceInfo = SourceInfo { _title, _url, _license, _homepage :: String,- _lastUpdated :: UTCTime, _expires, _version :: Integer, _expired :: Bool }+data SourceInfo = SourceInfo+ { _title, _url, _license, _homepage :: String,+ _lastUpdated :: UTCTime,+ _expires :: Integer,+ _version :: String,+ _expired :: Bool+ } emptySourceInfo :: SourceInfo-emptySourceInfo = SourceInfo "" "" "" "" (UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0) ) 72 0 True+emptySourceInfo = SourceInfo "" "" "" "" (UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0)) 72 "" True separator :: String separator = "----- source -----"@@ -40,39 +46,43 @@ showInfoItem :: SourceInfo -> [String] showInfoItem sourceInfo@(SourceInfo _ url _ _ lastUpdated expires _ expired) =- catMaybes [ Just separator,- optionalLine "Title: " _title,- Just $ "Url: " ++ url,- Just $ "Last modified: " ++ formatTime defaultTimeLocale "%d %b %Y %H:%M %Z" lastUpdated,- Just $ concat ["Expires: ", show expires, " hours", expiredMark],- optionalLine "Version: " $ show . _version,- optionalLine "License: " _license,- optionalLine "Homepage: " _homepage ]- where- expiredMark | expired = " (expired)"- | otherwise = ""- optionalLine caption getter | getter sourceInfo == getter emptySourceInfo = Nothing- | otherwise = Just $ caption ++ getter sourceInfo+ catMaybes+ [ Just separator,+ optionalLine "Title: " _title,+ Just $ "Url: " ++ url,+ Just $ "Last modified: " ++ formatTime defaultTimeLocale "%d %b %Y %H:%M %Z" lastUpdated,+ Just $ concat ["Expires: ", show expires, " hours", expiredMark],+ optionalLine "Version: " _version,+ optionalLine "License: " _license,+ optionalLine "Homepage: " _homepage+ ]+ where+ expiredMark+ | expired = " (expired)"+ | otherwise = ""+ optionalLine caption getter+ | getter sourceInfo == getter emptySourceInfo = Nothing+ | otherwise = Just $ caption ++ getter sourceInfo updateInfo :: UTCTime -> [Line] -> SourceInfo -> SourceInfo-updateInfo now lns old- = updated { _expired = infoExpired now updated }- where- initial = old { _lastUpdated = now }+updateInfo now lns old =+ updated {_expired = infoExpired now updated}+ where+ initial = old {_lastUpdated = now} updated = execState (mapM (parseInfo . lineComment) (take 50 lns)) initial makeInfo :: String -> SourceInfo-makeInfo url = emptySourceInfo { _url = url }+makeInfo url = emptySourceInfo {_url = url} readLogInfos :: [String] -> [SourceInfo] readLogInfos lns = chunkInfo <$> chunks- where- chunks = filter (not.null) . split [separator] . takeWhile (/= endMark) $ lns- chunkInfo chunk = execState (mapM parseInfo chunk) emptySourceInfo+ where+ chunks = filter (not . null) . split [separator] . takeWhile (/= endMark) $ lns+ chunkInfo chunk = execState (mapM parseInfo chunk) emptySourceInfo infoExpired :: UTCTime -> SourceInfo -> Bool-infoExpired now (SourceInfo _ _ _ _ lastUpdated expires _ _ ) =- diffUTCTime now lastUpdated > fromInteger (expires * 60 * 60)+infoExpired now (SourceInfo _ _ _ _ lastUpdated expires _ _) =+ diffUTCTime now lastUpdated > fromInteger (expires * 60 * 60) lineComment :: Line -> String lineComment (Line _ (Comment text)) = text@@ -80,25 +90,40 @@ parseInfo :: String -> State SourceInfo () parseInfo text = do- info <- get- let urlParser = (\x -> info{_url = x}) <$> ((string "Url: " <|> string "Redirect: ") *> many1 anyChar)- titleParser = (\x -> info{_title = x}) <$> (string "Title: " *> many1 anyChar)- homepageParser = (\x -> info{_homepage = x}) <$> (string "Homepage: " *> many1 anyChar)- lastUpdatedParser = (\case- Just time -> info {_lastUpdated = time}- Nothing -> info)- . parseTimeM True defaultTimeLocale "%d %b %Y %H:%M %Z"- <$> (string "Last modified: " *> many1 anyChar)- licenseParser = (\x -> info{_license = x})- <$> ((string "Licen" <|> string "Лицензия") *> manyTill anyChar (char ':')- *> skipMany (char ' ') *> many1 anyChar)- expiresParser = (\n unit -> info{_expires = unit * read n})- <$> (string "Expires: " *> many1 digit) <*> (24 <$ string " days" <|> 1 <$ string " hours")- versionnumber = intercalate "." <$> many1 digit `sepBy` char '.'- versionParser = (\x -> info{_version = read x}) <$> (string "Version: " *> versionnumber)- stringParser = skipMany (char ' ') *>- (try urlParser <|> try titleParser <|> try expiresParser <|> try versionParser- <|> try licenseParser <|> try homepageParser <|> try lastUpdatedParser)- case parse stringParser "" text of- Left _ -> return ()- Right info' -> put info'+ info <- get+ let urlParser = (\x -> info {_url = x}) <$> ((string "Url: " <|> string "Redirect: ") *> many1 anyChar)+ titleParser = (\x -> info {_title = x}) <$> (string "Title: " *> many1 anyChar)+ homepageParser = (\x -> info {_homepage = x}) <$> (string "Homepage: " *> many1 anyChar)+ lastUpdatedParser =+ ( \case+ Just time -> info {_lastUpdated = time}+ Nothing -> info+ )+ . parseTimeM True defaultTimeLocale "%d %b %Y %H:%M %Z"+ <$> (string "Last modified: " *> many1 anyChar)+ licenseParser =+ (\x -> info {_license = x})+ <$> ( (string "Licen" <|> string "Лицензия")+ *> manyTill anyChar (char ':')+ *> skipMany (char ' ')+ *> many1 anyChar+ )+ expiresParser =+ (\n unit -> info {_expires = unit * read n})+ <$> (string "Expires: " *> many1 digit)+ <*> (24 <$ string " days" <|> 1 <$ string " hours")+ versionnumber = intercalate "." <$> many1 digit `sepBy` char '.'+ versionParser = (\x -> info {_version = x}) <$> (string "Version: " *> versionnumber)+ stringParser =+ skipMany (char ' ')+ *> ( try urlParser+ <|> try titleParser+ <|> try expiresParser+ <|> try versionParser+ <|> try licenseParser+ <|> try homepageParser+ <|> try lastUpdatedParser+ )+ case parse stringParser "" text of+ Left _ -> return ()+ Right info' -> put info'
src/Statistics.hs view
@@ -1,37 +1,39 @@-module Statistics (- collectStat-)where-import qualified Data.Map as Map-import InputParser-import Data.Maybe+module Statistics+ ( collectStat,+ )+where+ import Control.Monad import Control.Monad.State+import Data.List (foldl')+import qualified Data.Map.Strict as Map+import Data.Maybe+import InputParser type Stat = Map.Map String Int collectStat :: [Line] -> [String]-collectStat = fmap resultLine . Map.toAscList . foldr getStat Map.empty- where- resultLine (name, value) = concat [name, ": ", show value]+collectStat = fmap resultLine . Map.toAscList . foldl' (flip getStat) Map.empty+ where+ resultLine (name, value) = concat [name, ": ", show value] -increment :: String -> Stat-> Stat+increment :: String -> Stat -> Stat increment key = Map.insertWith (+) key 1 isJustFilled :: Maybe [a] -> Bool isJustFilled Nothing = False-isJustFilled (Just list) = not.null $ list-+isJustFilled (Just list) = not . null $ list -getStat :: Line -> Stat-> Stat-getStat (Line _ Comment {} ) = increment "Comments"-getStat (Line _ Error {}) = increment "Errors"-getStat (Line _ ElementHide {}) = increment "Elements hiding rules"-getStat (Line _ (RequestBlock policy _ (RequestOptions _ thirdParty domains _ _ _ _ _))) = execState stateState- where+getStat :: Line -> Stat -> Stat+getStat (Line _ Comment {}) = increment "Comments"+getStat (Line _ Error {}) = increment "Errors"+getStat (Line _ ElementHide {}) = increment "Elements hiding rules"+getStat (Line _ (RequestBlock policy _ (RequestOptions _ thirdParty domains _ _ _ _ _))) = execState stateState+ where incrementState = modify . increment stateState = do- incrementState "Request block rules total"- when (policy == InputParser.Unblock) $ incrementState "Request block rules for exception"- when (isJust thirdParty) $ incrementState "Rules with third party option"- when ((not.null._negative $ domains) || (isJustFilled . _positive $ domains)) $ incrementState "Request block rules with domain option"- when ((not.null._negative $ domains) || (isJustFilled . _positive $ domains)) $ incrementState "Request block rules with request type options"+ incrementState "Request block rules total"+ when (policy == InputParser.Unblock) $ incrementState "Request block rules for exception"+ when (isJust thirdParty) $ incrementState "Rules with third party option"+ when ((not . null . _negative $ domains) || (isJustFilled . _positive $ domains)) $ incrementState "Request block rules with domain option"+ when ((not . null . _negative $ domains) || (isJustFilled . _positive $ domains)) $ incrementState "Request block rules with request type options"
src/Task.hs view
@@ -1,20 +1,21 @@-module Task (-writeTask,-readTask-) where-import System.IO.Strict as Strict-import System.IO+module Task+ ( writeTask,+ readTask,+ )+where+ import InputParser import Statistics+import System.IO+import System.IO.Strict as Strict writeTask :: String -> [String] -> [Line] -> IO () writeTask filename info lns =- let- statistics = collectStat lns- errorLine (Line position (Error text))- = [concat ["ERROR: ", recordSourceText position, " - ", text]]- errorLine _ = []- in do+ let statistics = collectStat lns+ errorLine (Line position (Error text)) =+ [concat ["ERROR: ", recordSourceText position, " - ", text]]+ errorLine _ = []+ in do outFile <- openFile filename WriteMode mapM_ (hPutStrLn outFile) info mapM_ (hPutStrLn outFile) statistics@@ -23,5 +24,5 @@ readTask :: String -> IO [String] readTask path = do- result <- lines <$> Strict.readFile path- return $ length result `seq` result --read whole file to allow its overwriting+ result <- lines <$> Strict.readFile path+ return $ length result `seq` result -- read whole file to allow its overwriting
src/Templates.hs view
@@ -1,9 +1,10 @@ module Templates where-import {-# SOURCE #-} UrlBlocker++import Data.Foldable import Paths_adblock2privoxy import System.FilePath ((</>))-import Data.String.Utils (replace, startswith)-import Data.Foldable+import {-# SOURCE #-} UrlBlocker+import Utils (replace, startswith) blockCss, ab2pPrefix, actionsFilePrefix, filtersFilePrefix :: String blockCss = "{display:none!important;visibility:hidden!important}"@@ -13,43 +14,45 @@ terminalActionSwitch :: Bool -> BlockMethod -> String terminalActionSwitch True Request =- "+block{ adblock rules } \\\n\- \+server-header-tagger{ab2p-block-s}"+ "+block{ adblock rules } \\\n\+ \+server-header-tagger{ab2p-block-s}" terminalActionSwitch False Request =- "-block \\\n\- \-server-header-tagger{ab2p-block-s} \\\n\- \+server-header-tagger{ab2p-unblock-d} \\\n\- \+server-header-tagger{ab2p-unblock-s} \\\n\- \+client-header-tagger{ab2b-unblock-u}"+ "-block \\\n\+ \-server-header-tagger{ab2p-block-s} \\\n\+ \+server-header-tagger{ab2p-unblock-d} \\\n\+ \+server-header-tagger{ab2p-unblock-s} \\\n\+ \+client-header-tagger{ab2b-unblock-u}" terminalActionSwitch True Xframe = "+server-header-filter{ab2p-xframe-filter}" terminalActionSwitch False Xframe = "-server-header-filter{ab2p-xframe-filter}" terminalActionSwitch False Elem = "-filter{ab2p-elemhide-filter}" terminalActionSwitch True Xpopup = "+filter{ab2p-popup-filter}" terminalActionSwitch False Xpopup = "-filter{ab2p-popup-filter}" terminalActionSwitch True Dnt = "+add-header{DNT: 1}"+-- N.b. the unblock action must this specific parameter value+terminalActionSwitch False Dnt = "-add-header{DNT: 1}" terminalActionSwitch _ _ = "" cssProtocol :: Bool -> String cssProtocol useHTTP- | useHTTP = "http"- | otherwise = "https"+ | useHTTP = "http"+ | otherwise = "https" writeTemplateFiles :: String -> String -> Bool -> IO () writeTemplateFiles outDir cssDomain useHTTP = do- copySystem "ab2p.system.action"- copySystem "ab2p.system.filter"- where- filterDomain content = unlines . filter (not . null) $ filterLine <$> lns- where- lns = lines content- replace' line (from, to) = replace from to line- filterLine line- | null cssDomain && startswith "[?CSS_DOMAIN]" line = ""- | otherwise = foldl' replace' line [("[?CSS_DOMAIN]", ""), ("[CSS_DOMAIN]", cssDomain), ("[CSS_PROTOCOL]", cssProtocol useHTTP)]- -- | null cssDomain && (startswith "[?CSS_DOMAIN]" line || startswith "[?CSS_DOMAIN_DEBUG]" line) = ""- -- | otherwise = foldl' replace' line [("[?CSS_DOMAIN]", ""), ("[?CSS_DOMAIN_DEBUG]", "# "), ("[CSS_DOMAIN]", cssDomain), ("[CSS_PROTOCOL]", cssProtocol useHTTP)]+ copySystem "ab2p.system.action"+ copySystem "ab2p.system.filter"+ where+ filterDomain content = unlines . filter (not . null) $ filterLine <$> lns+ where+ lns = lines content+ replace' line (from, to) = replace from to line+ filterLine line+ | null cssDomain && startswith "[?CSS_DOMAIN]" line = ""+ | otherwise = foldl' replace' line [("[?CSS_DOMAIN]", ""), ("[CSS_DOMAIN]", cssDomain), ("[CSS_PROTOCOL]", cssProtocol useHTTP)]+ -- \| null cssDomain && (startswith "[?CSS_DOMAIN]" line || startswith "[?CSS_DOMAIN_DEBUG]" line) = ""+ -- \| otherwise = foldl' replace' line [("[?CSS_DOMAIN]", ""), ("[?CSS_DOMAIN_DEBUG]", "# "), ("[CSS_DOMAIN]", cssDomain), ("[CSS_PROTOCOL]", cssProtocol useHTTP)] - copySystem file = do- dataDir <- getDataDir- content <- readFile $ dataDir </> "templates" </> file- writeFile (outDir </> file) $ filterDomain content+ copySystem file = do+ dataDir <- getDataDir+ content <- readFile $ dataDir </> "templates" </> file+ writeFile (outDir </> file) $ filterDomain content
+ src/Test.hs view
@@ -0,0 +1,281 @@+module Main (main) where++import Control.Monad (forM_)+import Data.List (isInfixOf, isPrefixOf)+import InputParser (Line (..), Policy (..), Record (..), Restrictions (..), adblockFile)+import ParserExtTests (testParseMorse, testParsecExt)+import PatternConverter (globWildcard, hasUnsupportedPCRE, isOverbroadPattern, makePattern, maxPatternLength, parseUrl)+import PolicyTree (restrictionsTree)+import qualified PolicyTree as PT (NodePolicy (Block)) -- qualified: NodePolicy's Block would otherwise clash with Policy's Block+import System.Exit (exitFailure, exitSuccess)+import Text.ParserCombinators.Parsec (parse)+import Utils (replace, split, startswith)++data Case = Case {caseName :: String, caseOk :: Bool}++check :: String -> Bool -> Case+check = Case++cases :: [Case]+cases =+ [ check+ "replace basic"+ (replace "foo" "bar" "foobarfoo" == "barbarbar"),+ check+ "replace no match"+ (replace "xyz" "Q" "abc" == "abc"),+ check+ "split basic"+ (split "," "a,b,,c" == ["a", "b", "", "c"]),+ check+ "split no delim"+ (split "," "abc" == ["abc"]),+ check+ "startswith true"+ (startswith "foo" "foobar"),+ check+ "startswith false"+ (not (startswith "bar" "foobar")),+ check+ "parseUrl doesn't error on simple pattern"+ (either (const False) (const True) (parseUrl "||example.com^")),+ check+ "genuine second-level domain still produced (example.com)"+ (either (const False) (not . null) (parseUrl "||example.com^")),+ check+ "network pattern containing literal '#' no longer truncates (regression)"+ ( either+ (const False)+ (const True)+ (parseUrl "/\\.(gif|jpe?g|png|webp)#(\\/?.+)?(\\/(ad)s?\\/|\\/ad-)/")+ ),+ check+ "adblockFile parses minimal header"+ ( either+ (const False)+ (const True)+ (parse adblockFile "test" "[Adblock Plus 2.0]\n")+ ),+ check+ "adblockFile parses list with no header (uBlock-style)"+ ( either+ (const False)+ (const True)+ (parse adblockFile "test" "! Title: example\n||example.com^\n")+ ),+ check+ "ParsecExt cases combinator (ab/eb + letters + alnum)"+ (either (const False) (not . null) testParsecExt),+ check+ "ParsecExt morse decode of HELLO"+ (either (const False) (elem "HELLO") testParseMorse),+ check+ "parseUrl terminates on malformed bracket in path (regression)"+ (either (const False) (const True) (parseUrl "||example.com/foo[bar^")),+ check+ "host dots are literal, not PCRE-escaped (regression)"+ ( either+ (const False)+ (all (\p -> not ("\\." `isInfixOf` makePattern False p)))+ (parseUrl "||example.com^")+ ),+ check+ "bare TLD host is rejected (com)"+ (either (const False) null (parseUrl "||com^")),+ check+ "unanchored-dot TLD host is rejected (.com)"+ (either (const False) null (parseUrl "||.com^")),+ check+ "wildcard subdomain of a real domain is kept (*.example.com)"+ (either (const False) (not . null) (parseUrl "||*.example.com^")),+ -- PCRE filtering tests+ check+ "hasUnsupportedPCRE accepts a single positive lookahead (?=...)"+ (not (hasUnsupportedPCRE "foo(?=bar)baz")),+ check+ "hasUnsupportedPCRE accepts a single negative lookahead (?!...)"+ (not (hasUnsupportedPCRE "foo(?!bar)baz")),+ check+ "hasUnsupportedPCRE accepts a single positive lookbehind (?<=...)"+ (not (hasUnsupportedPCRE "foo(?<=bar)baz")),+ check+ "hasUnsupportedPCRE accepts a single negative lookbehind (?<!...)"+ (not (hasUnsupportedPCRE "foo(?<!bar)baz")),+ check+ "hasUnsupportedPCRE detects two chained lookaheads (the catastrophic-backtracking shape)"+ (hasUnsupportedPCRE "foo(?=[a-z]{0,9}1)(?=[a-z]{0,9}2)bar"),+ check+ "hasUnsupportedPCRE detects a lookahead plus a lookbehind chained together"+ (hasUnsupportedPCRE "foo(?=bar)(?<=baz)qux"),+ check+ "hasUnsupportedPCRE detects conditional (?(...))"+ (hasUnsupportedPCRE "foo(?(1)bar)baz"),+ check+ "hasUnsupportedPCRE accepts named capture (?P<name>...)"+ (not (hasUnsupportedPCRE "foo(?P<test>bar)baz")),+ check+ "hasUnsupportedPCRE accepts normal PCRE patterns"+ (not (hasUnsupportedPCRE "foo[a-z]+bar.*baz")),+ check+ "hasUnsupportedPCRE accepts character classes"+ (not (hasUnsupportedPCRE "[a-zA-Z0-9_-]+")),+ check+ "hasUnsupportedPCRE accepts quantifiers"+ (not (hasUnsupportedPCRE "foo{1,3}bar+baz*qux?")),+ check+ "hasUnsupportedPCRE accepts alternation"+ (not (hasUnsupportedPCRE "foo|bar|baz")),+ check+ "hasUnsupportedPCRE accepts anchors"+ (not (hasUnsupportedPCRE "^foo.*bar\\$")),+ check+ "hasUnsupportedPCRE accepts word boundaries"+ (not (hasUnsupportedPCRE "\\bfoo\\b")),+ check+ "hasUnsupportedPCRE accepts non-capturing groups"+ (not (hasUnsupportedPCRE "foo(?:bar|baz)qux")),+ check+ "hasUnsupportedPCRE accepts case-insensitive modifier"+ (not (hasUnsupportedPCRE "(?i)foo")),+ check+ "hasUnsupportedPCRE accepts case-sensitive modifier"+ (not (hasUnsupportedPCRE "(?-i)foo")),+ check+ "hasUnsupportedPCRE rejects a malformed pattern (unmatched bracket)"+ (hasUnsupportedPCRE "foo[bar"),+ check+ "parseUrl accepts pattern with a single positive lookahead"+ ( case parseUrl "/(?=test)/" of+ Right patterns ->+ not (null patterns)+ && all (\p -> not ("# FILTERED:" `isInfixOf` makePattern False p)) patterns+ Left _ -> False+ ),+ check+ "parseUrl accepts pattern with a single negative lookahead"+ ( case parseUrl "/(?!test)/" of+ Right patterns ->+ not (null patterns)+ && all (\p -> not ("# FILTERED:" `isInfixOf` makePattern False p)) patterns+ Left _ -> False+ ),+ check+ "parseUrl accepts pattern with a single positive lookbehind"+ ( case parseUrl "/(?<=test)/" of+ Right patterns ->+ not (null patterns)+ && all (\p -> not ("# FILTERED:" `isInfixOf` makePattern False p)) patterns+ Left _ -> False+ ),+ check+ "parseUrl accepts pattern with a single negative lookbehind"+ ( case parseUrl "/(?<!test)/" of+ Right patterns ->+ not (null patterns)+ && all (\p -> not ("# FILTERED:" `isInfixOf` makePattern False p)) patterns+ Left _ -> False+ ),+ -- Over-broad (host-unrestricted, match-everything) pattern filtering tests+ check+ "isOverbroadPattern rejects an empty host with a bare wildcard path"+ (isOverbroadPattern "" globWildcard),+ check+ "isOverbroadPattern rejects an empty host with a bare wildcard path, end-anchored"+ (isOverbroadPattern "" globWildcard),+ check+ "isOverbroadPattern allows a wildcard path once it's followed by a literal"+ (not (isOverbroadPattern "" (globWildcard ++ "ads"))),+ check+ "isOverbroadPattern allows a bare wildcard path when the host is restricted"+ (not (isOverbroadPattern "example.com" globWildcard)),+ check+ "parseUrl accepts simple domain pattern"+ ( case parseUrl "||example.com^" of+ Right patterns ->+ not (null patterns)+ && all (\p -> not ("# FILTERED:" `isInfixOf` makePattern False p)) patterns+ Left _ -> False+ ),+ check+ "parseUrl accepts wildcard pattern"+ ( case parseUrl "||example.com/*/ads/*" of+ Right patterns ->+ not (null patterns)+ && all (\p -> not ("# FILTERED:" `isInfixOf` makePattern False p)) patterns+ Left _ -> False+ ),+ check+ "parseUrl accepts separator pattern"+ ( case parseUrl "||example.com^banner^" of+ Right patterns ->+ not (null patterns)+ && all (\p -> not ("# FILTERED:" `isInfixOf` makePattern False p)) patterns+ Left _ -> False+ ),+ check+ "parseUrl filters excessively long pattern"+ ( let longPattern = "/^" ++ replicate (maxPatternLength + 100) 'a' ++ "\\$/"+ in case parseUrl longPattern of+ Right patterns -> all (\p -> "# FILTERED:" `isInfixOf` makePattern False p) patterns+ Left _ -> False+ ),+ check+ "parseUrl accepts normal-length pattern"+ ( let normalPattern = "/^" ++ replicate 100 'a' ++ "\\$/"+ in case parseUrl normalPattern of+ Right patterns ->+ not (null patterns)+ && all (\p -> not ("# FILTERED:" `isInfixOf` makePattern False p)) patterns+ Left _ -> False+ ),+ -- Domain validation tests for PolicyTree+ check+ "restrictionsTree filters out bare TLD from positive list"+ ( case restrictionsTree PT.Block (Restrictions (Just ["com", "example.com"]) []) of+ Just tree -> True -- Should succeed with only example.com+ Nothing -> False+ ),+ check+ "restrictionsTree filters out bare TLD from negative list"+ ( case restrictionsTree PT.Block (Restrictions Nothing ["org", "example.org"]) of+ Just tree -> True -- Should succeed with only example.org negated+ Nothing -> False+ ),+ check+ "restrictionsTree returns Nothing when all positive domains invalid"+ ( case restrictionsTree PT.Block (Restrictions (Just ["com", "org", "net"]) []) of+ Just _ -> False+ Nothing -> True+ ),+ check+ "restrictionsTree handles mixed valid/invalid domains in positive list"+ ( case restrictionsTree PT.Block (Restrictions (Just ["com", "example.com", "org"]) []) of+ Just _ -> True -- Should keep example.com+ Nothing -> False+ ),+ check+ "restrictionsTree handles mixed valid/invalid domains in negative list"+ ( case restrictionsTree PT.Block (Restrictions Nothing ["net", "example.net", "io"]) of+ Just _ -> True -- Should keep example.net+ Nothing -> False+ ),+ -- port pattern+ check+ "parseUrl accepts valid host:port pattern"+ (either (const False) (not . null) (parseUrl "||example.com:8080^")),+ check+ "parseUrl rejects host with malformed port"+ (either (const False) null (parseUrl "||example.com:notaport^")),+ check+ "parseUrl rejects port with no hostname"+ (either (const False) null (parseUrl "||:8080^")),+ check+ "parseUrl accepts wildcard port"+ (either (const False) (not . null) (parseUrl "||example.com:*^"))+ ]++main :: IO ()+main = do+ forM_ cases $ \c ->+ putStrLn $ (if caseOk c then "OK " else "FAIL ") ++ caseName c+ if all caseOk cases then exitSuccess else exitFailure
src/UrlBlocker.hs view
@@ -1,249 +1,306 @@ {-# LANGUAGE StrictData #-} -module UrlBlocker (-BlockMethod(..),-TaggerType(..),-urlBlock-) where-import InputParser+module UrlBlocker+ ( BlockMethod (..),+ TaggerType (..),+ urlBlock,+ )+where+ import Control.Monad-import Data.List-import Data.Char (toLower)-import OptionsConverter-import Utils import Control.Monad.State-import qualified Templates-import qualified Data.Map as Map-import Data.String.Utils (split)+import Data.Char (toLower)+import Data.List+import qualified Data.Map.Strict as Map import Data.Maybe-import System.IO+import qualified Data.Set as Set+import InputParser+import OptionsConverter+-- UrlPattern's _regex field collides with Filter's _regex field from OptionsConverter+import PatternConverter hiding (_regex) import System.FilePath-import PatternConverter+import System.IO+import qualified Templates+import Utils data TaggerType = Client | Server+ data TaggerForwarder = Forward (Maybe Filter) String | CancelTagger String-data Tagger = Tagger { _taggerCode :: String, _forwarding :: [TaggerForwarder], _headerType :: HeaderType } -data ActionType = TaggerAction Tagger | BlockAction | TerminalAction BlockMethod+data Tagger = Tagger {_taggerCode :: String, _forwarding :: [TaggerForwarder], _headerType :: HeaderType}++data ActionType = TaggerAction Tagger | BlockAction | TerminalAction BlockMethod+ data ActionSwitch = Switch Bool ActionType-data Action = Action { _actionCode :: String, _switches :: [ActionSwitch], _patterns :: [Pattern], _hasTag :: Bool } +data Action = Action {_actionCode :: String, _switches :: [ActionSwitch], _patterns :: [Pattern], _hasTag :: Bool}+ data ChainType = Regular | Nested | Negate deriving (Eq, Ord)+ type UrlBlockData = ([Tagger], [Action])+ data BlockMethod = Request | Xframe | Elem | Dnt | Xpopup deriving (Show, Eq)-data FilteringNode = Node { _pattern :: [Pattern], _filters :: HeaderFilters, _nodeType :: ChainType,- _policy :: Policy, _method :: BlockMethod } +data FilteringNode = Node+ { _pattern :: [Pattern],+ _filters :: HeaderFilters,+ _nodeType :: ChainType,+ _policy :: Policy,+ _method :: BlockMethod+ } class Named a where- name :: a -> String+ name :: a -> String -urlBlock :: String -> [String] -> [Line] -> IO()+urlBlock :: String -> [String] -> [Line] -> IO () urlBlock path info = writeBlockData . urlBlockData- where- writeBlockData :: UrlBlockData -> IO()+ where+ writeBlockData :: UrlBlockData -> IO () writeBlockData (taggers, actions) =- do writeContent (path </> "ab2p.filter") Templates.filtersFilePrefix taggers- writeContent (path </> "ab2p.action") Templates.actionsFilePrefix actions+ do+ writeContent (path </> "ab2p.filter") Templates.filtersFilePrefix taggers+ writeContent (path </> "ab2p.action") Templates.actionsFilePrefix actions+ writeContent :: (Show a) => String -> String -> [a] -> IO () writeContent filename header content =- do outFile <- openFile filename WriteMode- hSetEncoding outFile utf8- hPutStrLn outFile header- mapM_ (hPutStrLn outFile) $ ('#' :) <$> info- hPutStrLn outFile $ intercalate "\n\n" $ show <$> content- hClose outFile+ do+ outFile <- openFile filename WriteMode+ hSetEncoding outFile utf8+ -- Explicit block buffering: with millions of items this avoids+ -- one syscall-worthy flush per line under whatever the default+ -- buffering mode happens to be+ hSetBuffering outFile (BlockBuffering Nothing)+ hPutStrLn outFile header+ mapM_ (hPutStrLn outFile) $ ('#' :) <$> info+ writeItemsSeparated outFile (dedupeByShow content)+ hClose outFile+ -- Drop items whose rendered text is a repeat of one already kept+ dedupeByShow :: (Show a) => [a] -> [a]+ dedupeByShow = go Set.empty+ where+ go _ [] = []+ go seen (x : xs)+ | show x `Set.member` seen = go seen xs+ | otherwise = x : go (Set.insert (show x) seen) xs+ -- Stream each item's Show output straight to the handle+ writeItemsSeparated :: (Show a) => Handle -> [a] -> IO ()+ writeItemsSeparated _ [] = return ()+ writeItemsSeparated out (x : xs) = do+ hPutStr out (show x)+ mapM_ (\y -> hPutStr out "\n\n" >> hPutStr out (show y)) xs+ hPutStrLn out "" urlBlockData :: [Line] -> UrlBlockData urlBlockData lns = filterBlockData result- where- result = mconcat [nodeResult node | node <- shortenNodes $ sortBy cmpPolicy $ filterNodesList blockLines]- cmpPolicy node1 node2 = compare (_policy node1) (_policy node2)+ where+ result = mconcat [nodeResult node | node <- shortenNodes $ blockPolicyOrder $ filterNodesList blockLines]+ -- Use O(n) separation into (Block, Unblock) rather than O(n log n) sort+ blockPolicyOrder nodes = blocked ++ unblocked+ where+ (blocked, unblocked) = partition ((== Block) . _policy) nodes blockLines = lns >>= blockLine- where- blockLine (Line position (RequestBlock policy pttrn options))- = filteringNodes policy (errorToPattern expandedPatterns) options- where- expandedPatterns = makePattern (_matchCase options) <<$> parseUrl pttrn+ where+ blockLine (Line position (RequestBlock policy pttrn options)) =+ filteringNodes policy (errorToPattern expandedPatterns) options+ where+ expandedPatterns = filterValidPatterns $ makePattern (_matchCase options) <<$> parseUrl pttrn sourceText = recordSourceText position- errorToPattern (Left parseError) = ["# ERROR: " ++ sourceText ++ " - " ++ show parseError]+ filterValidPatterns = fmap (filter (not . startswith "# FILTERED:"))+ errorToPattern (Left parseError) = ["# ERROR: " ++ sourceText ++ " - " ++ show parseError] errorToPattern (Right patterns') = ("# " ++ sourceText) : patterns' blockLine _ = [] filterNodesList :: [FilteringNode] -> [FilteringNode] filterNodesList nodes = Map.foldr (:) [] $ Map.fromListWith joinNodes list- where+ where list = [(name node, node) | node <- nodes]- joinNodes (Node patterns1 filters1 type1 policy1 method1)- (Node patterns2 _ type2 _ _)- = Node (patterns1 ++ patterns2) filters1 (max type1 type2) policy1 method1+ joinNodes+ (Node patterns1 filters1 type1 policy1 method1)+ (Node patterns2 _ type2 _ _) =+ Node (patterns1 ++ patterns2) filters1 (max type1 type2) policy1 method1 filterBlockData :: UrlBlockData -> UrlBlockData filterBlockData blockData = (result, snd blockData)- where+ where result = Map.foldr (:) [] $ Map.fromListWith joinTaggers taggerItems taggerItems = [(name tagger, tagger) | tagger <- fst blockData]- metric = length._forwarding- joinTaggers tagger1 tagger2 | metric tagger1 >= metric tagger2 = tagger1- | otherwise = tagger2+ metric = length . _forwarding+ joinTaggers tagger1 tagger2+ | metric tagger1 >= metric tagger2 = tagger1+ | otherwise = tagger2 shortenNodes :: [FilteringNode] -> [FilteringNode] shortenNodes nodes = evalState (mapM shortenNode nodes) initialState- where+ where initialState = Map.empty :: Map.Map String String- shortenNode node = (\f -> node {_filters = f}) <$> (mapM.mapM) shortenFilter (_filters node)- shortenFilter headerFilter@(HeaderFilter headerType flt)- = let filterCode = _code flt- in do- dictionary <- get- case Map.lookup filterCode dictionary of- Just shortenCode -> return $ HeaderFilter headerType flt { _code = shortenCode }- Nothing -> case break (=='[') filterCode of- (_,[]) -> return headerFilter- (start, rest) ->- let end = last $ split "]" rest- shortenCode' = start ++ show (Map.size dictionary + 1) ++ end- in do put $ Map.insert filterCode shortenCode' dictionary- return $ HeaderFilter headerType flt { _code = shortenCode' }-+ shortenNode node = (\f -> node {_filters = f}) <$> (mapM . mapM) shortenFilter (_filters node)+ shortenFilter headerFilter@(HeaderFilter headerType flt) =+ let filterCode = _code flt+ in do+ dictionary <- get+ case Map.lookup filterCode dictionary of+ Just shortenCode -> return $ HeaderFilter headerType flt {_code = shortenCode}+ Nothing -> case break (== '[') filterCode of+ (_, []) -> return headerFilter+ (start, rest) ->+ let end = last $ split "]" rest+ shortenCode' = start ++ show (Map.size dictionary + 1) ++ end+ in do+ put $ Map.insert filterCode shortenCode' dictionary+ return $ HeaderFilter headerType flt {_code = shortenCode'} filteringNodes :: Policy -> [Pattern] -> RequestOptions -> [FilteringNode]-filteringNodes policy patterns requestOptions- = join.join $ [mainResult, subdocumentResult, elemhideResult, dntResult, popupResult]- where+filteringNodes policy patterns requestOptions =+ join . join $ [mainResult, subdocumentResult, elemhideResult, dntResult, popupResult]+ where mainResult = optionsToNodes mainOptions $> Request subdocumentResult = maybeToList (optionsToNodes (singleTypeOptions Subdocument) $> Xframe) elemhideResult = maybeToList (optionsToNodes (boolOptions _elemHide) $> Elem) dntResult = maybeToList (optionsToNodes (boolOptions _doNotTrack) $> Dnt) popupResult = maybeToList (optionsToNodes (singleTypeOptions Popup) $> Xpopup) requestType = _requestType requestOptions- mainOptions = [requestOptions {_requestType = requestType { _positive = mainPosRequestTypes } }]+ mainOptions = [requestOptions {_requestType = requestType {_positive = mainPosRequestTypes}}] mainPosRequestTypes = filter (`notElem` [Subdocument]) <$> _positive requestType- boolOptions getter = if getter requestOptions+ boolOptions getter =+ if getter requestOptions then Nothing else Just requestOptions {_requestType = Restrictions Nothing [], _thirdParty = Nothing} singleTypeOptions singleType =- do+ do foundTypes <- filter (== singleType) <$> _positive requestType foundType <- listToMaybe foundTypes- return requestOptions {_requestType = requestType { _positive = Just [foundType] } }+ return requestOptions {_requestType = requestType {_positive = Just [foundType]}} optionsToNodes options = collectNodes patterns . headerFilters policy 2 <$> options nestedOrRegular True = Nested nestedOrRegular False = Regular collectNodes :: [Pattern] -> Maybe HeaderFilters -> BlockMethod -> [FilteringNode] collectNodes _ Nothing _ = [] collectNodes patterns' (Just []) method = [Node patterns' [] (nestedOrRegular $ null patterns') policy method]- collectNodes patterns' (Just filters@(levelFilters: next)) method- = Node patterns' filters (nestedOrRegular $ null patterns') policy method- : (levelFilters >>= negateNode)- ++ collectNodes [] (Just next) method- where- negateNode negateFilter@(HeaderFilter _ (Filter {_orEmpty = True}))- = [Node [] ([negateFilter] : next) Negate policy method]+ collectNodes patterns' (Just filters@(levelFilters : next)) method =+ Node patterns' filters (nestedOrRegular $ null patterns') policy method+ : (levelFilters >>= negateNode)+ ++ collectNodes [] (Just next) method+ where+ negateNode negateFilter@(HeaderFilter _ (Filter {_orEmpty = True})) =+ [Node [] ([negateFilter] : next) Negate policy method] negateNode _ = [] nodeResult :: FilteringNode -> UrlBlockData nodeResult node@(Node patterns [] nodeType policy method) = ([], [baseAction])- where baseAction = Action (name node) [Switch (policy == Block) $ TerminalAction method] patterns (nodeType == Nested)-nodeResult node@(Node _ ([flt] : nextLevelFilters) Negate policy method)- = ([negateTagger], [negateAction])- where+ where+ baseAction = Action (name node) [Switch (policy == Block) $ TerminalAction method] patterns (nodeType == Nested)+nodeResult node@(Node _ ([flt] : nextLevelFilters) Negate policy method) =+ ([negateTagger], [negateAction])+ where negateAction = Action (name node) [Switch False $ TaggerAction negateTagger] [] True negateTagger = newTagger flt nextLevelFilters policy method Negate []-nodeResult node@(Node patterns (levelFilters : nextLevelFilters) nodeType policy method)- = (taggers, [action])- where- action = Action { _actionCode = name node,- _switches = appendIf (policy == Unblock && method == Request)- (Switch False BlockAction)- (Switch True . TaggerAction <$> taggers),- _patterns = patterns,- _hasTag = nodeType == Nested }+nodeResult node@(Node patterns (levelFilters : nextLevelFilters) nodeType policy method) =+ (taggers, [action])+ where+ action =+ Action+ { _actionCode = name node,+ _switches =+ appendIf+ (policy == Unblock && method == Request)+ (Switch False BlockAction)+ (Switch True . TaggerAction <$> taggers),+ _patterns = patterns,+ _hasTag = nodeType == Nested+ } taggers = filterTaggers <$> levelFilters- filterTaggers flt@(HeaderFilter _ (Filter _ _ orEmpty))- = newTagger flt nextLevelFilters policy method Regular moreForwarding- where- orEmptyTaggerCode = filtersCode ([flt] : nextLevelFilters) Negate policy method ""- moreForwarding | orEmpty = [CancelTagger orEmptyTaggerCode]- | otherwise = []+ filterTaggers flt@(HeaderFilter _ (Filter _ _ orEmpty)) =+ newTagger flt nextLevelFilters policy method Regular moreForwarding+ where+ orEmptyTaggerCode = filtersCode ([flt] : nextLevelFilters) Negate policy method ""+ moreForwarding+ | orEmpty = [CancelTagger orEmptyTaggerCode]+ | otherwise = [] newTagger :: HeaderFilter -> HeaderFilters -> Policy -> BlockMethod -> ChainType -> [TaggerForwarder] -> Tagger-newTagger flt@(HeaderFilter headerType filter') nextLevelFilters policy method chainType moreForwarding- = Tagger { _taggerCode = taggerCode,- _forwarding = Forward filter'' nextLevelActionCode : moreForwarding,- _headerType = headerType }- where- filter'' | chainType == Negate = Nothing- | otherwise = Just filter'- taggerCode = filtersCode ([flt] : nextLevelFilters) chainType policy method ""- nextLevelActionCode = filtersCode nextLevelFilters Nested policy method ""+newTagger flt@(HeaderFilter headerType filter') nextLevelFilters policy method chainType moreForwarding =+ Tagger+ { _taggerCode = taggerCode,+ _forwarding = Forward filter'' nextLevelActionCode : moreForwarding,+ _headerType = headerType+ }+ where+ filter''+ | chainType == Negate = Nothing+ | otherwise = Just filter'+ taggerCode = filtersCode ([flt] : nextLevelFilters) chainType policy method ""+ nextLevelActionCode = filtersCode nextLevelFilters Nested policy method "" instance Named FilteringNode where- name (Node _ filters Negate policy method) = '-' : filtersCode filters Negate policy method ""- name (Node _ filters _ policy method) = filtersCode filters Nested policy method ""+ name (Node _ filters Negate policy method) = '-' : filtersCode filters Negate policy method ""+ name (Node _ filters _ policy method) = filtersCode filters Nested policy method "" filtersCode :: HeaderFilters -> ChainType -> Policy -> BlockMethod -> String -> String-filtersCode [] _ policy method rest- = join [Templates.ab2pPrefix, toLower <$> show policy, "-" ,toLower <$> show method, if null rest then "" else "-", rest]-filtersCode (levelFilters : nextLevelFilters) chainType policy method rest- = filtersCode nextLevelFilters Nested policy method $ join [levelCode, if null rest then "" else "-when-", rest]- where+filtersCode [] _ policy method rest =+ join [Templates.ab2pPrefix, toLower <$> show policy, "-", toLower <$> show method, if null rest then "" else "-", rest]+filtersCode (levelFilters : nextLevelFilters) chainType policy method rest =+ filtersCode nextLevelFilters Nested policy method $ join [levelCode, if null rest then "" else "-when-", rest]+ where levelCode = intercalate "-" $ filterCode <$> levelFilters filterCode (HeaderFilter HeaderType {_typeCode = typeCode} (Filter code _ orEmpty))- | chainType == Negate = negateCode- | chainType == Nested && orEmpty = negateCode ++ '-' : mainCode- | otherwise = mainCode- where+ | chainType == Negate = negateCode+ | chainType == Nested && orEmpty = negateCode ++ '-' : mainCode+ | otherwise = mainCode+ where mainCode = typeCode : code negateCode = 'n' : [typeCode] instance Show TaggerType where- show Client = "CLIENT-HEADER-TAGGER"- show Server = "SERVER-HEADER-TAGGER"+ show Client = "CLIENT-HEADER-TAGGER"+ show Server = "SERVER-HEADER-TAGGER" instance Named TaggerType where- name = fmap toLower . show+ name = fmap toLower . show instance Named Tagger where- name = _taggerCode+ name = _taggerCode instance Show Tagger where- show (Tagger code forwarding HeaderType {_name = headerName, _taggerType = taggerType })- = intercalate "\n" (caption : (forward <$> forwarding))- where caption = show taggerType ++ ": " ++ code- forward (Forward (Just filter') target) = forwardRegex headerName (_regex filter') ":" "" target- forward (Forward Nothing target) = forwardRegex "" "" "" "" target- forward (CancelTagger taggerCode) = forwardRegex headerName "" ":" "-" taggerCode- forwardRegex header expression value tagPrefix target- = let (modifier, lookahead', additionalLines) - = case split "\n" expression of- [x] -> ("Ti", x, [])- (x:xs) -> ("i", x, xs) -- the case for third-party- _ -> ("Ti", expression, [])- in intercalate "\n" $ additionalLines ++- [join ["s@^", header, lookahead', value, ".*@", tagPrefix, target, "@", modifier]]+ show (Tagger code forwarding HeaderType {_name = headerName, _taggerType = taggerType}) =+ intercalate "\n" (caption : (forward <$> forwarding))+ where+ caption = show taggerType ++ ": " ++ code+ forward (Forward (Just filter') target) = forwardRegex headerName (_regex filter') ":" "" target+ forward (Forward Nothing target) = forwardRegex "" "" "" "" target+ forward (CancelTagger taggerCode) = forwardRegex headerName "" ":" "-" taggerCode+ forwardRegex header expression value tagPrefix target =+ let (modifier, lookahead', additionalLines) =+ case split "\n" expression of+ [x] -> ("Ti", x, [])+ (x : xs) -> ("i", x, xs) -- the case for third-party+ _ -> ("Ti", expression, [])+ in intercalate "\n" $+ additionalLines+ ++ [join ["s@^", header, lookahead', value, ".*@", tagPrefix, target, "@", modifier]] instance Named Bool where- name True = "+"- name False = "-"+ name True = "+"+ name False = "-" instance Show ActionSwitch where- show (Switch enable (TerminalAction method)) = Templates.terminalActionSwitch enable method- show (Switch enable BlockAction) = name enable ++ "block"- show (Switch enable (TaggerAction tagger))- = intercalate " \\\n " $ mainText : (_forwarding tagger >>= cancelTaggerText)- where- mainText = join [name enable, name . _taggerType . _headerType $ tagger, "{", name tagger, "}" ]- cancelTaggerText (CancelTagger cancelTaggerCode)- = [join [name enable, name . _taggerType . _headerType $ tagger, "{", cancelTaggerCode, "}" ]]- cancelTaggerText _ = []+ show (Switch enable (TerminalAction method)) = Templates.terminalActionSwitch enable method+ show (Switch enable BlockAction) = name enable ++ "block"+ show (Switch enable (TaggerAction tagger)) =+ intercalate " \\\n " $ mainText : (_forwarding tagger >>= cancelTaggerText)+ where+ mainText = join [name enable, name . _taggerType . _headerType $ tagger, "{", name tagger, "}"]+ cancelTaggerText (CancelTagger cancelTaggerCode) =+ [join [name enable, name . _taggerType . _headerType $ tagger, "{", cancelTaggerCode, "}"]]+ cancelTaggerText _ = [] instance Named Action where- name = _actionCode+ name = _actionCode instance Show Action where- show (Action code switches patterns hasTag)- = intercalate "\n" (caption : switches' : patterns')- where caption = '#' : code- switches' = join ["{", intercalate " \\\n " (show <$> switches), " \\\n}"]- patterns' | hasTag = join ["TAG:^", code, "$"] : patterns- | otherwise = patterns+ show (Action code switches patterns hasTag) =+ intercalate "\n" (caption : switches' : patterns')+ where+ caption = '#' : code+ switches' = join ["{", intercalate " \\\n " (show <$> switches), " \\\n}"]+ patterns'+ | hasTag = join ["TAG:^", code, "$"] : patterns+ | otherwise = patterns
src/UrlBlocker.hs-boot view
@@ -1,7 +1,9 @@-module UrlBlocker (-BlockMethod(..),-TaggerType(..)-) where+module UrlBlocker+ ( BlockMethod (..),+ TaggerType (..),+ )+where data BlockMethod = Request | Xframe | Elem | Dnt | Xpopup+ data TaggerType = Client | Server
src/Utils.hs view
@@ -1,59 +1,85 @@ {-# LANGUAGE CPP #-}-module Utils (-Struct2 (..),-Struct3 (..),-Struct4 (..),-Struct5 (..),-testSquare,-ZipListM,-getZipListM,-zipListM,-maxList,-minList,-compareList,-appendIf,-pure',-pure'',-(<<$>),-(<<<$>),-(<<*>>),-(<<<*>>>),-($>),-($>>),-($>>>),-(.*.)-) where++module Utils+ ( Struct2 (..),+ Struct3 (..),+ Struct4 (..),+ Struct5 (..),+ testSquare,+ ZipListM,+ getZipListM,+ zipListM,+ maxList,+ minList,+ compareList,+ appendIf,+ replace,+ split,+ startswith,+ mergeBalanced,+ pure',+ pure'',+ (<<$>),+ (<<<$>),+ (<<*>>),+ (<<<*>>>),+ ($>),+ ($>>),+ ($>>>),+ (.*.),+ )+where+ import Control.Applicative hiding (many) import Control.Monad.State+import Data.List (isPrefixOf)+import Data.List.Extra (replace, splitOn) import Data.Monoid ------------------------------------------------------------------------------------------ ----------------------------- export ----------------------------------------------------- ------------------------------------------------------------------------------------------ +-- export @Data.List.isPrefixOf@ under the original name+startswith :: (Eq a) => [a] -> [a] -> Bool+startswith = isPrefixOf++-- export @Data.List.Extra.splitOn@ under the original name+split :: (Eq a) => [a] -> [a] -> [[a]]+split = splitOn+ -- at least one list should be finite-compareList :: Ord a => [a] -> [a] -> Ordering+compareList :: (Ord a) => [a] -> [a] -> Ordering compareList = compareList' EQ- where- compareList' lx [] [] = lx- compareList' _ [] _ = LT- compareList' _ _ [] = GT- compareList' lx (x:xs) (y:ys) = compareList' (lx <> compare x y) xs ys+ where+ compareList' lx [] [] = lx+ compareList' _ [] _ = LT+ compareList' _ _ [] = GT+ compareList' lx (x : xs) (y : ys) = compareList' (lx <> compare x y) xs ys -maxList :: Ord a => [a] -> [a] -> [a]+maxList :: (Ord a) => [a] -> [a] -> [a] maxList a b = if compareList a b == LT then b else a -minList :: Ord a => [a] -> [a] -> [a]+minList :: (Ord a) => [a] -> [a] -> [a] minList a b = if compareList a b == GT then b else a appendIf :: Bool -> a -> [a] -> [a] appendIf condition item list- | condition = item : list- | otherwise = list+ | condition = item : list+ | otherwise = list -newtype ZipListM a = ZipListM { getZipList' :: ZipList a } deriving (Functor, Applicative)+-- Combine values using divide-and-conquer rather than linear folds+mergeBalanced :: (a -> a -> a) -> [a] -> a+mergeBalanced _ [x] = x+mergeBalanced f xs = mergeBalanced f (pairUp xs)+ where+ pairUp (a : b : rest) = f a b : pairUp rest+ pairUp rest = rest++newtype ZipListM a = ZipListM {getZipList' :: ZipList a} deriving (Functor, Applicative)+ getZipListM :: ZipListM a -> [a]-getZipListM = getZipList.getZipList'+getZipListM = getZipList . getZipList' zipListM :: [a] -> ZipListM a zipListM = ZipListM . ZipList@@ -63,7 +89,7 @@ x <> y = (<>) <$> x <*> y #endif -instance Monoid a => Monoid (ZipListM a) where+instance (Monoid a) => Monoid (ZipListM a) where mempty = pure mempty #if (MIN_VERSION_base(4,11,0)) mappend = (<>)@@ -72,35 +98,39 @@ #endif class Struct2 f where- struct2 :: a1 -> a2 -> f a1 a2- square2 :: (Applicative g, Monoid a1, Monoid a2) => g a1 -> g a2 -> [g (f a1 a2)]- square2 a1 a2 = makeSquare (pure'' struct2 <%> a1 <%> a2)-+ struct2 :: a1 -> a2 -> f a1 a2+ square2 :: (Applicative g, Monoid a1, Monoid a2) => g a1 -> g a2 -> [g (f a1 a2)]+ square2 a1 a2 = makeSquare (pure'' struct2 <%> a1 <%> a2) class Struct3 f where- struct3 :: a1 -> a2 -> a3 -> f a1 a2 a3- square3 :: (Applicative g, Monoid a1, Monoid a2, Monoid a3) =>- g a1 -> g a2 -> g a3 -> [g (f a1 a2 a3)]- square3 a1 a2 a3 = makeSquare (pure'' struct3 <%> a1 <%> a2 <%> a3)+ struct3 :: a1 -> a2 -> a3 -> f a1 a2 a3+ square3 ::+ (Applicative g, Monoid a1, Monoid a2, Monoid a3) =>+ g a1 -> g a2 -> g a3 -> [g (f a1 a2 a3)]+ square3 a1 a2 a3 = makeSquare (pure'' struct3 <%> a1 <%> a2 <%> a3) class Struct4 f where- struct4 :: a1 -> a2 -> a3 -> a4 -> f a1 a2 a3 a4- square4 :: (Applicative g, Monoid a1, Monoid a2, Monoid a3, Monoid a4) =>- g a1 -> g a2 -> g a3 -> g a4 -> [g (f a1 a2 a3 a4)]- square4 a1 a2 a3 a4 = makeSquare (pure'' struct4 <%> a1 <%> a2 <%> a3 <%> a4)+ struct4 :: a1 -> a2 -> a3 -> a4 -> f a1 a2 a3 a4+ square4 ::+ (Applicative g, Monoid a1, Monoid a2, Monoid a3, Monoid a4) =>+ g a1 -> g a2 -> g a3 -> g a4 -> [g (f a1 a2 a3 a4)]+ square4 a1 a2 a3 a4 = makeSquare (pure'' struct4 <%> a1 <%> a2 <%> a3 <%> a4) class Struct5 f where- struct5 :: a1 -> a2 -> a3 -> a4 -> a5 -> f a1 a2 a3 a4 a5- square5 :: (Applicative g, Monoid a1, Monoid a2, Monoid a3, Monoid a4, Monoid a5) =>- g a1 -> g a2 -> g a3 -> g a4 -> g a5 -> [g (f a1 a2 a3 a4 a5)]- square5 a1 a2 a3 a4 a5 = makeSquare (pure'' struct5 <%> a1 <%> a2 <%> a3 <%> a4 <%> a5)+ struct5 :: a1 -> a2 -> a3 -> a4 -> a5 -> f a1 a2 a3 a4 a5+ square5 ::+ (Applicative g, Monoid a1, Monoid a2, Monoid a3, Monoid a4, Monoid a5) =>+ g a1 -> g a2 -> g a3 -> g a4 -> g a5 -> [g (f a1 a2 a3 a4 a5)]+ square5 a1 a2 a3 a4 a5 = makeSquare (pure'' struct5 <%> a1 <%> a2 <%> a3 <%> a4 <%> a5) -instance Struct2 (,) where struct2 = (,)-instance Struct3 (,,) where struct3 = (,,)-instance Struct4 (,,,) where struct4 = (,,,)-instance Struct5 (,,,,) where struct5 = (,,,,)+instance Struct2 (,) where struct2 = (,) +instance Struct3 (,,) where struct3 = (,,) +instance Struct4 (,,,) where struct4 = (,,,)++instance Struct5 (,,,,) where struct5 = (,,,,)+ --------------------------------------------------------------------------------------------- ------------------------- usage sample ------------------------------------------------------ ---------------------------------------------------------------------------------------------@@ -124,49 +154,58 @@ -- involves 2 applicatives/monads : -- State Int a - stores column number -- Reader ((->) r) - provides row number from outside-valueOnDiagonal :: (Applicative f, Monoid a) => f a -> State Int (Int -> f a)+valueOnDiagonal :: (Applicative f, Monoid a) => f a -> State Int (Int -> f a) valueOnDiagonal val = do- col <- get- put (col + 1)- return (\row -> if row == col- then val- else pure mempty)+ col <- get+ put (col + 1)+ return+ ( \row ->+ if row == col+ then val+ else pure mempty+ ) -- lifts right argument 2 levels up to become s (r (f a)) where s = State and r = Reader -- then applies left arg to right one -- it's used to put items to a line in matrix-(<%>) :: (Applicative f, Monoid a) => State Int (Int -> f (a -> b))- -> f a -- becomes State Int (Int -> f a) after lift with valueOnDiagonal- -> State Int (Int -> f b)+(<%>) ::+ (Applicative f, Monoid a) =>+ State Int (Int -> f (a -> b)) ->+ f a -> -- becomes State Int (Int -> f a) after lift with valueOnDiagonal+ State Int (Int -> f b) (<%>) a b = a <<<*>>> valueOnDiagonal b -- creates square matrix from given lines -- values are on main diagonal makeSquare :: State Int (Int -> a) -> [a]-makeSquare line = let start = 0- (line', size) = runState line start- in line' <$> [start .. size - 1]+makeSquare line =+ let start = 0+ (line', size) = runState line start+ in line' <$> [start .. size - 1] -- pure level 2 pure' :: (Applicative f, Applicative g) => a -> f (g a)-pure' = pure.pure+pure' = pure . pure -- pure level 3 pure'' :: (Applicative f, Applicative g, Applicative h) => a -> f (g (h a))-pure'' = pure.pure.pure+pure'' = pure . pure . pure infixl 4 .*., <<$>, <<<$>, $>, $>>, $>>>, <<*>>, <<<*>>> -(.*.) :: (c -> d) ->- (a -> b -> c) ->- a -> b -> d-(.*.) = (.).(.)+(.*.) ::+ (c -> d) ->+ (a -> b -> c) ->+ a ->+ b ->+ d+(.*.) = (.) . (.) (<<$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)-(<<$>) = fmap.fmap+(<<$>) = fmap . fmap (<<<$>) :: (Functor f, Functor g, Functor h) => (a -> b) -> f (g (h a)) -> f (g (h b))-(<<<$>) = fmap.fmap.fmap+(<<<$>) = fmap . fmap . fmap ($>) :: (Applicative f) => f (a -> b) -> a -> f b ($>) a b = a <*> pure b@@ -180,5 +219,5 @@ (<<*>>) :: (Applicative f, Applicative g) => f (g (a -> b)) -> f (g a) -> f (g b) (<<*>>) = liftA2 (<*>) -(<<<*>>>) :: (Applicative f, Applicative g, Applicative h) => f (g (h (a -> b))) -> f (g (h a)) -> f (g (h b))+(<<<*>>>) :: (Applicative f, Applicative g, Applicative h) => f (g (h (a -> b))) -> f (g (h a)) -> f (g (h b)) (<<<*>>>) = liftA2 (<<*>>)