adblock2privoxy 1.0.0 → 1.1.0
raw patch · 7 files changed
+193/−229 lines, 7 filesdep +http-conduitdep +networkdep +text
Dependencies added: http-conduit, network, text
Files
- adblock2privoxy.cabal +13/−10
- src/ElementBlocker.hs +3/−1
- src/Main.hs +75/−38
- src/ParserExtTests.hs +0/−125
- src/SourceInfo.hs +65/−34
- src/Statistics.hs +9/−21
- src/Task.hs +28/−0
adblock2privoxy.cabal view
@@ -1,5 +1,5 @@ name: adblock2privoxy-version: 1.0.0+version: 1.1.0 cabal-version: >= 1.6 build-type: Simple author: Alexey Zubritsky@@ -47,22 +47,25 @@ parsec-permutation, time >=1.4.0 && <1.5, old-locale >=1.0.0 && <1.1,- strict >=0.3.2 && <0.4+ strict >=0.3.2 && <0.4,+ network >=2.4.2 && <2.5,+ http-conduit,+ text >=0.11.3 && <0.12 ghc-options: -Wall other-modules: - InputParser,- ParsecExt,- Utils,- ParserExtTests, ElementBlocker,- PolicyTree,+ InputParser, OptionsConverter,+ ParsecExt, PatternConverter,- UrlBlocker,- Templates,+ PolicyTree, PopupBlocker,+ SourceInfo, Statistics,- SourceInfo+ Task,+ Templates,+ UrlBlocker,+ Utils source-repository this type: git
src/ElementBlocker.hs view
@@ -14,6 +14,7 @@ import System.Directory import qualified Templates import Control.Monad +import Data.String.Utils (startswith) type BlockedRulesTree = DomainTree [Pattern] @@ -26,12 +27,13 @@ writeElemBlock (ElemBlockData flatPatterns rulesTree) = do 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 - writePatterns info (path </> "ab2p.common.css") (debugPath </> "ab2p.common.css") flatPatterns + writePatterns filteredInfo (path </> "ab2p.common.css") (debugPath </> "ab2p.common.css") flatPatterns removeOld entry' = let entry = path </> entry' in do
src/Main.hs view
@@ -1,79 +1,116 @@ module Main where import InputParser-import System.IO import ElementBlocker import UrlBlocker import Text.ParserCombinators.Parsec hiding (Line, many, optional)-import Statistics+import Task import Control.Applicative hiding (many) import SourceInfo import System.Console.GetOpt import System.Environment-import Control.Monad-import Templates (writeTemplateFiles)-import Data.Time.Clock (getCurrentTime)+import Templates+import Data.Time.Clock +import Network.HTTP.Conduit+import Network.URI+import Data.Text.Lazy.Encoding+import Data.Text.Lazy (unpack)+import Network.Socket+import System.FilePath data Options = Options { _showVersion :: Bool , _privoxyDir :: FilePath , _webDir :: FilePath+ , _taskFile :: FilePath+ , _forced :: Bool } deriving Show options :: [OptDescr (Options -> Options)] options =- [ Option ['V'] ["version"]+ [ Option "v" ["version"] (NoArg (\ opts -> opts { _showVersion = True })) "show version number"- , Option ['p'] ["privoxyDir"]+ , Option "p" ["privoxyDir"] (ReqArg (\ f opts -> opts { _privoxyDir = f }) "PATH") "privoxy config output path (required)"- , Option ['w'] ["webDir"]+ , Option "w" ["webDir"] (ReqArg (\ f opts -> opts { _webDir = f }) "PATH") "css files output path (optional, privoxyDir is used by default)"+ , Option "t" ["taskFile"]+ (ReqArg (\ f opts -> opts { _taskFile = f })+ "PATH")+ "path to task file containing urls to process"+ , 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 foldl (flip id) (Options False [] []) opts of- Options False [] _ -> writeError "Privoxy dir is not specified.\n"- opts'@(Options _ privoxyDir []) -> return (opts'{_webDir = privoxyDir}, nonOpts)- opts' -> return (opts', nonOpts)+ case foldl (flip id) (Options False "" "" "" False) opts of+ Options False "" _ _ _ -> writeError "Privoxy dir is not specified.\n"+ opts' -> return (setDefaults opts', nonOpts) (_,_,errs) -> writeError $ concat errs- where - writeError msg = ioError $ userError $ msg ++ usageInfo header options- header = "Usage: adblock2privoxy [OPTION...] adblockFiles..."+ where+ setDefaults opts@(Options _ privoxyDir "" _ _) = setDefaults opts{ _webDir = privoxyDir }+ setDefaults opts@(Options _ privoxyDir _ "" _) = setDefaults opts{ _taskFile = privoxyDir </> "ab2p.task" }+ setDefaults opts = opts + +writeError :: String -> IO a+writeError msg = ioError $ userError $ msg ++ usageInfo header options+ where + header = "Usage: adblock2privoxy [OPTION...] [URL...]" +getResponse :: String -> IO String+getResponse url = withSocketsDo $ unpack . decodeUtf8 <$> simpleHttp url -processFiles :: String -> String -> [String] -> IO [()]-processFiles privoxyDir webDir filenames = do - let parseFile filename = do- putStrLn $ "parse " ++ filename- inputFile <- openFile filename ReadMode- text <- hGetContents inputFile- case parse adblockFile filename text of- Right parsed -> return (parsed, extractInfo parsed, inputFile)- Left msg -> return ([], NoInfo, inputFile) <$ putStrLn $ show msg- - (parsed, sourceInfo, handlers) <- unzip3 <$> mapM parseFile filenames- showInfo' <- showInfo <$> getCurrentTime +processSources :: String -> String -> String -> [SourceInfo]-> IO ()+processSources privoxyDir webDir taskFile sources = do + (parsed, sourceInfo) <- unzip <$> mapM parseSource sources let parsed' = concat parsed - info = (sourceInfo >>= showInfo') ++ ["------- end ------\n"] - stat privoxyDir info parsed'- elemBlock webDir info parsed'- urlBlock privoxyDir info parsed'+ infoText = showInfos sourceInfo + writeTask taskFile infoText parsed'+ elemBlock webDir infoText parsed'+ urlBlock privoxyDir infoText parsed' writeTemplateFiles privoxyDir- sequence $ hClose <$> handlers+ where + parseSource sourceInfo = do+ let + url = _url sourceInfo+ loader = if isURI url then getResponse else readFile+ putStrLn $ "parse " ++ url+ text <- loader url+ now <- getCurrentTime+ case parse adblockFile url text of+ Right parsed -> + let sourceInfo' = updateInfo now parsed sourceInfo + url' = _url sourceInfo'+ in if url == url' + then return (parsed, sourceInfo')+ else parseSource sourceInfo'+ Left msg -> return ([], sourceInfo) <$ putStrLn $ show msg main::IO()-main = do +main = do + now <- getCurrentTime args <- getArgs- (opts, filenames) <- parseOptions args- when (_showVersion opts) $ putStrLn "adblock2privoxy version 1.0"- when (not . null $_privoxyDir opts) $- do _ <- processFiles (_privoxyDir opts) (_webDir opts) filenames- putStrLn "done"+ (Options showVersion privoxyDir webDir taskFile forced, urls) <- parseOptions args+ let acton+ | showVersion = putStrLn "adblock2privoxy version 1.0"+ | not . null $ urls + = processSources privoxyDir webDir taskFile (makeInfo <$> urls)+ | not . null $ taskFile + = do task <- readTask taskFile+ let sources = logInfo task + if forced || or (infoExpired now <$> sources) + then processSources privoxyDir webDir taskFile sources+ else putStrLn "all sources are up to date"+ | otherwise = writeError "no input specified"+ acton+ now' <- getCurrentTime+ putStrLn $ concat ["done in ", show $ diffUTCTime now' now, " seconds"]
− src/ParserExtTests.hs
@@ -1,125 +0,0 @@-module ParserExtTests (-parseMorse,-encodeMorse-) where-import Utils-import ParsecExt-import Control.Applicative hiding (many)-import Text.ParserCombinators.Parsec hiding ((<|>),State)-import Control.Monad-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 = join $ fst <$> catMaybes (code <$> s)- where code c = find (\pair -> snd pair == c) morseChars- -decodeMorse :: [String] -> String-decodeMorse ss = snd <$> catMaybes (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 = case acc' of- Nothing -> ""- Just val -> val- 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.fmap) postProcess $ parseMorseRaw "x" s- where - parseMorseRaw = parse (cases $ morseParsers) - postProcess = decodeMorse.toLists - toLists = (takeWhile $ not.null) . getZipListM -
src/SourceInfo.hs view
@@ -1,8 +1,11 @@ module SourceInfo (-SourceInfo(..),-extractInfo,-showInfo+SourceInfo(_url),+showInfos,+updateInfo,+makeInfo,+logInfo,+infoExpired ) where import InputParser import Control.Monad.State@@ -12,41 +15,70 @@ import Data.Time.Calendar import System.Locale import Data.Time.Format+import Data.Maybe (catMaybes)+import Data.String.Utils (split) -data SourceInfo = SourceInfo { _title, _filename, _license, _homepage :: String, - _lastUpdated :: UTCTime, _expires, _version :: Integer } | NoInfo+data SourceInfo = SourceInfo { _title, _url, _license, _homepage :: String, + _lastUpdated :: UTCTime, _expires, _version :: Integer, _expired :: Bool } emptySourceInfo :: SourceInfo-emptySourceInfo = SourceInfo "" "" "" "" (UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0) ) 72 0+emptySourceInfo = SourceInfo "" "" "" "" (UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0) ) 72 0 True -showInfo :: UTCTime -> SourceInfo -> [String] -showInfo _ NoInfo = ["----- a source skipped -----"]-showInfo now sourceInfo@(SourceInfo _ filename _ _ lastUpdated expires _) = - [concat ["----- source -----"]]- ++ optionalLine "Title: " _title- ++ [concat ["Filename: ", filename],- concat ["Last modified: ", formatTime defaultTimeLocale "%d %b %Y %H:%M %Z" lastUpdated],- concat ["Expires: ", show expires, " hours", expired]] - ++ optionalLine "Version: " _version- ++ optionalLine "License: " _license- ++ optionalLine "Homepage: " _homepage+separator :: String+separator = "----- source -----"++endMark :: String+endMark = "------- end ------"++showInfos :: [SourceInfo] -> [String] +showInfos sourceInfos = (sourceInfos >>= showInfo) ++ [endMark ++ "\n"]++showInfo :: SourceInfo -> [String] +showInfo sourceInfo@(SourceInfo _ url _ _ lastUpdated expires _ expired) = + catMaybes [ Just separator,+ optionalLine "Title: " _title,+ Just $ concat ["Url: ", url],+ Just $ concat ["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 - expired | (diffUTCTime now lastUpdated) > (fromInteger $ expires * 60 * 60) = " (expired)"- | otherwise = []- optionalLine caption getter | getter sourceInfo == getter emptySourceInfo = []- | otherwise = [concat [caption, show $ getter sourceInfo]] + expiredMark | expired = " (expired)"+ | otherwise = ""+ optionalLine caption getter | getter sourceInfo == getter emptySourceInfo = Nothing+ | otherwise = Just $ concat [caption, getter sourceInfo] -extractInfo :: [Line] -> SourceInfo-extractInfo lns@(Line RecordSource{_position = pos} _:_) - = execState (sequence $ lineInfo <$> take 50 lns) initial- where initial =emptySourceInfo { _filename = sourceName pos} -extractInfo _ = NoInfo+updateInfo :: UTCTime -> [Line] -> SourceInfo -> SourceInfo+updateInfo now lns old+ = updated { _expired = infoExpired now updated } + where + initial = old { _lastUpdated = now } + updated = execState (sequence $ parseInfo . lineComment <$> take 50 lns) initial+ +makeInfo :: String -> SourceInfo+makeInfo url = emptySourceInfo { _url = url } -lineInfo :: Line -> State SourceInfo ()-lineInfo (Line _ (Comment text)) = do+logInfo :: [String] -> [SourceInfo]+logInfo lns = chunkInfo <$> chunks+ where + chunks = filter (not.null) . split [separator] . takeWhile (/= endMark) $ lns+ chunkInfo chunk = execState (sequence $ parseInfo <$> chunk) emptySourceInfo++infoExpired :: UTCTime -> SourceInfo -> Bool+infoExpired now (SourceInfo _ _ _ _ lastUpdated expires _ _ ) = + diffUTCTime now lastUpdated > (fromInteger $ expires * 60 * 60)++lineComment :: Line -> String+lineComment (Line _ (Comment text)) = text+lineComment _ = ""++parseInfo :: String -> State SourceInfo ()+parseInfo text = do info <- get- let titleParser = (\x -> info{_title = x}) <$> (string "Title: " *> many1 anyChar)+ 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}@@ -57,12 +89,11 @@ <$> ((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")+ <$> (string "Expires: " *> many1 digit) <*> (24 <$ string " days" <|> 1 <$ string " hours") versionParser = (\x -> info{_version = read x}) <$> (string "Version: " *> many1 digit)- commentParser = skipMany (char ' ') *> - (try titleParser <|> try expiresParser <|> try versionParser + stringParser = skipMany (char ' ') *> + (try urlParser <|> try titleParser <|> try expiresParser <|> try versionParser <|> try licenseParser <|> try homepageParser <|> try lastUpdatedParser)- case parse commentParser "" text of+ case parse stringParser "" text of Left _ -> return () Right info' -> put info' -lineInfo _ = return ()
src/Statistics.hs view
@@ -1,31 +1,19 @@-module Statistics where+{-# LANGUAGE OverloadedStrings #-}+module Statistics (+ collectStat+)where import qualified Data.Map as Map import InputParser import Data.Maybe -import System.IO-import System.FilePath-import Control.Applicative ((<$>))+import Control.Applicative import Control.Monad.State type Stat = Map.Map String Int -stat :: String -> [String] -> [Line] -> IO ()-stat path info lns = - let result = collectStat lns - filename = path </> "ab2p.stat"- resultLine (name, value) = concat [name, ": ", show value] - errorLine (Line position (Error text)) - = [concat ["ERROR: ", recordSourceText position, " - ", text]]- errorLine _ = []- in do - outFile <- openFile filename WriteMode- _ <- mapM (hPutStrLn outFile) info- _ <- sequence $ hPutStrLn outFile . resultLine <$> Map.toAscList result- _ <- sequence $ hPutStrLn outFile <$> (lns >>= errorLine)- hClose outFile--collectStat :: [Line] -> Stat-collectStat = foldr getStat Map.empty+collectStat :: [Line] -> [String]+collectStat = liftA resultLine . Map.toAscList . foldr getStat Map.empty+ where+ resultLine (name, value) = concat [name, ": ", show value] increment :: String -> Stat-> Stat increment key = Map.insertWith (+) key 1
+ src/Task.hs view
@@ -0,0 +1,28 @@+module Task (+writeTask,+readTask+) where+import System.IO+import InputParser+import Statistics+import Control.Applicative ((<$>))++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 + outFile <- openFile filename WriteMode+ _ <- mapM (hPutStrLn outFile) info+ _ <- sequence $ hPutStrLn outFile <$> statistics + _ <- sequence $ hPutStrLn outFile <$> (lns >>= errorLine)+ hClose outFile++readTask :: String -> IO [String] +readTask path = do + result <- lines <$> readFile path+ return $ length result `seq` result --read whole file to allow its overwriting+