Changeset dcd1d6c in adblock2privoxy


Ignore:
Timestamp:
Sep 7, 2013 4:04:15 PM (6 years ago)
Author:
zubr <a@…>
Branches:
master
Children:
96c17d9
Parents:
861fbae
Message:

elements blocker done

Files:
4 added
5 edited

Legend:

Unmodified
Added
Removed
  • AdBlock2Privoxy.cabal

    rb6b5fc1 rdcd1d6c  
    1313                   parsec, 
    1414                   parsec-permutation, 
    15                    mtl 
     15                   mtl, 
     16                   containers 
    1617  ghc-options:     -Wall 
    1718  other-modules:    
     
    2122                   Foo, 
    2223                   Utils, 
    23                    ParserExtTests 
     24                   ParserExtTests, 
     25                   PatternConvertor, 
     26                   ElementBlocker, 
     27                   PolicyTree 
    2428 
  • src/InputParser.hs

    r861fbae rdcd1d6c  
    44RequestOptions (..), 
    55Record (..), 
    6 Pattern 
     6Pattern, 
     7Domain, 
     8adblockFile 
    79) 
    810where 
     
    161163 
    162164lineSpaces :: Parser () 
    163 --lineSpaces = spaces 
    164165lineSpaces = skipMany (satisfy isLineSpace) <?> "white space" 
    165166    where isLineSpace c = c == ' ' || c == '\t' 
  • src/Main.hs

    rf7023f1 rdcd1d6c  
    99import Normalizer 
    1010import Utils 
     11import PolicyTree 
     12import ElementBlocker 
    1113 
    1214 
    1315filename :: String 
    14 --filename = "/home/alexey/Downloads/advblock.txt" 
    15 filename = "/home/alexey/Downloads/easylist.txt" 
    16 filename1 = "/home/alexey/Downloads/easylist1.txt" 
     16filename = "/home/alexey/Projects/AdBlock2Privoxy/testData" 
    1717 
    1818data Stat = Stat {total,comm,block,el::Int} deriving (Show) 
     
    2020getStat :: Line -> Stat-> Stat 
    2121getStat  (Line _ Comment) (Stat t c b e) = Stat (t + 1) (c + 1) b e 
    22 getStat  (Line _ (RequestBlock _ _ _)) (Stat t c b e) = Stat (t + 1) c (b + 1) e 
    23 getStat  (Line _ (ElementHide _ _ _)) (Stat t c b e) = Stat (t + 1) c b (e + 1)  
     22getStat  (Line _ RequestBlock {}) (Stat t c b e) = Stat (t + 1) c (b + 1) e 
     23getStat  (Line _ ElementHide {}) (Stat t c b e) = Stat (t + 1) c b (e + 1)  
    2424getStat  _ (Stat t c b e) = Stat (t + 1) c b e 
    2525 
     
    2727main = do 
    2828        inputFile <- openFile filename ReadMode 
    29         outFile <- openFile filename1 WriteMode 
    3029        text <- hGetContents inputFile 
    31         --(Right res) <- return $ (concatText <$> filter problems <$> parse adblockFile filename text) 
    32         parsed <- return $ (collectStat <$> parse adblockFile filename text) 
    33         putStr.show$parsed 
     30        parsed <- return $ parse adblockFile filename text 
     31        let res = case parsed of 
     32                        Right parsed' -> show $ elemBlockTree $ fixLines parsed' 
     33                        Left msg -> show msg 
     34        ---putStrLn $ show $ fixLines <$> parsed 
     35        putStrLn res 
    3436        hClose inputFile 
    35         hClose outFile 
    3637        putStrLn "done" 
    3738    where 
     
    3940        concatText = join . intersperse ('\n':[]) . map lineText 
    4041        collectStat = foldr getStat (Stat 0 0 0 0) 
    41         problems (Line _ Unknown) = True 
     42        problems (Line _ Error {}) = True 
    4243        problems _= False 
  • src/Normalizer.hs

    r861fbae rdcd1d6c  
    1 module Normalizer where 
     1module Normalizer ( 
     2--opa, 
     3fixLines 
     4) where 
    25import InputParser 
    36import Control.Applicative hiding (many) 
     
    58import Control.Monad.State 
    69import Data.List 
    7 import Data.String.Utils (replace) 
    8 import Data.Maybe 
    9 import Data.List.Utils (split) 
    10 import ParsecExt 
     10import Data.String.Utils (strip) 
    1111import Utils 
    12   
    13 opa s = case parseUrl s of 
    14         Left e -> putStrLn $ show e 
    15         Right urls -> putStrLn $ intercalate "\n" $ makePattern <$> urls   
     12import PatternConvertor 
     13 
    1614  
    1715fixLines :: [Line] -> [Line] 
     
    1917 
    2018fixLine :: Line -> [Line] 
    21 fixLine  (Line text (ElementHide                  restr  excl pattern))  
    22        = [Line text (ElementHide (fixRestrictions restr) excl pattern)] 
     19fixLine  (Line text (ElementHide                  restrDom  excl        pattern))  
     20       = [Line text (ElementHide (fixRestrictions restrDom) excl (strip pattern))] 
    2321  
    24 fixLine  (Line text                     requestBlock@(RequestBlock _ _ _))  
     22fixLine  (Line text                     requestBlock@(RequestBlock {}))  
    2523       =  Line text <$> fixRequestBlock requestBlock  
    2624          where     
    2725              fixRequestBlock      (RequestBlock excl                       pattern                  options) 
    28                              = case RequestBlock excl <<$> (fixBlockPattern pattern) $>> (fixOptions options) of 
     26                             = case RequestBlock excl <<$> fixBlockPattern pattern $>> fixOptions options of 
    2927                                    Right res     -> res 
    3028                                    Left  problem -> [Error $ show problem] 
     
    3533               
    3634              fixBlockPattern :: Pattern -> Either ParseError [Pattern] 
    37               fixBlockPattern pattern = makePattern <<$> (parseUrl pattern) 
     35              fixBlockPattern pattern = makePattern <<$> parseUrl pattern 
    3836                                                    
    39           
     37           
    4038fixLine a = [a] 
    4139 
    4240fixRestrictions :: (Eq a) => Restrictions a -> Restrictions a 
    43 fixRestrictions = annigilate.allowAll.deduplicate 
     41fixRestrictions = annigilate.deduplicate.allowAll 
    4442        where  
     43        allowAll (Restrictions (Just []) n) = Restrictions Nothing n 
     44        allowAll a = a 
    4545        deduplicate (Restrictions (Just p) n) = Restrictions (Just $ nub p) (nub n) 
    4646        deduplicate a = a 
    47         allowAll (Restrictions (Just []) n@(_:_)) = Restrictions Nothing n 
    48         allowAll a = a 
    4947        annigilate (Restrictions (Just p) n) =  
    5048                            let notN x = x `notElem` n 
     
    5351         
    5452 
    55 data SideBind = Hard | Soft | None deriving (Show, Eq)  
    5653 
    57 data UrlPattern = UrlPattern {  
    58                    _bindStart :: SideBind, 
    59                    _proto :: String, 
    60                    _host :: String, 
    61                    _query :: String, 
    62                    _bindEnd :: SideBind, 
    63                    _regex :: Bool } 
    64               deriving (Show) 
    65  
    66 makePattern :: UrlPattern -> Pattern 
    67 makePattern (UrlPattern bindStart proto host query bindEnd isRegex) =  if query' == "/"  
    68                                                                             then host'  
    69                                                                             else host' ++ query'  
    70     where  
    71         host' = case host of 
    72                     "" -> "" 
    73                     _  -> changeFirst.changeLast $ host 
    74                     where 
    75                     changeLast []     = [] 
    76                     changeLast [lst]   
    77                         | lst == '|' || lst `elem` hostSeparators   =  []       
    78                         | lst == '*' || lst == '\0'                 =  "*." 
    79                         | otherwise                                 =  lst : "*." 
    80                     changeLast (c:cs) = c : changeLast cs 
    81   
    82                     changeFirst []    = [] 
    83                     changeFirst (first:cs)  
    84                         | first == '*'                       =       '.' :  '*'  : cs 
    85                         | bindStart /= None || proto /= ""   =             first : cs       
    86                         | otherwise                          = '.' : '*' : first : cs 
    87                                      
    88         query' = case query of 
    89                     ""     -> "" 
    90                     (c:cs) -> if isRegex then '/' : query 
    91                               else replaceFirst c ++ (join . map replaceWildcard $ cs) ++ queryEnd  
    92                     where                   
    93                     replaceFirst '*' = "/.*" 
    94                     replaceFirst c 
    95                         | c == '/' || c == '^' = if openStart 
    96                                                  then "/(.*" ++ replaceWildcard c ++ ")?" 
    97                                                  else "/" 
    98                         | otherwise            = if openStart  
    99                                                  then "/.*" ++ replaceWildcard c 
    100                                                  else '/' : replaceWildcard c 
    101                         where  
    102                         openStart = bindStart == None && host == "" 
    103                      
    104                     queryEnd = if bindEnd == None then "" else "$" 
    105                                                        
    106                     replaceWildcard c 
    107                         | c == '^'         = "[^\\w%.-]" 
    108                         | c == '*'         = ".*" 
    109                         | c `elem` special = '\\' : [c] 
    110                         | otherwise        = [c] 
    111                         where special = "?$.+[]{}()\\|" -- also ^ and * are special 
    112                       
    113  
    114 hostSeparators :: String 
    115 hostSeparators = "^/" 
    116  
    117 parseUrl :: Pattern -> Either ParseError [UrlPattern] 
    118 parseUrl =   
    119     let  raw = makeUrls <$> bindStart <*> cases urlParts <*> bindEnd 
    120     in   parse (join <$> (fmap.fmap) postfilter raw) "url" 
    121     where 
    122         makeUrls start mid end = makeUrl <$> pure start <*> mid <*> pure end 
    123         makeUrl start (proto, host, query) end = UrlPattern start proto host query end False 
    124          
    125         bindStart = (try (Soft <$ string "||") <|> try (Hard <$ string "|") <|> return None) <?> "query start"  
    126         queryEnd = (char '|' <* eof) <|> ('\0' <$ eof) <|> (char '\0') <?> "query end" 
    127         bindEnd = (\c -> if c == '|' then Hard else None) <$> queryEnd 
    128         port = option False $ (many1 $ noneOf ":") *> char ':' *> (many1 (digit <|> char '*')) *> (optionMaybe $ oneOf "/^") *> (True <$ queryEnd) 
    129          
    130         hostChar :: Parser Char 
    131         hostChar = alphaNum <|> oneOf ".-:" 
    132          
    133         protocols :: [String] 
    134         protocols = ["https://", "http://"] 
    135          
    136         protocolsSeparator :: String 
    137         protocolsSeparator = ";" 
    138          
    139         protocolChar :: Parser Char 
    140         protocolChar = oneOf (delete '/' $ nub $ join protocols) 
    141          
    142         postfilter :: UrlPattern -> [UrlPattern] 
    143         postfilter url@(UrlPattern bs proto host query be _) = regular ++ regex ++ www 
    144             where  
    145                 regex = if     proto == ""  
    146                             && host == ""  
    147                             && "/" `isPrefixOf` query  
    148                             && length query > 2 
    149                             && "/" `isSuffixOf` query  
    150                             then  
    151                                 let query' = take (length query - 2) . drop 1 $ query 
    152                                 in [UrlPattern bs "" "" query' be True]  
    153                             else [] 
    154                 regular = let  
    155                              leftBound = bs /= None || proto /= "" 
    156                              rightBound = be /= None || query /= "" 
    157                              orphanQuery = leftBound && host == "" && query /= "" && not ("*" `isPrefixOf` query) 
    158                              duplicateHostStar = host == "*" 
    159                              hostHasDot = isJust $ find (\c -> c == '.' || c == '*') host 
    160                              firstLevelHost = not hostHasDot && leftBound && rightBound  
    161                              hasLegalPort = case parse port "host" host of 
    162                                                 Right val -> val 
    163                                                 _ -> False   
    164                              hasIllegalPort = not hasLegalPort && ":" `isInfixOf` host 
    165                           in if not (orphanQuery || duplicateHostStar || firstLevelHost || hasIllegalPort)  
    166                              then 
    167                                 let 
    168                                     query' = if "*" `isSuffixOf` host && query /= "" then '*' : query else query  
    169                                 in [url {_query = query'}]  
    170                              else [] 
    171                 www = case regular of 
    172                             [regular'] -> if    bs == Soft  
    173                                              && proto == "" 
    174                                              && host /= "" 
    175                                              && not ("*" `isPrefixOf` host) 
    176                                              && not ("." `isPrefixOf` host)  
    177                                           then [regular' {_host = "www." ++ host} ]  
    178                                           else [] 
    179                             _ -> []  
    180          
    181         urlParts :: [StringStateParser (String,String,String)] 
    182         urlParts = square3 proto (manyCases host) (oneCase query) 
    183             where           
    184                 append xs x = xs ++ [x] 
    185                 proto :: StringStateParser String 
    186                 proto = do 
    187                         masksString <- get 
    188                         case masksString of  
    189                             Nothing ->  
    190                                 do 
    191                                 put $ Just $ intercalate protocolsSeparator protocols 
    192                                 return "" --allow to skip proto 
    193                             Just masksString' ->  
    194                                 do 
    195                                 let masks = split protocolsSeparator masksString' 
    196                                 if null masks  
    197                                     then lift pzero -- no continuations available (parser have finished on previous iteration) 
    198                                     else  
    199                                         do 
    200                                         lift $ skipMany $ char '*' --skip leading * if presented 
    201                                         name <- lift $ many protocolChar 
    202                                         sep <- lift $ many $ oneOf hostSeparators 
    203                                         let chars = name ++ replace "^" "//" sep -- concatenate input and expand separator wildcard 
    204                                         nextChar <- lift $ lookAhead anyChar 
    205                                         let masks' = filterProtoMasks masks chars nextChar -- find possible continuations for current input 
    206                                         if null masks' || null chars 
    207                                             then lift pzero -- fail parser if no continuations or no chars read 
    208                                             else 
    209                                                 do 
    210                                                 put $ Just $ if isJust (find null masks')  -- if empty continuation found (i.e. parser finished) 
    211                                                                 then "" -- make no continuations available next time 
    212                                                                 else intercalate protocolsSeparator masks'   
    213                                                 return $ if nextChar == '*' then chars ++ "*" else chars 
    214                 host = try (append <$> many hostChar <*> char '*') <|> 
    215                        try (append <$> many1 hostChar <*> lookAhead separator) <?> "host" 
    216                 separator = (oneOf hostSeparators <|> queryEnd) <?> "separator" 
    217                 query = notFollowedBy (try $ string "//") *> manyTill anyChar (lookAhead (try queryEnd)) <?> "query" 
    218                  
    219                 filterProtoMasks :: [String] -> String -> Char -> [String] 
    220                 filterProtoMasks masks chars nextChar = mapMaybe filterProtoMask masks 
    221                     where filterProtoMask mask = if nextChar /= '*'  
    222                                     then if chars `isSuffixOf` mask 
    223                                          then Just "" 
    224                                          else Nothing  
    225                                     else let tailFound = find (chars `isPrefixOf`) (tails mask) 
    226                                          in drop (length chars) <$> tailFound  
    227                  
    22854         
    22955 
  • src/Utils.hs

    r861fbae rdcd1d6c  
    2020($>), 
    2121($>>), 
    22 ($>>>) 
     22($>>>), 
     23(.*.) 
    2324) where 
    2425import Control.Applicative hiding (many) 
     
    140141pure'' = pure.pure.pure 
    141142 
    142 infixl 4 <<$>, <<<$>, $>, $>>, $>>>, <<*>>, <<<*>>> 
     143infixl 4 .*., <<$>, <<<$>, $>, $>>, $>>>, <<*>>, <<<*>>> 
     144 
     145(.*.) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d) 
     146(.*.) = (.).(.) 
    143147 
    144148(<<$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) 
Note: See TracChangeset for help on using the changeset viewer.