adblock2privoxy 2.2.0 → 2.3.0
raw patch · 22 files changed
+343/−185 lines, 22 filesdep ~MissingHdep ~case-insensitivedep ~containers
Dependency ranges changed: MissingH, case-insensitive, containers, directory, filepath, http-conduit, mtl, network, network-uri, old-locale, parsec, parsec-permutation, strict, text, time
Files
- CHANGELOG.md +61/−0
- README.rst +4/−0
- adblock2privoxy.cabal +19/−18
- changelog +0/−57
- man/man1/adblock2privoxy.1 +10/−0
- src/ElementBlocker.hs +24/−44
- src/InputParser.hs +13/−9
- src/Main.hs +8/−5
- src/Network.hs +1/−2
- src/OptionsConverter.hs +9/−6
- src/ParsecExt.hs +1/−1
- src/ParserExtTests.hs +122/−0
- src/PatternConverter.hs +7/−5
- src/PolicyTree.hs +2/−0
- src/ProgramOptions.hs +25/−8
- src/SourceInfo.hs +8/−5
- src/Statistics.hs +1/−2
- src/Task.hs +3/−3
- src/Templates.hs +7/−6
- src/UrlBlocker.hs +16/−12
- templates/ab2p.system.action +1/−1
- templates/ab2p.system.filter +1/−1
+ CHANGELOG.md view
@@ -0,0 +1,61 @@+2.3.0+ * hlint mods+ * Add debug code with new DebugLevel option++2.2.0+ * Remove unused debug code++2.1.1+ * Fix compilation issues for ghc 9.6.3++2.1.0+ * Use TLS for CSS server to avoid mixed content errors+ * Add --useHTTP option+ * Update to ghc 8.10.7, lts-18.18 resolver++2.0.2+ * Update to ghc 8.10.4, lts-17.11 resolver++2.0.1+ * Update to ghc 8.6.5, lts-13.25 resolver++2.0.0+ * Update to ghc 8.4.3+ * Regex wildcard optimizations+ * Fix several parsing issues+ * Fix several privoxy action syntax issues+ * Migrate to GitHub fork++1.4.2+ * Fixed "commitBuffer: invalid argument (invalid character)" problem+ * Fixed system.action file generation in case when no webserver is used+ * Improved documentation++1.4.0+ * Stack build envirionment and GHC 7.10+ * Problem with network connections should be fixed because of new HTTPS library++1.3.0+ * Build and packaging process refactoring+ * Build script for windows+ * Installation documentation+ * CSS server domain changed from hardcoded 'privoxy.zubr.me' to configurable one (ticket #1)+ * Element hiding CSS generation is skipped if the domain is not specified+ * Task files contains output paths, so it's possible to run ab2p with single parameter: task file name+ * Bugfixes for tickets #7, #8, #9+1.2.4+ * Documentation and bugfixes++1.1.0+ * Tasks support to update privoxy config from same sources+ * HTTP(s) supported to get adblock files+ * Redirect comment support+ * Sources expiration check ++1.0.0+ * First public version+ * Supports filenames in command-line+ * Page elements blocking+ * URLs blocking+ * Popups blocking+ * Adblock options: script, image, stylesheet, object, xmlhttprequest, object-subrequest, subdocument,document, elemhide, other, popup, third-party, domain=..., match-case, donottrack
README.rst view
@@ -56,6 +56,10 @@ Css files output path -d DOMAIN, --domainCSS=DOMAIN Domain of CSS web server (required for Element Hide functionality)+ -u, --useHTTP+ Use HTTP for CSS web server; the default is HTTPS to avoid mixed content+ -g INT, --debugLevel=INT+ Debug Level. 0: Off; 1: top directory CSS; 2: full directory. -t PATH, --taskFile=PATH Path to task file containing urls to process and options. -f, --forced
adblock2privoxy.cabal view
@@ -1,5 +1,5 @@ name: adblock2privoxy-version: 2.2.0+version: 2.3.0 cabal-version: >= 1.10 build-type: Simple tested-with:@@ -12,7 +12,7 @@ stack.yaml README.rst INSTALL.rst- changelog+ CHANGELOG.md man/man1/adblock2privoxy.1 distribution/rpmbuild/SPECS/adblock2privoxy.spec distribution/buildWin.bat@@ -65,21 +65,21 @@ FlexibleContexts build-depends: base >= 4 && < 9.9,- parsec,- mtl,- containers,- filepath,- directory,- MissingH >=1.4.3.0,- parsec-permutation >=0.1.2.0,- time >=1.4,- old-locale >=1.0,- strict >=0.3,- network >=2.4,- http-conduit,- text >=0.11,- network-uri,- case-insensitive+ 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.2,+ old-locale >= 1.0.0 && < 1.1,+ parsec >= 3.1.16 && < 3.2,+ text >= 2.0.2 && < 2.1,+ case-insensitive >= 1.2.1 && < 1.3,+ http-conduit >= 2.3.8 && < 2.4,+ network-uri >= 2.6.4 && < 2.7,+ strict >= 0.5 && < 0.6,+ parsec-permutation >= 0.1.2 && < 0.2 ghc-options: -Wall other-modules: ElementBlocker,@@ -87,6 +87,7 @@ Network, OptionsConverter, ParsecExt,+ ParserExtTests, Paths_adblock2privoxy, PatternConverter, PolicyTree,@@ -103,4 +104,4 @@ type: git location: https://github.com/essandess/adblock2privoxy.git subdir: adblock2privoxy- tag: v2.2.0+ tag: v2.3.0
− changelog
@@ -1,57 +0,0 @@-2.2.0- * Remove unused debug code--2.1.1- * Fix compilation issues for ghc 9.6.3--2.1.0- * Use TLS for CSS server to avoid mixed content errors- * Add --useHTTP option- * Update to ghc 8.10.7, lts-18.18 resolver--2.0.2- * Update to ghc 8.10.4, lts-17.11 resolver--2.0.1- * Update to ghc 8.6.5, lts-13.25 resolver--2.0.0- * Update to ghc 8.4.3- * Regex wildcard optimizations- * Fix several parsing issues- * Fix several privoxy action syntax issues- * Migrate to GitHub fork--1.4.2- * Fixed "commitBuffer: invalid argument (invalid character)" problem- * Fixed system.action file generation in case when no webserver is used- * Improved documentation--1.4.0- * Stack build envirionment and GHC 7.10- * Problem with network connections should be fixed because of new HTTPS library--1.3.0- * Build and packaging process refactoring- * Build script for windows- * Installation documentation- * CSS server domain changed from hardcoded 'privoxy.zubr.me' to configurable one (ticket #1)- * Element hiding CSS generation is skipped if the domain is not specified- * Task files contains output paths, so it's possible to run ab2p with single parameter: task file name- * Bugfixes for tickets #7, #8, #9-1.2.4- * Documentation and bugfixes--1.1.0- * Tasks support to update privoxy config from same sources- * HTTP(s) supported to get adblock files- * Redirect comment support- * Sources expiration check --1.0.0- * First public version- * Supports filenames in command-line- * Page elements blocking- * URLs blocking- * Popups blocking- * Adblock options: script, image, stylesheet, object, xmlhttprequest, object-subrequest, subdocument,document, elemhide, other, popup, third-party, domain=..., match-case, donottrack
man/man1/adblock2privoxy.1 view
@@ -79,6 +79,16 @@ .RS .RE .TP+.B \-u \-\-useHTTP+Use HTTP for CSS web server; the default is HTTPS to avoid mixed content+.RS+.RE+.TP+.B \-g INT \-\-debugLevel=INT+Debug Level. 0: Off; 1: top directory CSS; 2: full directory.+.RS+.RE+.TP .B \-t PATH \-\-taskFile=PATH Path to task file containing urls to process and options. .RS
src/ElementBlocker.hs view
@@ -1,9 +1,12 @@+{-# LANGUAGE StrictData #-}+ module ElementBlocker ( elemBlock ) where import InputParser hiding (Policy(..)) import qualified InputParser import PolicyTree+import ProgramOptions (DebugLevel(DebugLevel)) import qualified Data.Map as Map import Data.Maybe import Utils@@ -19,51 +22,45 @@ type BlockedRulesTree = DomainTree [Pattern] data ElemBlockData = ElemBlockData [Pattern] BlockedRulesTree deriving Show -elemBlock :: String -> [String] -> [Line] -> IO ()-elemBlock path info = writeElemBlock . elemBlockData+elemBlock :: String -> [String] -> DebugLevel -> [Line] -> IO ()+elemBlock path info debug = writeElemBlock . elemBlockData where writeElemBlock :: ElemBlockData -> IO () writeElemBlock (ElemBlockData flatPatterns rulesTree) = do- let filteredInfo = filter ((||) <$> not . startswith "Url:" <*> startswith "Url: http") info- -- debugPath = path </> "debug"+ let debugPath = path </> "debug"+ filteredInfo = filter ((||) <$> not . startswith "Url:" <*> startswith "Url: http") info createDirectoryIfMissing True path cont <- getDirectoryContents path- _ <- sequence $ removeOld <$> cont- -- createDirectoryIfMissing True debugPath- -- writeBlockTree path debugPath rulesTree- writeBlockTree path rulesTree- writePatterns_with_debug filteredInfo (path </> "ab2p.common.css") "" flatPatterns- -- writePatterns_with_debug filteredInfo (path </> "ab2p.common.css") (debugPath </> "ab2p.common.css") flatPatterns+ 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- -- writeBlockTree :: String -> String -> BlockedRulesTree -> IO ()- -- writeBlockTree normalNodePath debugNodePath (Node name patterns children) =- writeBlockTree :: String -> BlockedRulesTree -> IO ()- writeBlockTree normalNodePath (Node name patterns children) =+ writeBlockTree :: String -> String -> BlockedRulesTree -> IO ()+ writeBlockTree normalNodePath debugNodePath (Node name patterns children) = do createDirectoryIfMissing True normalPath- -- createDirectoryIfMissing True debugPath- -- _ <- sequence (writeBlockTree normalPath debugPath <$> children)- -- writePatterns ["See ab2p.common.css for sources info"] normalFilename debugFilename patterns- _ <- sequence (writeBlockTree normalPath <$> children)- writePatterns ["See ab2p.common.css for sources info"] normalFilename patterns+ 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+ debugPath+ | null name = debugNodePath+ | otherwise = debugNodePath </> name normalFilename = normalPath </> "ab2p.css"- -- debugFilename = debugPath </> "ab2p.css"- writePatterns_with_debug :: [String] -> String -> String -> [Pattern] -> IO ()- writePatterns_with_debug _ _ _ [] = return ()- writePatterns_with_debug info' normalFilename debugFilename patterns =+ 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)@@ -75,24 +72,7 @@ do outFile <- openFile filename WriteMode hSetEncoding outFile utf8 hPutStrLn outFile "/*"- _ <- mapM (hPutStrLn outFile) info'- hPutStrLn outFile "*/"- hPutStrLn outFile content- hClose outFile- writePatterns :: [String] -> String -> [Pattern] -> IO ()- writePatterns _ _ [] = return ()- writePatterns info' normalFilename patterns =- do- -- writeCssFile debugFilename $ intercalate "\n" $ (++ Templates.blockCss) <$> patterns- writeCssFile normalFilename $ intercalate "\n" ((++ Templates.blockCss) . intercalate "," <$>- splitEvery 4000 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'+ mapM_ (hPutStrLn outFile) info' hPutStrLn outFile "*/" hPutStrLn outFile content hClose outFile
src/InputParser.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE StrictData #-}+ module InputParser ( Line (..), Restrictions (..),@@ -17,6 +19,8 @@ import Data.List.Utils (split) import Data.List import Data.Char+import Data.Containers.ListUtils+import Data.Functor import Data.Monoid import Control.Monad import Text.Parsec.Permutation@@ -40,7 +44,7 @@ data RequestType = Script | Image | Stylesheet | Object | Xmlhttprequest | Popup | ObjectSubrequest | Subdocument | Document | Other- deriving (Read, Show,Eq)+ deriving (Read,Show,Eq,Ord) data RequestOptions = RequestOptions { _requestType :: Restrictions RequestType,@@ -62,7 +66,7 @@ data Restrictions a = Restrictions { _positive :: Maybe [a], _negative :: [a]}- deriving (Read,Show,Eq)+ deriving (Read,Show,Eq,Ord) recordSourceText :: RecordSource -> String recordSourceText (RecordSource position rawRecord)@@ -98,14 +102,14 @@ match = RequestBlock <$> excludeMatch <*> pattern <*> options where excludeMatch = option Block $ Unblock <$ count 2 (char '@')- patternEnd = try (return () <* char '$' <* requestOptions <* lineEnd) <|> try (return () <* lineEnd)+ patternEnd = try (void (char '$') <* requestOptions <* lineEnd) <|> try (void lineEnd) pattern = manyTill (noneOf "#") (lookAhead patternEnd) options = option '$' (char '$') *> requestOptions comment :: Parser Record comment = Comment <$> (separatorLine <|> commentText) where commentText = char '!' *> many notLineEnd- separatorLine = lookAhead lineEnd *> return ""+ separatorLine = lookAhead lineEnd $> "" unknown :: Parser Record unknown = Error "Record type detection failed" <$ skipMany notLineEnd@@ -130,7 +134,7 @@ unknownOption = manyPerm $ try optionName requestOption :: String -> Parser All-requestOption name = All <$> option True (char '~' *> return False) <* checkOptionName name+requestOption name = All <$> option True (char '~' $> False) <* checkOptionName name @@ -151,14 +155,14 @@ capitalize [] = "" capitalize (x:xs) = toUpper x:(toLower<$>xs) ws = split "-"- asOptionName = join.liftA capitalize.ws+ asOptionName = capitalize <=< ws checkOptionName :: String -> Parser () checkOptionName name = do t <- optionName when (name /= t) (pzero <?> "option type") domain :: Parser Domain-domain = join <$> intersperse "." <$> parts+domain = join . intersperse "." <$> parts where parts = sepBy1 domainPart (char '.') domainPart = many1 (alphaNum <|> char '-')@@ -196,10 +200,10 @@ noRestrictions :: Restrictions a noRestrictions = Restrictions Nothing [] -fixRestrictions :: (Eq a) => Restrictions a -> Restrictions a+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 $ nub p) (nub n)+ deduplicate (Restrictions (Just p) n) = Restrictions (Just $ nubOrd p) (nubOrd n) deduplicate a = a
src/Main.hs view
@@ -8,6 +8,7 @@ import ProgramOptions as Options import System.Environment import Templates+import Control.Monad import Data.Time.Clock import Network.HTTP.Conduit import Network.URI@@ -25,7 +26,7 @@ processSources :: Options -> String -> [SourceInfo]-> IO () processSources options taskFile sources = do manager <- newManager tlsManagerSettings- (parsed, sourceInfo) <- unzip <$> mapM (parseSource manager) sources+ (parsed, sourceInfo) <- mapAndUnzipM (parseSource manager) sources let parsed' = concat parsed sourceInfoText = showInfo sourceInfo optionsText = logOptions options@@ -33,7 +34,7 @@ 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 parsed'+ 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."@@ -62,7 +63,7 @@ setForeignEncoding utf8 now <- getCurrentTime args <- getArgs- (options@(Options printVersion _ _ taskFile _ _ forced), urls) <- parseOptions args+ (options@(Options printVersion _ _ taskFile _ _ _ forced), urls) <- parseOptions args (options', task) <- do fileExists <- doesFileExist taskFile if fileExists@@ -78,10 +79,12 @@ Nothing -> writeError "no input specified" (Just task') -> do let sources = Source.readLogInfos task'- if forced || or (infoExpired now <$> sources)+ if forced || any (infoExpired now) sources then processSources options' taskFile sources else putStrLn "all sources are up to date"-+ debug = _debugLevel options+ when (debug > DebugLevel 0) $+ putStrLn $ concat ["Debug level '", show debug, "'."] action now' <- getCurrentTime putStrLn $ concat ["Execution done in ", show $ diffUTCTime now' now, " seconds."]
src/Network.hs view
@@ -4,7 +4,6 @@ where import Network.HTTP.Conduit-import Control.Monad (liftM) import Data.Text.Lazy.Encoding import Data.Text.Lazy import Control.Exception@@ -16,7 +15,7 @@ req <- parseUrlThrow url -- parseUrl let req' = req -- let req' = req {responseTimeoutMicro = Just 15000000}- result <- try $ liftM responseBody $ httpLbs req' manager+ result <- try (responseBody <$> httpLbs req' manager) case result of Left e@(HttpExceptionRequest _ (ConnectionFailure _)) -> -- Left e@(FailedConnectionException _ _) ->
src/OptionsConverter.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE StrictData #-}+ module OptionsConverter ( HeaderFilters, Filter (..),@@ -7,6 +9,7 @@ ) where import InputParser import Control.Monad+import Data.Containers.ListUtils import Data.List import Data.Maybe import Data.String.Utils (replace)@@ -70,7 +73,7 @@ checkPassthrough :: RequestOptions -> Bool checkPassthrough RequestOptions {_requestType = (Restrictions positive _) }- = fromMaybe False $ (not . null . intersect [Subdocument, Popup]) <$> positive+ = maybe False (not . null . intersect [Subdocument, Popup]) positive acceptFilter, contentTypeFilter, requestedWithFilter, refererFilter :: FilterFabrique @@ -85,13 +88,13 @@ positivePart = positive >>= convert True result@(code, regex) = mconcat $ catMaybes [positivePart, negativePart] orEmpty = (policy == Unblock) && isNothing positive- emptyPositive = not . any (`notElem` (fromMaybe "" $ fst <$> negativePart)) . fst <$> positivePart+ emptyPositive = not . any (`notElem` maybe "" fst negativePart) . fst <$> positivePart convert _ [] = Nothing convert include requestTypes | null code' = Nothing | otherwise = Just (code', regex')- where contentTypes' = nub $ requestTypes >>= contentTypes include- code' = sort $ (head . dropWhile (`elem` "/(?:x-)")) <$> contentTypes'+ where contentTypes' = nubOrd $ requestTypes >>= contentTypes include+ code' = sort $ head . dropWhile (`elem` "/(?:x-)") <$> contentTypes' regex' = lookahead contentTypes' "[\\s\\w]*" include acceptFilter excludePattern options = case contentTypeFilter excludePattern options of@@ -109,9 +112,9 @@ result | Xmlhttprequest `elem` negative = Just False | Xmlhttprequest `elem` fromMaybe [] positive = Just True | hasContentTypes False negative- && fromMaybe True (not . hasContentTypes True <$> positive) = Just True+ && maybe True (not . hasContentTypes True) positive = Just True | otherwise = Nothing- hasContentTypes include = not . all null . fmap (contentTypes include)+ hasContentTypes include = not . all (null . contentTypes include) refererFilter policy RequestOptions{ _thirdParty = thirdParty, _domain = Restrictions positive negative }
src/ParsecExt.hs view
@@ -39,7 +39,7 @@ type CasesParser st r = RWST () [r] String (StateParser st) optionMaybeTry :: StateParser st a -> StateParser st (Maybe a)-optionMaybeTry p = liftM Just (mapStateT try p) <|> return Nothing+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
+ src/ParserExtTests.hs view
@@ -0,0 +1,122 @@+module ParserExtTests (+testParsecExt,+testParseMorse,+encodeMorse+) where+import Utils+import ParsecExt+import Control.Applicative hiding (many)+import Text.ParserCombinators.Parsec hiding ((<|>),State)+import Data.List+import Data.Maybe+import Control.Monad.State++---------------------------------------------------------------------------------------------+------------------------- parsec ext usage samples ------------------------------------------+---------------------------------------------------------------------------------------------++type ExampleCase = ([String], String, String)++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+++testParsecExt :: Either ParseError [([String], String, String)]+testParsecExt = parse (cases parsersChain <* string "$$") "x" "abebz12$$"++testParseMorse :: Either ParseError [String]+testParseMorse = parseMorse "......-...-..---"++--------------------------------------------------------------------------------+--- Morse chars parsing: parse "......-...-..---" in all possible ways ---------+--------------------------------------------------------------------------------++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')]++morseCharCodes :: [String]+morseCharCodes = fst <$> morseChars++-- HELLO = "......-...-..---"+encodeMorse :: String -> String+encodeMorse s = fst =<< mapMaybe code s+ 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+++-- 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]++morseStepParser :: [String] -> Parser String+morseStepParser [] = pzero+morseStepParser [step] = string step+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 ""))+++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
src/PatternConverter.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE StrictData #-}+ module PatternConverter ( makePattern, parseUrl@@ -38,10 +40,10 @@ _ -> changeFirst.changeLast $ host where changeLast [] = []- changeLast ('.' : '*' : [])+ changeLast ['.', '*'] | query' == "" = "." | otherwise = ".*"- changeLast ('*' : '.' : [])+ changeLast ['*', '.'] | query' == "" = "*." | otherwise = "*.*" changeLast [lst]@@ -97,7 +99,7 @@ let raw = makeUrls <$> bindStart <*> cases urlParts <*> bindEnd in parse (join <$> (fmap.fmap) postfilter raw) "url" where- makeUrls start mid end = makeUrl <$> pure start <*> mid <*> pure end+ makeUrls start mid end = (makeUrl start <$> mid) <*> pure end makeUrl start (proto, host, query) end = UrlPattern start proto (trimTrailingNul host) query end False bindStart = (try (Soft <$ string "||") <|> try (Hard <$ string "|") <|> return None) <?> "query start"@@ -108,8 +110,8 @@ trimTrailingNul :: String -> String trimTrailingNul [] = [] trimTrailingNul (c:cs)- | cs == [] && c == '\0' = []- | otherwise = c : trimTrailingNul(cs)+ | null cs && c == '\0' = []+ | otherwise = c : trimTrailingNul cs hostChar :: Parser Char hostChar = alphaNum <|> oneOf ".-:"
src/PolicyTree.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE StrictData #-}+ module PolicyTree ( NodePolicy (..), DomainTree (..),
src/ProgramOptions.hs view
@@ -1,21 +1,33 @@+{-# LANGUAGE StrictData #-}+ module ProgramOptions ( Options(..),+DebugLevel(DebugLevel), fillFromLog, parseOptions, logOptions, writeError, versionText ) where+import Paths_adblock2privoxy (version) import Control.Monad.State import Control.Applicative hiding (many) import Text.ParserCombinators.Parsec hiding ((<|>),State,Line) import System.Console.GetOpt-import System.FilePath-import Paths_adblock2privoxy (version)+import System.FilePath ( (</>) ) import Data.Version (showVersion) +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")+ data Options = Options { _showVersion :: Bool , _privoxyDir :: FilePath@@ -23,6 +35,7 @@ , _taskFile :: FilePath , _cssDomain :: String , _useHTTP :: Bool+ , _debugLevel :: DebugLevel , _forced :: Bool } @@ -46,6 +59,10 @@ , 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")@@ -59,14 +76,14 @@ parseOptions argv = case getOpt Permute options argv of (opts,nonOpts,[] ) ->- case foldl (flip id) emptyOptions opts of- Options False "" _ "" _ _ _ -> writeError "Privoxy dir or task file should be specified.\n"+ 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@(Options _ privoxyDir@(_:_) "" _ _ _ _ _) = setDefaults opts{ _webDir = privoxyDir }+ setDefaults opts@(Options _ privoxyDir _ "" _ _ _ _) = setDefaults opts{ _taskFile = privoxyDir </> "ab2p.task" } setDefaults opts = opts versionText :: String@@ -96,11 +113,11 @@ endMark = "------- end ------" emptyOptions :: Options-emptyOptions = Options False "" "" "" "" False False+emptyOptions = Options False "" "" "" "" False (DebugLevel 0) False fillFromLog :: Options -> [String] -> Options-fillFromLog existing lns = execState (sequence $ parseLogOptions <$> lns') existing+fillFromLog existing lns = execState (mapM parseLogOptions lns') existing where lns' = filter (not.null) $ takeWhile (/= endMark).dropWhile (/= startMark) $ lns
src/SourceInfo.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE StrictData #-}+ module SourceInfo ( SourceInfo(_url),@@ -56,7 +59,7 @@ = updated { _expired = infoExpired now updated } where initial = old { _lastUpdated = now }- updated = execState (sequence $ parseInfo . lineComment <$> take 50 lns) initial+ updated = execState (mapM (parseInfo . lineComment) (take 50 lns)) initial makeInfo :: String -> SourceInfo makeInfo url = emptySourceInfo { _url = url }@@ -65,7 +68,7 @@ readLogInfos lns = chunkInfo <$> chunks where chunks = filter (not.null) . split [separator] . takeWhile (/= endMark) $ lns- chunkInfo chunk = execState (sequence $ parseInfo <$> chunk) emptySourceInfo+ chunkInfo chunk = execState (mapM parseInfo chunk) emptySourceInfo infoExpired :: UTCTime -> SourceInfo -> Bool infoExpired now (SourceInfo _ _ _ _ lastUpdated expires _ _ ) =@@ -81,9 +84,9 @@ 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 = (\x -> case x of- Just time -> info{_lastUpdated = time}- Nothing -> info)+ 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})
src/Statistics.hs view
@@ -4,14 +4,13 @@ import qualified Data.Map as Map import InputParser import Data.Maybe-import Control.Applicative import Control.Monad import Control.Monad.State type Stat = Map.Map String Int collectStat :: [Line] -> [String]-collectStat = liftA resultLine . Map.toAscList . foldr getStat Map.empty+collectStat = fmap resultLine . Map.toAscList . foldr getStat Map.empty where resultLine (name, value) = concat [name, ": ", show value]
src/Task.hs view
@@ -16,9 +16,9 @@ errorLine _ = [] in do outFile <- openFile filename WriteMode- _ <- mapM (hPutStrLn outFile) info- _ <- sequence $ hPutStrLn outFile <$> statistics- _ <- sequence $ hPutStrLn outFile <$> (lns >>= errorLine)+ mapM_ (hPutStrLn outFile) info+ mapM_ (hPutStrLn outFile) statistics+ mapM_ (hPutStrLn outFile) (lns >>= errorLine) hClose outFile readTask :: String -> IO [String]
src/Templates.hs view
@@ -3,12 +3,13 @@ import Paths_adblock2privoxy import System.FilePath ((</>)) import Data.String.Utils (replace, startswith)+import Data.Foldable blockCss, ab2pPrefix, actionsFilePrefix, filtersFilePrefix :: String blockCss = "{display:none!important;visibility:hidden!important}" ab2pPrefix = "ab2p-"-actionsFilePrefix = "#AbBlock generated actions -- don't edit --"-filtersFilePrefix = "#AbBlock generated filters -- don't edit --"+actionsFilePrefix = "#AdBlock generated actions -- don't edit --"+filtersFilePrefix = "#AdBlock generated filters -- don't edit --" terminalActionSwitch :: Bool -> BlockMethod -> String terminalActionSwitch True Request =@@ -30,7 +31,7 @@ cssProtocol :: Bool -> String cssProtocol useHTTP- | useHTTP == True = "http"+ | useHTTP = "http" | otherwise = "https" writeTemplateFiles :: String -> String -> Bool -> IO ()@@ -43,10 +44,10 @@ 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 = ""+ | 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)]+ -- | otherwise = foldl' replace' line [("[?CSS_DOMAIN]", ""), ("[?CSS_DOMAIN_DEBUG]", "# "), ("[CSS_DOMAIN]", cssDomain), ("[CSS_PROTOCOL]", cssProtocol useHTTP)] copySystem file = do dataDir <- getDataDir
src/UrlBlocker.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE StrictData #-}+ module UrlBlocker ( BlockMethod(..), TaggerType(..),@@ -47,7 +49,7 @@ do outFile <- openFile filename WriteMode hSetEncoding outFile utf8 hPutStrLn outFile header- _ <- mapM (hPutStrLn outFile) $ ('#':) <$> info+ mapM_ (hPutStrLn outFile) $ ('#' :) <$> info hPutStrLn outFile $ intercalate "\n\n" $ show <$> content hClose outFile @@ -58,10 +60,10 @@ cmpPolicy node1 node2 = compare (_policy node1) (_policy node2) blockLines = lns >>= blockLine where- blockLine (Line position (RequestBlock policy pattern options))+ blockLine (Line position (RequestBlock policy pttrn options)) = filteringNodes policy (errorToPattern expandedPatterns) options where- expandedPatterns = makePattern (_matchCase options) <<$> parseUrl pattern+ expandedPatterns = makePattern (_matchCase options) <<$> parseUrl pttrn sourceText = recordSourceText position errorToPattern (Left parseError) = ["# ERROR: " ++ sourceText ++ " - " ++ show parseError] errorToPattern (Right patterns') = ("# " ++ sourceText) : patterns'@@ -124,7 +126,7 @@ foundTypes <- filter (== singleType) <$> _positive requestType foundType <- listToMaybe foundTypes return requestOptions {_requestType = requestType { _positive = Just [foundType] } }- optionsToNodes options = collectNodes patterns <$> headerFilters policy 2 <$> options+ optionsToNodes options = collectNodes patterns . headerFilters policy 2 <$> options nestedOrRegular True = Nested nestedOrRegular False = Regular collectNodes :: [Pattern] -> Maybe HeaderFilters -> BlockMethod -> [FilteringNode]@@ -207,16 +209,18 @@ 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') tagret) = forwardRegex headerName (_regex filter') ":" "" tagret- forward (Forward Nothing tagret) = forwardRegex "" "" "" "" tagret+ 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 tagret- = let (modifier, lookahead' : additionalLines)- | '\n' `elem` expression = ("i", split "\n" expression) -- the case for third-party- | otherwise = ("Ti", [expression])+ 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, tagret, "@", modifier]]+ [join ["s@^", header, lookahead', value, ".*@", tagPrefix, target, "@", modifier]] instance Named Bool where name True = "+"
templates/ab2p.system.action view
@@ -1,4 +1,4 @@-#AbBlock system actions -- don't edit --+#AdBlock system actions -- don't edit -- {+set-image-blocker{blank} \ [?CSS_DOMAIN] +filter{ab2p-elemhide-filter} \
templates/ab2p.system.filter view
@@ -1,4 +1,4 @@-#AbBlock system filters -- don't edit --+#AdBlock system filters -- don't edit -- SERVER-HEADER-TAGGER: ab2p-block-s