diff --git a/adblock2privoxy.cabal b/adblock2privoxy.cabal --- a/adblock2privoxy.cabal +++ b/adblock2privoxy.cabal @@ -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 diff --git a/src/ElementBlocker.hs b/src/ElementBlocker.hs --- a/src/ElementBlocker.hs +++ b/src/ElementBlocker.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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"] diff --git a/src/ParserExtTests.hs b/src/ParserExtTests.hs deleted file mode 100644 --- a/src/ParserExtTests.hs +++ /dev/null @@ -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 - diff --git a/src/SourceInfo.hs b/src/SourceInfo.hs --- a/src/SourceInfo.hs +++ b/src/SourceInfo.hs @@ -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 () diff --git a/src/Statistics.hs b/src/Statistics.hs --- a/src/Statistics.hs +++ b/src/Statistics.hs @@ -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 diff --git a/src/Task.hs b/src/Task.hs new file mode 100644 --- /dev/null +++ b/src/Task.hs @@ -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 +