diff --git a/README.rst b/README.rst --- a/README.rst +++ b/README.rst @@ -201,5 +201,5 @@ Contribution ------------ -* Clone repository from http://projects.zubr.me/adblock2privoxy.git. -* `Report bugs `_ +* Clone repository from https://github.com/essandess/adblock2privoxy.git. +* `Report bugs `_ diff --git a/adblock2privoxy.cabal b/adblock2privoxy.cabal --- a/adblock2privoxy.cabal +++ b/adblock2privoxy.cabal @@ -1,10 +1,10 @@ name: adblock2privoxy -version: 1.4.2 +version: 2.0.0 cabal-version: >= 1.10 build-type: Simple tested-with: - GHC==7.10.3 -author: Alexey Zubritsky + GHC==8.4.3 +author: Alexey Zubritsky , Steven Thomas Smith data-files: templates/ab2p.system.action, templates/ab2p.system.filter @@ -20,10 +20,10 @@ distribution/debbuild/DEBIAN/control distribution/makeDeb.sh license: GPL-3 -maintainer: Alexey Zubritskiy +maintainer: Steven Thomas Smith license-file: LICENSE stability: stable -homepage: https://projects.zubr.me/wiki/adblock2privoxy +homepage: https://github.com/essandess/adblock2privoxy category: Web synopsis: Convert adblock config files to privoxy format description: @@ -101,6 +101,6 @@ source-repository this type: git - location: ​http://projects.zubr.me/adblock2privoxy.git + location: ​https://github.com/essandess/adblock2privoxy.git subdir: adblock2privoxy - tag: 1.4.2 + tag: 2.0.0 diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,10 @@ +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 diff --git a/distribution/debbuild/DEBIAN/control b/distribution/debbuild/DEBIAN/control --- a/distribution/debbuild/DEBIAN/control +++ b/distribution/debbuild/DEBIAN/control @@ -2,8 +2,8 @@ Version: 1.4.2 Depends: libgmp10 Architecture: #ARCH# -Maintainer: Alexey Zubritskiy -Homepage: https://projects.zubr.me/wiki/adblock2privoxy +Maintainer: Alexey Zubritskiy , Steven Thomas Smith +Homepage: https://github.com/essandess/adblock2privoxy Section: web Priority: extra Recommends: privoxy, nginx diff --git a/distribution/rpmbuild/SPECS/adblock2privoxy.spec b/distribution/rpmbuild/SPECS/adblock2privoxy.spec --- a/distribution/rpmbuild/SPECS/adblock2privoxy.spec +++ b/distribution/rpmbuild/SPECS/adblock2privoxy.spec @@ -1,12 +1,12 @@ Name: adblock2privoxy -Version: 1.4.2 +Version: 2.0.0 Release: 1%{?dist} Summary: Convert adblock config files to privoxy format License: GPL-3 -URL: https://projects.zubr.me/wiki/adblock2privoxy -Source0: http://hackage.haskell.org/package/adblock2privoxy-1.4.2/adblock2privoxy-1.4.2.tar.gz -Vendor: Alexey Zubritskiy +URL: https://github.com/essandess/adblock2privoxy +Source0: http://hackage.haskell.org/package/adblock2privoxy-2.0.0/adblock2privoxy-2.0.0.tar.gz +Vendor: Alexey Zubritskiy , Steven Thomas Smith Group: Web BuildRequires: stack diff --git a/man/man1/adblock2privoxy.1 b/man/man1/adblock2privoxy.1 --- a/man/man1/adblock2privoxy.1 +++ b/man/man1/adblock2privoxy.1 @@ -242,6 +242,6 @@ .IP "6)" 3 Restart privoxy and apache to load updated configs .PP -Clone repository from +Clone repository from .SH AUTHORS -Alexey Zubritsky . +Alexey Zubritsky , Steven Thomas Smith . diff --git a/src/ElementBlocker.hs b/src/ElementBlocker.hs --- a/src/ElementBlocker.hs +++ b/src/ElementBlocker.hs @@ -31,35 +31,57 @@ cont <- getDirectoryContents path _ <- sequence $ removeOld <$> cont createDirectoryIfMissing True debugPath - writeBlockTree path debugPath rulesTree - writePatterns filteredInfo (path "ab2p.common.css") (debugPath "ab2p.common.css") flatPatterns + -- writeBlockTree path debugPath rulesTree + writeBlockTree path rulesTree + writePatterns_with_debug filteredInfo (path "ab2p.common.css") (debugPath "ab2p.common.css") 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 -> String -> BlockedRulesTree -> IO () + -- writeBlockTree normalNodePath debugNodePath (Node name patterns children) = + writeBlockTree :: String -> BlockedRulesTree -> IO () + writeBlockTree normalNodePath (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 + -- 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 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 :: [String] -> String -> String -> [Pattern] -> IO () - writePatterns _ _ _ [] = return () - writePatterns info' normalFilename debugFilename patterns = + -- debugFilename = debugPath "ab2p.css" + writePatterns_with_debug :: [String] -> String -> String -> [Pattern] -> IO () + writePatterns_with_debug _ _ _ [] = return () + writePatterns_with_debug info' normalFilename debugFilename 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' + 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 diff --git a/src/Network.hs b/src/Network.hs --- a/src/Network.hs +++ b/src/Network.hs @@ -13,11 +13,13 @@ downloadHttp :: Manager -> Int -> String -> IO String downloadHttp manager retries url = do putStrLn $ "load " ++ url ++ " (" ++ show retries ++ " more attempts)..." - req <- parseUrl url - let req' = req {responseTimeout = Just 15000000} + req <- parseUrlThrow url -- parseUrl + let req' = req + -- let req' = req {responseTimeoutMicro = Just 15000000} result <- try $ liftM responseBody $ httpLbs req' manager case result of - Left e@(FailedConnectionException _ _) -> + 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/PatternConverter.hs b/src/PatternConverter.hs --- a/src/PatternConverter.hs +++ b/src/PatternConverter.hs @@ -36,17 +36,25 @@ "" -> "" _ -> changeFirst.changeLast $ host where - changeLast [] = [] + changeLast [] = [] + changeLast ('.' : '*' : []) + | query' == "" = "." + | otherwise = ".*" + changeLast ('*' : '.' : []) + | query' == "" = "*." + | otherwise = "*.*" changeLast [lst] | lst == '|' || lst `elem` hostSeparators = [] - | lst == '*' || lst == '\0' = "*." + | lst == '*' && query' == "" = "*." + | lst == '*' && query' /= "" = "*" + | lst == '.' = "." | otherwise = lst : "*." changeLast (c:cs) = c : changeLast cs changeFirst [] = [] changeFirst (first:cs) | first == '*' = '.' : '*' : cs - | bindStart == Hard || proto /= "" = first : cs + | first == '.' || bindStart == Hard || proto /= "" = first : cs | bindStart == Soft = '.' : first : cs | otherwise = '.' : '*' : first : cs @@ -60,20 +68,21 @@ _ -> replaceQuery start other (bindStart == None && host == "") where replaceQuery c cs openStart = replaceFirst c openStart ++ (join . map replaceWildcard $ cs) ++ queryEnd - replaceFirst '*' _ = ".*" + {- 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 "(.*" ++ replaceWildcard c ++ ")?" + then "(?:(*PRUNE).*?" ++ replaceWildcard c ++ ")?" else "" | otherwise = if openStart - then ".*" ++ replaceWildcard c + then "(*PRUNE).*?" ++ replaceWildcard c else replaceWildcard c queryEnd = if bindEnd == None then "" else "$" replaceWildcard c | c == '^' = "[^\\w%.-]" - | c == '*' = ".*" + | c == '*' = "(*PRUNE).*?" | c `elem` special = '\\' : [c] | otherwise = [c] where special = "?$.+[]{}()\\|" -- also ^ and * are special @@ -88,13 +97,19 @@ in parse (join <$> (fmap.fmap) postfilter raw) "url" where makeUrls start mid end = makeUrl <$> pure start <*> mid <*> pure end - makeUrl start (proto, host, query) end = UrlPattern start proto host query end False + 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" 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) + trimTrailingNul :: String -> String + trimTrailingNul [] = [] + trimTrailingNul (c:cs) + | cs == [] && c == '\0' = [] + | otherwise = c : trimTrailingNul(cs) + hostChar :: Parser Char hostChar = alphaNum <|> oneOf ".-:" @@ -158,7 +173,7 @@ else do lift $ skipMany $ char '*' --skip leading * if presented - name <- lift $ many protocolChar + name <- lift $ many1 protocolChar sep <- lift $ many $ oneOf hostSeparators let chars = name ++ replace "^" "//" sep -- concatenate input and expand separator wildcard nextChar <- lift $ lookAhead anyChar diff --git a/src/ProgramOptions.hs b/src/ProgramOptions.hs --- a/src/ProgramOptions.hs +++ b/src/ProgramOptions.hs @@ -72,7 +72,7 @@ writeError msg = ioError $ userError $ msg ++ "\n" ++ usageInfo header options where header = versionText ++ - "\nSee home page for more details and updates: http://projects.zubr.me/wiki/adblock2privoxy\n" ++ + "\nSee home page for more details and updates: https://github.com/essandess/adblock2privoxy\n" ++ "Usage: adblock2privoxy [OPTION...] [URL...]" diff --git a/src/SourceInfo.hs b/src/SourceInfo.hs --- a/src/SourceInfo.hs +++ b/src/SourceInfo.hs @@ -11,6 +11,7 @@ import Control.Monad.State import Control.Applicative hiding (many) import Text.ParserCombinators.Parsec hiding ((<|>),State,Line) +import Data.List import Data.Time.Clock import Data.Time.Calendar --import System.Locale @@ -90,7 +91,8 @@ *> skipMany (char ' ') *> many1 anyChar) expiresParser = (\n unit -> info{_expires = unit * read n}) <$> (string "Expires: " *> many1 digit) <*> (24 <$ string " days" <|> 1 <$ string " hours") - versionParser = (\x -> info{_version = read x}) <$> (string "Version: " *> many1 digit) + 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) diff --git a/src/Utils.hs b/src/Utils.hs --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module Utils ( Struct2 (..), Struct3 (..), @@ -57,9 +58,18 @@ zipListM :: [a] -> ZipListM a zipListM = ZipListM . ZipList +#if (MIN_VERSION_base(4,11,0)) +instance Semigroup a => Semigroup (ZipListM a) where + x <> y = (<>) <$> x <*> y +#endif + instance Monoid a => Monoid (ZipListM a) where mempty = pure mempty +#if (MIN_VERSION_base(4,11,0)) + mappend = (<>) +#else mappend x y = mappend <$> x <*> y +#endif class Struct2 f where struct2 :: a1 -> a2 -> f a1 a2 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,7 +1,7 @@ # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) -resolver: lts-5.2 +resolver: lts-12.9 # Local packages, usually specified by relative directory name packages: diff --git a/templates/ab2p.system.action b/templates/ab2p.system.action --- a/templates/ab2p.system.action +++ b/templates/ab2p.system.action @@ -26,7 +26,8 @@ {-block} TAG:^ab2p-unblock-s$ -#workaround for gzip handling privoxy bugs -{ +prevent-compression } - *.yahoo.com - *.amazon.com +# Omit per GitHub issue #7 +# workaround for gzip handling privoxy bugs +#{ +prevent-compression } +#.yahoo.com +#.amazon.com