diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/README.rst b/README.rst --- a/README.rst +++ b/README.rst @@ -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 diff --git a/adblock2privoxy.cabal b/adblock2privoxy.cabal --- a/adblock2privoxy.cabal +++ b/adblock2privoxy.cabal @@ -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 diff --git a/changelog b/changelog deleted file mode 100644 --- a/changelog +++ /dev/null @@ -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 diff --git a/man/man1/adblock2privoxy.1 b/man/man1/adblock2privoxy.1 --- a/man/man1/adblock2privoxy.1 +++ b/man/man1/adblock2privoxy.1 @@ -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 diff --git a/src/ElementBlocker.hs b/src/ElementBlocker.hs --- a/src/ElementBlocker.hs +++ b/src/ElementBlocker.hs @@ -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 diff --git a/src/InputParser.hs b/src/InputParser.hs --- a/src/InputParser.hs +++ b/src/InputParser.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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."] diff --git a/src/Network.hs b/src/Network.hs --- a/src/Network.hs +++ b/src/Network.hs @@ -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 _ _) -> diff --git a/src/OptionsConverter.hs b/src/OptionsConverter.hs --- a/src/OptionsConverter.hs +++ b/src/OptionsConverter.hs @@ -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 } diff --git a/src/ParsecExt.hs b/src/ParsecExt.hs --- a/src/ParsecExt.hs +++ b/src/ParsecExt.hs @@ -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 diff --git a/src/ParserExtTests.hs b/src/ParserExtTests.hs new file mode 100644 --- /dev/null +++ b/src/ParserExtTests.hs @@ -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 diff --git a/src/PatternConverter.hs b/src/PatternConverter.hs --- a/src/PatternConverter.hs +++ b/src/PatternConverter.hs @@ -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 ".-:" diff --git a/src/PolicyTree.hs b/src/PolicyTree.hs --- a/src/PolicyTree.hs +++ b/src/PolicyTree.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE StrictData #-} + module PolicyTree ( NodePolicy (..), DomainTree (..), diff --git a/src/ProgramOptions.hs b/src/ProgramOptions.hs --- a/src/ProgramOptions.hs +++ b/src/ProgramOptions.hs @@ -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 diff --git a/src/SourceInfo.hs b/src/SourceInfo.hs --- a/src/SourceInfo.hs +++ b/src/SourceInfo.hs @@ -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}) diff --git a/src/Statistics.hs b/src/Statistics.hs --- a/src/Statistics.hs +++ b/src/Statistics.hs @@ -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] diff --git a/src/Task.hs b/src/Task.hs --- a/src/Task.hs +++ b/src/Task.hs @@ -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] diff --git a/src/Templates.hs b/src/Templates.hs --- a/src/Templates.hs +++ b/src/Templates.hs @@ -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 diff --git a/src/UrlBlocker.hs b/src/UrlBlocker.hs --- a/src/UrlBlocker.hs +++ b/src/UrlBlocker.hs @@ -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 = "+" diff --git a/templates/ab2p.system.action b/templates/ab2p.system.action --- a/templates/ab2p.system.action +++ b/templates/ab2p.system.action @@ -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} \ diff --git a/templates/ab2p.system.filter b/templates/ab2p.system.filter --- a/templates/ab2p.system.filter +++ b/templates/ab2p.system.filter @@ -1,4 +1,4 @@ -#AbBlock system filters -- don't edit -- +#AdBlock system filters -- don't edit -- SERVER-HEADER-TAGGER: ab2p-block-s