diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/adblock2privoxy.cabal b/adblock2privoxy.cabal --- a/adblock2privoxy.cabal +++ b/adblock2privoxy.cabal @@ -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 , Steven Thomas Smith 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 diff --git a/src/ElementBlocker.hs b/src/ElementBlocker.hs --- a/src/ElementBlocker.hs +++ b/src/ElementBlocker.hs @@ -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 diff --git a/src/InputParser.hs b/src/InputParser.hs --- a/src/InputParser.hs +++ b/src/InputParser.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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."] diff --git a/src/Network.hs b/src/Network.hs --- a/src/Network.hs +++ b/src/Network.hs @@ -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 diff --git a/src/OptionsConverter.hs b/src/OptionsConverter.hs --- a/src/OptionsConverter.hs +++ b/src/OptionsConverter.hs @@ -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 _ _ = [] diff --git a/src/ParsecExt.hs b/src/ParsecExt.hs --- a/src/ParsecExt.hs +++ b/src/ParsecExt.hs @@ -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 ------------------------------------------------------------------------------------------------ diff --git a/src/ParserExtTests.hs b/src/ParserExtTests.hs --- a/src/ParserExtTests.hs +++ b/src/ParserExtTests.hs @@ -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 diff --git a/src/PatternConverter.hs b/src/PatternConverter.hs --- a/src/PatternConverter.hs +++ b/src/PatternConverter.hs @@ -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 = ["(?=", "(?!", "(?<=", "(? 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 diff --git a/src/PolicyTree.hs b/src/PolicyTree.hs --- a/src/PolicyTree.hs +++ b/src/PolicyTree.hs @@ -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) diff --git a/src/PopupBlocker.hs b/src/PopupBlocker.hs deleted file mode 100644 --- a/src/PopupBlocker.hs +++ /dev/null @@ -1,1 +0,0 @@ -module PopupBlocker where diff --git a/src/ProgramOptions.hs b/src/ProgramOptions.hs --- a/src/ProgramOptions.hs +++ b/src/ProgramOptions.hs @@ -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' diff --git a/src/SourceInfo.hs b/src/SourceInfo.hs --- a/src/SourceInfo.hs +++ b/src/SourceInfo.hs @@ -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' diff --git a/src/Statistics.hs b/src/Statistics.hs --- a/src/Statistics.hs +++ b/src/Statistics.hs @@ -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" diff --git a/src/Task.hs b/src/Task.hs --- a/src/Task.hs +++ b/src/Task.hs @@ -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 diff --git a/src/Templates.hs b/src/Templates.hs --- a/src/Templates.hs +++ b/src/Templates.hs @@ -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 diff --git a/src/Test.hs b/src/Test.hs new file mode 100644 --- /dev/null +++ b/src/Test.hs @@ -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(?Pbar)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 "/(? + 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 diff --git a/src/UrlBlocker.hs b/src/UrlBlocker.hs --- a/src/UrlBlocker.hs +++ b/src/UrlBlocker.hs @@ -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 diff --git a/src/UrlBlocker.hs-boot b/src/UrlBlocker.hs-boot --- a/src/UrlBlocker.hs-boot +++ b/src/UrlBlocker.hs-boot @@ -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 diff --git a/src/Utils.hs b/src/Utils.hs --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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 (<<*>>)