Changeset 54de81f in adblock2privoxy


Ignore:
Timestamp:
Nov 7, 2013 7:50:21 PM (6 years ago)
Author:
zubr <a@…>
Branches:
master
Children:
b81c15c
Parents:
e90f7e4
Message:

bugfixes, added license text

Files:
4 added
2 deleted
10 edited

Legend:

Unmodified
Added
Removed
  • AdBlock2Privoxy.cabal

    re90f7e4 r54de81f  
    3131                   Templates, 
    3232                   PopupBlocker, 
    33                    Statistics 
     33                   Statistics, 
     34                   SourceInfo 
    3435 
  • src/ElementBlocker.hs

    re90f7e4 r54de81f  
    2020data ElemBlockData = ElemBlockData [Pattern] BlockedRulesTree deriving Show 
    2121 
    22 elemBlock :: String -> [Line] -> IO () 
    23 elemBlock path = writeElemBlock path . elemBlockData 
    24  
    25 writeElemBlock :: String -> ElemBlockData -> IO () 
    26 writeElemBlock path (ElemBlockData flatPatterns rulesTree) =  
    27     do 
    28        writeBlockTree path rulesTree  
    29        writePatterns (path </> "adblock.common.css") flatPatterns            
    30  
    31 writeBlockTree :: String -> BlockedRulesTree -> IO () 
    32 writeBlockTree path (Node name patterns children) = 
    33     do 
    34         createDirectoryIfMissing True path' 
    35         _ <- sequence (writeBlockTree path' <$> children) 
    36         writePatterns filename patterns         
     22elemBlock :: String -> [String] -> [Line] -> IO () 
     23elemBlock path info = writeElemBlock . elemBlockData 
    3724    where 
    38         path'  
    39             | null name = path 
    40             | otherwise = path </> name 
    41         filename = path' </> "adblock.css" 
    42          
    43 writePatterns :: String -> [Pattern] -> IO () 
    44 writePatterns filename patterns =  
    45      do outFile <- openFile filename WriteMode 
    46         hPutStrLn outFile $ intercalate "," patterns 
    47         unless (null patterns) $ hPutStrLn outFile $ Templates.blockCss 
    48         hClose outFile 
    49       
     25    writeElemBlock :: ElemBlockData -> IO () 
     26    writeElemBlock (ElemBlockData flatPatterns rulesTree) =  
     27        do 
     28           writeBlockTree path rulesTree  
     29           writePatterns (path </> "ab2p.common.css") flatPatterns            
     30    writeBlockTree :: String -> BlockedRulesTree -> IO () 
     31    writeBlockTree nodePath (Node name patterns children) = 
     32        do 
     33            createDirectoryIfMissing True path' 
     34            _ <- sequence (writeBlockTree path' <$> children) 
     35            writePatterns filename patterns         
     36        where 
     37            path'  
     38                | null name = nodePath 
     39                | otherwise = nodePath </> name 
     40            filename = path' </> "ab2p.css"       
     41    writePatterns :: String -> [Pattern] -> IO () 
     42    writePatterns filename patterns =  
     43         do outFile <- openFile filename WriteMode 
     44            hPutStrLn outFile "/*" 
     45            _ <- mapM (hPutStrLn outFile) $ info 
     46            hPutStrLn outFile "*/" 
     47            hPutStrLn outFile $ intercalate "," patterns 
     48            unless (null patterns) $ hPutStrLn outFile $ Templates.blockCss 
     49            hClose outFile 
     50          
    5051         
    5152 
  • src/InputParser.hs

    re90f7e4 r54de81f  
    88Domain, 
    99Policy (..), 
    10 adblockFile 
     10RecordSource (..), 
     11adblockFile, 
     12recordSourceText 
    1113) 
    1214where 
     
    1921import Control.Monad 
    2022import Text.Parsec.Permutation 
     23import System.FilePath.Posix 
     24import Utils 
    2125  
    2226-------------------------------------------------------------------------- 
     
    2529 
    2630-- composite 
    27 data Line = Line String Record 
    28         deriving (Read,Show,Eq) 
    29          
     31data Line = Line RecordSource Record 
     32        deriving (Show,Eq) 
     33 
     34data RecordSource = RecordSource { _position :: SourcePos, _rawRecord :: String } deriving (Show,Eq)   
    3035data Policy = Block | Unblock deriving (Show, Eq, Read, Ord)         
    3136data Record =   Error String | 
    32                 Comment |  
     37                Comment String |  
    3338                ElementHide (Restrictions Domain) Policy Pattern |  
    3439                RequestBlock Policy Pattern RequestOptions 
    3540        deriving (Read,Show,Eq) 
    3641                    
    37 data RequestType =  Script | Image | Stilesheet | Object | Xmlhttprequest | Popup | 
    38                     ObjectSubrequest | Subdocument | Document | Elemhide | Other 
     42data RequestType =  Script | Image | Stylesheet | Object | Xmlhttprequest | Popup | 
     43                    ObjectSubrequest | Subdocument | Document | Other 
    3944                    deriving (Read, Show,Eq) 
    4045 
     
    4651                            _collapse    :: Maybe Bool, 
    4752                            _doNotTrack  :: Bool, 
     53                            _elemHide    :: Bool, 
    4854                            _unknown     :: [String] 
    4955                      } 
     
    6066        deriving (Read,Show,Eq) 
    6167 
     68recordSourceText :: RecordSource -> String 
     69recordSourceText (RecordSource position rawRecord) 
     70   = concat [rawRecord, " (", takeFileName $ sourceName position, ": ", show $ sourceLine position, ")"] 
     71    
    6272-------------------------------------------------------------------------- 
    6373---------------------------- parsers  ------------------------------------ 
     
    7282 
    7383line :: Parser Line  
    74 line = Line <$> text <*> choice (try <$> [comment, elementHide, match, unknown]) <?> "filtering rule"   
    75     where 
    76         text = lookAhead (manyTill anyChar lineEnd) 
     84line = do 
     85    position <- getPosition  
     86    let text = lookAhead (manyTill anyChar lineEnd) 
     87        sourcePosition = RecordSource position <$> text 
     88    Line <$> sourcePosition <*> choice (try <$> [comment, elementHide, match, unknown]) <?> "filtering rule"   
     89     
     90         
    7791 
    7892elementHide :: Parser Record 
     
    91105 
    92106comment :: Parser Record 
    93 comment = Comment <$ (separatorLine <|> commentText) 
    94             where commentText = char '!' <* skipMany notLineEnd 
    95                   separatorLine = lookAhead lineEnd 
     107comment = Comment <$> (separatorLine <|> commentText) 
     108            where commentText = char '!' *> many notLineEnd 
     109                  separatorLine = lookAhead lineEnd *> return "" 
    96110 
    97111unknown :: Parser Record 
     
    106120                                    <*> (getMaybeAll <$> requestOptionNorm "Collapse") 
    107121                                    <*> (getAllOrFalse <$> requestOptionNorm "Donottrack") 
     122                                    <*> (getAllOrFalse <$> requestOptionNorm "Elemhide") 
    108123                                    <* manyPerm separator  
    109124                                    <*> unknownOption 
     
    194209                            in Restrictions (Just $ filter notN p) n 
    195210        annigilate a = a 
     211         
     212         
     213         
     214         
  • src/Main.hs

    re90f7e4 r54de81f  
    66import Text.ParserCombinators.Parsec hiding (Line, many, optional) 
    77import Statistics 
     8import Control.Applicative hiding (many) 
     9import SourceInfo 
    810 
    9 filename, outDir :: String 
    10 filename = "/home/alexey/Projects/AdBlock2Privoxy/test-data/testData" 
    11 --filename = "/home/alexey/Downloads/easylist.txt" 
     11f1, outDir :: String 
     12f1 = "/home/alexey/Projects/AdBlock2Privoxy/test-data/testData" 
     13--f1 = "/home/alexey/Projects/AdBlock2Privoxy/test-data/easylist.txt" 
    1214--filename = "/home/alexey/Downloads/advblock.txt" 
    1315outDir = "/home/alexey/test/ab" 
    14  
     16filenames :: [String] 
     17filenames = [f1] 
    1518 
    1619main::IO() 
    17 main = do 
    18         putStrLn $ filename ++ ": parsing started" 
    19         inputFile <- openFile filename ReadMode 
    20         text <- hGetContents inputFile 
    21         let parsed = parse adblockFile filename text 
    22         putStrLn $ show parsed 
    23         case parsed of  
    24             Right parsed' ->  
    25                 do  
    26                    stat outDir parsed' 
    27                    elemBlock (outDir ++ "/site") parsed' 
    28                    urlBlock outDir parsed' 
    29             Left msg -> putStrLn $ show msg 
    30         hClose inputFile 
     20main = do  
     21        let parseFile filename = do 
     22            putStrLn $ filename ++ ": parsing started" 
     23            inputFile <- openFile filename ReadMode 
     24            text <- hGetContents inputFile 
     25            case parse adblockFile filename text of 
     26                Right parsed -> return (parsed, extractInfo parsed, inputFile) 
     27                Left msg -> return ([], NoInfo, inputFile) <$ putStrLn $ show msg 
     28                     
     29        (parsed, sourceInfo, handlers) <- unzip3 <$> mapM parseFile filenames    
     30        let parsed' = concat parsed  
     31            info    = (sourceInfo >>= showInfo) ++ ["------- end ------\n"]                
     32        stat outDir info parsed' 
     33        elemBlock (outDir ++ "/site") info parsed' 
     34        urlBlock outDir info parsed' 
     35        _ <- sequence $ hClose <$> handlers 
    3136        putStrLn "done" 
    3237 
  • src/OptionsConverter.hs

    re90f7e4 r54de81f  
    2424 
    2525allTypes :: [HeaderType] 
    26 allTypes = [accept, contentType, requestedWith, referrer] 
    27   
    28 accept, contentType, requestedWith, referrer :: HeaderType 
     26allTypes = [accept, contentType, requestedWith, referer] 
     27 
     28accept, contentType, requestedWith, referer :: HeaderType 
    2929accept = HeaderType "accept" Client 1 'A' acceptFilter 
    3030contentType = HeaderType "content-type" Server 1 'C' contentTypeFilter 
    3131requestedWith = HeaderType "x-requested-with" Client 1 'X' requestedWithFilter 
    32 referrer = HeaderType "referrer" Client 2 'R' referrerFilter 
     32referer = HeaderType "referer" Client 2 'R' refererFilter 
    3333 
    3434 
    3535headerFilters :: Policy -> Int -> RequestOptions -> Maybe HeaderFilters 
    3636headerFilters _ 0 _ = Just [] 
    37 headerFilters policy level requestOptions 
    38     = do  
    39          nextLevel <- headerFilters policy (level - 1) requestOptions 
    40          let filters = do 
     37headerFilters policy level requestOptions@RequestOptions{_requestType = requestType} 
     38    = let requestOptions' = requestOptions{_requestType = convertOther requestType}  
     39      in do  
     40         nextLevel <- headerFilters policy (level - 1) requestOptions' 
     41         let 
     42            passthrough = checkPassthrough policy requestOptions'   
     43            filters = do 
    4144                       headerType <- allTypes 
    4245                       guard (_level headerType == level) 
    43                        case (_fabrique headerType) policy requestOptions of 
     46                       case (_fabrique headerType) policy requestOptions' of 
    4447                          Specific filter' -> return $ Just $ HeaderFilter headerType filter' 
    4548                          None -> return Nothing 
    4649                          Any -> mzero 
    47          when (all isNothing filters && not (null filters)) $ fail "filters blocked" 
     50         when (not passthrough && all isNothing filters && not (null filters)) $ fail "filters blocked" 
    4851         return $ case catMaybes filters of 
    4952                    []       -> nextLevel 
    5053                    filters' -> filters' : nextLevel 
     54 
     55convertOther :: Restrictions RequestType -> Restrictions RequestType 
     56convertOther (Restrictions positive negative)= Restrictions positive' negative' 
     57    where  
     58    allContentOptions = [Script, Image, Stylesheet, Object, ObjectSubrequest, Document] 
     59    positiveList = fromMaybe [] positive 
     60    negative' | Other `elem` positiveList = allContentOptions \\ positiveList 
     61              | otherwise                 = negative 
     62    positive' | Other `elem` negative     = Just $ allContentOptions \\ negative'  
     63              | positive == Just [Other]  = Nothing 
     64              | otherwise                 = positive 
     65     
     66checkPassthrough :: Policy -> RequestOptions -> Bool 
     67checkPassthrough _ RequestOptions {_requestType = (Restrictions positive _) } 
     68    = fromMaybe False $ (not . null . intersect [Subdocument]) <$> positive  
    5169  
    52 acceptFilter, contentTypeFilter, requestedWithFilter, referrerFilter :: FilterFabrique 
     70acceptFilter, contentTypeFilter, requestedWithFilter, refererFilter :: FilterFabrique 
    5371 
    54 contentTypeFilter  policy (RequestOptions (Restrictions positive negative) thirdParty _ _ _ _ _) 
    55     | fromMaybe False emptyPositive  = None 
     72contentTypeFilter  policy (RequestOptions (Restrictions positive negative) thirdParty _ _ _ _ _ _) 
     73    | fromMaybe True emptyPositive && (not $ isNothing positive) = None 
    5674    | result == mempty = Any  
    5775    | otherwise = Specific $ Filter code regex orEmpty 
    5876    where  
    59     negative'  
    60         | fromMaybe False thirdParty = Document : negative 
    61         | otherwise                  = negative    
     77    negative' | isNothing positive && fromMaybe False thirdParty = Document : negative 
     78              | otherwise                  = negative    
    6279    negativePart = mappend ("n", "") <$> convert False negative' 
    6380    positivePart = positive >>= convert True 
     
    6683    emptyPositive = null . filter (`notElem` (fromMaybe "" $ fst <$> negativePart)) . fst <$> positivePart 
    6784    
    68     convert _ [] = Nothing 
    69     convert include requestTypes = let 
    70         contentTypes' = nub $ requestTypes >>= contentTypes include 
    71         code' = sort $ (head . dropWhile (`elem` "/(?:x-)")) <$> contentTypes' 
    72         regex' = lookahead contentTypes' ".*" include 
    73         in Just (code', regex') 
     85    convert  _      []                        = Nothing 
     86    convert include requestTypes | null code' = Nothing 
     87                                 | otherwise  = Just (code', regex') 
     88        where   contentTypes' = nub $ requestTypes >>= contentTypes include 
     89                code' = sort $ (head . dropWhile (`elem` "/(?:x-)")) <$> contentTypes' 
     90                regex' = lookahead contentTypes' "[\\s\\w]*" include 
    7491     
    7592acceptFilter excludePattern options = case contentTypeFilter excludePattern options of 
     
    7895                              
    7996                                         
    80 requestedWithFilter _ (RequestOptions (Restrictions positive negative) _ _ _ _ _ _) = 
     97requestedWithFilter _ RequestOptions{ _requestType = Restrictions positive negative } = 
    8198        case result of 
    8299            Nothing       -> Any 
    83             Just result'  -> Specific $ Filter "" (lookahead ["XMLHttpRequest"] "\\s*" result')  (not result') 
     100            Just result'  -> Specific $ Filter (code result') (lookahead ["xmlhttprequest"] "\\s*" result')  (not result') 
    84101    where 
    85     result 
    86         | Xmlhttprequest `elem` negative                             = Just False 
    87         | Xmlhttprequest `elem` fromMaybe [] positive                = Just True 
    88         |                           (hasContentTypes False    negative)  
    89           && (fromMaybe True $ not . hasContentTypes True <$> positive)   = Just True 
    90         | otherwise                                                  = Nothing 
    91      
    92      
     102    code True = "x" 
     103    code False = "nx" 
     104    result | Xmlhttprequest `elem` negative                                  = Just False 
     105           | Xmlhttprequest `elem` fromMaybe [] positive                     = Just True 
     106           |                           (hasContentTypes False    negative)  
     107             && (fromMaybe True $ not . hasContentTypes True <$> positive)   = Just True 
     108           | otherwise                                                       = Nothing 
    93109    hasContentTypes include = not . all null . fmap (contentTypes include) 
    94110 
    95111 
    96 referrerFilter policy (RequestOptions _ thirdParty (Restrictions positive negative) _ _ _ _)  
     112refererFilter policy RequestOptions{ _thirdParty = thirdParty, _domain = Restrictions positive negative } 
    97113    | fromMaybe False emptyPositive  = None 
    98114    | result == mempty = Any  
     
    102118    positivePart = positive >>= convert True 
    103119    thirdPartyPart tp = (if tp then "t" else "nt", lookahead ["$host"] ".*\\/" (not tp)) 
    104     result@(code, regex) = mconcat $ catMaybes [positivePart, negativePart, thirdPartyPart <$> thirdParty] 
    105      
     120    result@(code, regex) = mconcat $ catMaybes [positivePart, negativePart, thirdPartyPart <$> thirdParty]     
    106121    emptyPositive = null . filter (`notElem` negative) <$> positive 
    107122    orEmpty =  (policy == Unblock) && (isNothing positive || (not $ fromMaybe True thirdParty)) 
    108       
    109123    convert _ [] = Nothing 
    110124    convert include domains = let 
     
    123137contentTypes _ Script = ["/(?:x-)?javascript"] 
    124138contentTypes _ Image = ["image/"] 
    125 contentTypes _ Stilesheet = ["/css"] 
     139contentTypes _ Stylesheet = ["/css"] 
    126140contentTypes _ Object = ["video/","audio/","/(?:x-)?shockwave-flash"] 
    127141contentTypes _ ObjectSubrequest = ["video/","audio/","/octet-stream"] 
  • src/Statistics.hs

    re90f7e4 r54de81f  
    88type Stat = Map.Map String Int  
    99 
    10 stat :: String -> [Line] -> IO () 
    11 stat path lns =  
     10stat :: String -> [String] -> [Line] -> IO () 
     11stat path info lns =  
    1212    let result = collectStat lns  
    1313        filename = path </> "stat.txt" 
    1414    in do   
    1515        outFile <- openFile filename WriteMode 
     16        _ <- mapM (hPutStrLn outFile) info 
    1617        hPutStrLn outFile $ show result 
    1718        hClose outFile 
     
    2829 
    2930getStat :: Line -> Stat-> Stat 
    30 getStat  (Line _ Comment) = increment "comments" 
     31getStat  (Line _ Comment {} ) = increment "comments" 
    3132getStat  (Line _ Error {}) = increment "errors" 
    3233getStat  (Line _ ElementHide {}) = increment "elemHide" 
    33 getStat  (Line _ (RequestBlock policy _ (RequestOptions requestType thirdParty domains _ _ _ _))) = r 
     34getStat  (Line _ (RequestBlock policy _ (RequestOptions requestType thirdParty domains _ _ _ _ _))) = r 
    3435    where  
    3536    r s = r8 s 
     
    4950    r8 | isJust thirdParty && ((not.null._negative $ requestType) || ((isJustFilled . _positive) $ requestType)) = r7 . increment "requestType&thirdPartyRBlock" 
    5051       | otherwise = r7 
     52        
     53--TODO: Elemhide only in unblock requests, only in positive part 
     54--Document only in unblock requests  
     55        
     56        
     57        
     58        
  • src/Templates.hs

    re90f7e4 r54de81f  
    22import  {-# SOURCE #-}  UrlBlocker 
    33 
    4 blockCss, ab2pPrefix :: String 
     4blockCss, ab2pPrefix, actionsFilePrefix, filtersFilePrefix :: String 
    55blockCss = "{display:none,visibility:hidden}" 
    66ab2pPrefix = "ab2p-" 
     7actionsFilePrefix = "#AbBlock generated actions -- don't edit --" 
     8filtersFilePrefix = "#AbBlock generated filters -- don't edit --" 
    79 
    810terminalActionSwitch :: Bool -> BlockMethod -> String 
    911terminalActionSwitch True Request =  
    1012 "+block{ adblock rules } \\\n\ 
    11  \+server-header-tagger{ab2p-block-s}" 
     13 \+server-header-tagger{ab2p-block-s} \\\n\ 
     14 \+handle-as-image \\\n\ 
     15 \+client-header-tagger{ab2p-handle-as-document-c} \\\n\  
     16 \+server-header-tagger{ab2p-handle-as-document-s}" 
    1217terminalActionSwitch False Request =  
    1318 "-block \\\n\ 
     
    1621 \+server-header-tagger{ab2p-unblock-s} \\\n\ 
    1722 \+client-header-tagger{ab2b-unblock-u}" 
    18 terminalActionSwitch True Xframe = "+xframe-filter"  
    19 terminalActionSwitch False Xframe = "-xframe-filter"  
    20 terminalActionSwitch False Elem = "-elem-hide-filter"  
     23terminalActionSwitch True Xframe = "+server-header-filter{ab2p-xframe-filter}"  
     24terminalActionSwitch False Xframe = "-server-header-filter{ab2p-xframe-filter}"  
     25terminalActionSwitch False Elem = "-filter{ab2p-elemhide-filter}"  
     26terminalActionSwitch True Dnt = "+add-header{DNT: 1}" 
    2127terminalActionSwitch _ _ = ""  
    2228  
  • src/UrlBlocker.hs

    re90f7e4 r54de81f  
    2222 
    2323data TaggerType = Client | Server 
    24 data TaggerForwarder = Forward (Maybe Filter) String | Cancel Tagger  
     24data TaggerForwarder = Forward (Maybe Filter) String | CancelTagger String 
    2525data Tagger = Tagger { _taggerCode :: String, _forwarding :: [TaggerForwarder], _headerType :: HeaderType } 
    2626 
     
    2929data Action = Action { _actionCode :: String, _switches :: [ActionSwitch], _patterns :: [Pattern], _hasTag :: Bool } 
    3030 
     31data ChainType = Regular | Nested | Negate deriving (Eq, Ord) 
    3132type UrlBlockData = ([Tagger], [Action]) 
    32 data BlockMethod = Request | Xframe | Elem deriving (Show, Eq) 
    33 data FilteringNode = Node { _pattern :: [Pattern], _filters :: HeaderFilters, _isNested :: Bool,  
     33data BlockMethod = Request | Xframe | Elem | Dnt deriving (Show, Eq) 
     34data FilteringNode = Node { _pattern :: [Pattern], _filters :: HeaderFilters, _nodeType :: ChainType,  
    3435    _policy :: Policy, _method :: BlockMethod } 
     36 
    3537 
    3638class Named a where 
    3739    name :: a -> String 
    3840 
    39 urlBlock :: String -> [Line] -> IO() 
    40 urlBlock path = writeBlockData path . urlBlockData  
    41      
    42 writeBlockData :: String -> UrlBlockData -> IO() 
    43 writeBlockData path (taggers, actions) =  
    44     do writeContent (path </> "adblock.filter") "#AbBlock generated filters -- don't edit --" taggers 
    45        writeContent (path </> "adblock.action") "#AbBlock generated actions -- don't edit --" actions 
    46  
    47 writeContent :: Show a => String -> String -> [a] -> IO() 
    48 writeContent filename header content =  
    49      do outFile <- openFile filename WriteMode 
    50         hPutStrLn outFile (header ++ "\n")  
    51         hPutStrLn outFile $ intercalate "\n\n" $ show <$> content 
    52         hClose outFile 
     41urlBlock :: String -> [String] -> [Line] -> IO() 
     42urlBlock path info = writeBlockData . urlBlockData  
     43    where     
     44    writeBlockData :: UrlBlockData -> IO() 
     45    writeBlockData (taggers, actions) =  
     46        do writeContent (path </> "ab2p.filter") Templates.filtersFilePrefix taggers 
     47           writeContent (path </> "ab2p.action") Templates.actionsFilePrefix actions 
     48    writeContent filename header content =  
     49         do outFile <- openFile filename WriteMode 
     50            hPutStrLn outFile (header)  
     51            _ <- mapM (hPutStrLn outFile) $ ('#':) <$> info 
     52            hPutStrLn outFile $ intercalate "\n\n" $ show <$> content 
     53            hClose outFile 
    5354 
    5455urlBlockData :: [Line] -> UrlBlockData  
    55 urlBlockData lns = mconcat [nodeResult node | node <- shortenNodes $ sortBy cmpPolicy filterNodesList ] 
    56     where 
     56urlBlockData lns = filterBlockData $ result 
     57    where 
     58    result = mconcat [nodeResult node | node <- shortenNodes $ sortBy cmpPolicy $ filterNodesList blockLines] 
    5759    cmpPolicy node1 node2 = compare (_policy node1) (_policy node2) 
    58     filterNodesList = Map.foldr (:) [] $ Map.fromListWith joinNodes $ lns >>= blockLine 
    59         where 
    60         blockLine (Line _ (RequestBlock policy pattern options))  
    61             = [(name node, node) | node <- filteringNodes policy (errorToPattern expandedPatterns) options] 
     60    blockLines = lns >>= blockLine 
     61        where  
     62        blockLine (Line position (RequestBlock policy pattern options))  
     63            = filteringNodes policy (errorToPattern expandedPatterns) options 
    6264            where  
    6365            expandedPatterns = makePattern (_matchCase options) <<$> parseUrl pattern 
    64             errorToPattern (Left parseError) = ['#' : pattern ++ " - " ++ show parseError] 
    65             errorToPattern (Right patterns') = patterns' 
     66            sourceText = recordSourceText position  
     67            errorToPattern (Left parseError) = ["# ERROR: " ++ sourceText  ++ " - " ++ show parseError] 
     68            errorToPattern (Right patterns') = ("# " ++ sourceText) : patterns' 
    6669        blockLine _ = [] 
    67         joinNodes (Node patterns1 filters1 nested1 policy1 method1)  
    68                   (Node patterns2 _ nested2 _ _)  
    69             = Node (patterns1 ++ patterns2) filters1 (nested1 || nested2) policy1 method1 
    70  
    71  
     70     
     71filterNodesList :: [FilteringNode] -> [FilteringNode] 
     72filterNodesList nodes = Map.foldr (:) [] $ Map.fromListWith joinNodes $ list 
     73    where 
     74    list = [(name node, node) | node <- nodes] 
     75    joinNodes (Node patterns1 filters1 type1 policy1 method1)  
     76              (Node patterns2 _ type2 _ _)  
     77        = Node (patterns1 ++ patterns2) filters1 (max type1 type2) policy1 method1 
     78 
     79filterBlockData :: UrlBlockData -> UrlBlockData 
     80filterBlockData blockData = (result, snd blockData) 
     81    where 
     82    result = Map.foldr (:) [] $ Map.fromListWith joinTaggers taggerItems 
     83    taggerItems = [(name tagger, tagger) | tagger <- fst blockData] 
     84    metric = length._forwarding 
     85    joinTaggers tagger1 tagger2 | metric tagger1 >= metric tagger2 = tagger1 
     86                                | otherwise                        = tagger2 
     87          
    7288shortenNodes :: [FilteringNode] -> [FilteringNode]       
    7389shortenNodes nodes = evalState (mapM shortenNode nodes) initialState 
     
    92108filteringNodes :: Policy -> [Pattern] -> RequestOptions -> [FilteringNode] 
    93109filteringNodes policy patterns requestOptions  
    94     = join $ mainResult ++ subdocumentResult ++ elemhideResult 
     110    = join.join $  [mainResult, subdocumentResult, elemhideResult, dntResult] 
    95111    where  
    96112    mainResult = optionsToNodes mainOptions $> Request 
    97113    subdocumentResult = maybeToList (optionsToNodes (singleTypeOptions Subdocument) $> Xframe) 
    98     elemhideResult = maybeToList (optionsToNodes (singleTypeOptions Elemhide) $> Elem) 
     114    elemhideResult = maybeToList (optionsToNodes (boolOptions _elemHide) $> Elem) 
     115    dntResult = maybeToList (optionsToNodes (boolOptions _doNotTrack) $> Dnt) 
    99116    requestType = _requestType requestOptions 
    100117    mainOptions = [requestOptions {_requestType = requestType { _positive = mainRequestTypes } }] 
    101     mainRequestTypes = filter (/= Subdocument) <$> (_positive requestType) 
     118    mainRequestTypes = filter (`notElem` [Subdocument, Popup]) <$> (_positive requestType) 
     119    boolOptions getter = case getter requestOptions of 
     120        False -> Nothing 
     121        True  -> Just requestOptions {_requestType = Restrictions Nothing [], _thirdParty = Nothing} 
    102122    singleTypeOptions singleType =  
    103123        do 
     
    106126        return requestOptions {_requestType = requestType { _positive = Just [foundType] } } 
    107127    optionsToNodes options = collectNodes patterns <$> headerFilters policy 2 <$> options 
     128    nestedOrRegular True = Nested 
     129    nestedOrRegular False = Regular 
    108130    collectNodes :: [Pattern] -> Maybe HeaderFilters -> BlockMethod -> [FilteringNode] 
    109131    collectNodes _ Nothing _ = []  
    110     collectNodes patterns' (Just []) method = [Node patterns' [] (null patterns') policy method] 
    111     collectNodes patterns' (Just filters@(_: next)) method 
    112             = Node patterns' filters (null patterns') policy Request : collectNodes [] (Just next) method 
     132    collectNodes patterns' (Just []) method = [Node patterns' [] (nestedOrRegular $ null patterns') policy method] 
     133    collectNodes patterns' (Just filters@(levelFilters: next)) method 
     134            = Node patterns' filters (nestedOrRegular $ null patterns') policy method  
     135              : (levelFilters >>= negateNode)  
     136              ++ collectNodes [] (Just next) method 
     137        where  
     138        negateNode negateFilter@(HeaderFilter _ (Filter {_orEmpty = True}))  
     139                = [Node [] ([negateFilter] : next) Negate policy method] 
     140        negateNode _ = []  
    113141           
    114  
    115142nodeResult :: FilteringNode -> UrlBlockData 
    116 nodeResult node@(Node patterns (levelFilters : nextLevelFilters) nested policy method) 
    117     = (taggers, (mainAction : auxActions)) 
    118     where  
    119     mainAction = Action { _actionCode = name node, 
    120                           _switches   = appendIf (policy == Unblock && method == Request)  
    121                                             (Switch False BlockAction) 
    122                                             (Switch True . TaggerAction <$> taggers), 
    123                           _patterns   = patterns, 
    124                           _hasTag     = nested }  
    125     
    126     auxActions = do forwarder <- taggers >>= _forwarding 
    127                     case forwarder of 
    128                        Cancel tagger ->  
    129                            return $ Action ('-' : name tagger) [Switch False $ TaggerAction tagger] [] True 
    130                        _ -> mzero 
    131      
    132     taggers = levelFilters >>= filterTaggers 
    133     filterTaggers (HeaderFilter headerType@HeaderType {_typeCode = typeCode} filter'@(Filter filterCode _ orEmpty))   
    134         | orEmpty  = [orEmptyTagger, mainTagger [Cancel orEmptyTagger]] 
    135         | otherwise   = [mainTagger []] 
     143nodeResult node@(Node patterns [] nodeType policy method) = ([], [baseAction]) 
     144    where baseAction = Action (name node) [Switch (policy == Block) $ TerminalAction method] patterns (nodeType == Nested) 
     145nodeResult node@(Node _ ([flt] : nextLevelFilters) Negate policy method) 
     146    = ([negateTagger], [negateAction]) 
     147    where 
     148    negateAction = Action (name node) [Switch False $ TaggerAction negateTagger] [] True 
     149    negateTagger = newTagger flt nextLevelFilters policy method Negate [] 
     150nodeResult node@(Node patterns (levelFilters : nextLevelFilters) nodeType policy method) 
     151    = (taggers, [action]) 
     152    where  
     153    action = Action { _actionCode = name node, 
     154                      _switches   = appendIf (policy == Unblock && method == Request)  
     155                                        (Switch False BlockAction) 
     156                                        (Switch True . TaggerAction <$> taggers), 
     157                      _patterns   = patterns, 
     158                      _hasTag     = (nodeType == Nested) }   
     159    taggers = filterTaggers <$> levelFilters 
     160    filterTaggers flt@(HeaderFilter _ (Filter _ _ orEmpty))   
     161        = newTagger flt nextLevelFilters policy method Regular moreForwarding 
    136162        where 
    137         nextLevelName = filtersCode policy method nextLevelFilters 
    138         mainTagger moreForwarders = Tagger {   _taggerCode = nextLevelName $ typeCode : filterCode, 
    139                                                _forwarding = Forward (Just filter') (nextLevelName "") : moreForwarders, 
    140                                                _headerType = headerType } 
    141         orEmptyTagger             = Tagger { _taggerCode = nextLevelName ['n', typeCode], 
    142                                              _forwarding = [Forward Nothing (nextLevelName "")], 
    143                                              _headerType = headerType } 
    144 nodeResult node@(Node patterns [] nested policy method) = ([], [baseAction]) 
    145     where baseAction = Action (name node) [Switch (policy == Block) $ TerminalAction method] patterns nested 
     163        orEmptyTaggerCode   = filtersCode ([flt] : nextLevelFilters) Negate  policy method "" 
     164        moreForwarding  | orEmpty = [CancelTagger orEmptyTaggerCode] 
     165                        | otherwise = [] 
    146166             
     167newTagger :: HeaderFilter -> HeaderFilters -> Policy -> BlockMethod -> ChainType -> [TaggerForwarder] -> Tagger 
     168newTagger flt@(HeaderFilter headerType filter') nextLevelFilters policy method chainType moreForwarding 
     169   = Tagger { _taggerCode = taggerCode, 
     170              _forwarding = Forward filter'' nextLevelActionCode : moreForwarding, 
     171              _headerType = headerType }      
     172   where 
     173   filter'' | chainType == Negate = Nothing 
     174            | otherwise           = Just filter' 
     175   taggerCode          = filtersCode ([flt] : nextLevelFilters) chainType policy method ""         
     176   nextLevelActionCode = filtersCode nextLevelFilters  Nested policy method ""    
     177            
    147178instance Named FilteringNode where 
    148     name (Node _ filters _ policy method)  = filtersCode policy method filters ""  
    149      
    150 filtersCode :: Policy -> BlockMethod -> HeaderFilters -> String -> String 
    151 filtersCode policy method [] rest  
     179    name (Node _ filters Negate policy method)  = '-' : filtersCode filters Negate policy method ""  
     180    name (Node _ filters _ policy method)  = filtersCode filters Nested policy method ""  
     181     
     182filtersCode :: HeaderFilters -> ChainType -> Policy -> BlockMethod -> String -> String 
     183filtersCode [] _ policy method rest  
    152184    = join [Templates.ab2pPrefix, toLower <$> show policy, "-" ,toLower <$> show method,(if null rest then "" else "-"), rest] 
    153 filtersCode policy method (levelFilters : nextLevelFilters) rest  
    154     = filtersCode policy method nextLevelFilters $ join [levelCode, (if null rest then "" else "-when-"), rest] 
     185filtersCode (levelFilters : nextLevelFilters) chainType policy method rest  
     186    = filtersCode nextLevelFilters Nested policy method $ join [levelCode, (if null rest then "" else "-when-"), rest] 
    155187    where  
    156188    levelCode = (intercalate "-" $ filterCode <$> levelFilters) 
    157189    filterCode (HeaderFilter HeaderType {_typeCode = typeCode} (Filter code _ orEmpty)) 
    158         | orEmpty   = 'n' : typeCode : '-' : mainCode   
    159         | otherwise    = mainCode 
    160         where mainCode = typeCode : code 
     190        | chainType == Negate            = negateCode 
     191        | chainType == Nested && orEmpty = negateCode ++ '-' : mainCode   
     192        | otherwise                      = mainCode 
     193        where  
     194        mainCode = typeCode : code 
     195        negateCode = 'n' : [typeCode] 
    161196 
    162197instance Show TaggerType where 
     
    176211              forward (Forward (Just filter') tagret) = forwardRegex headerName (_regex filter') ":" "" tagret 
    177212              forward (Forward Nothing tagret) = forwardRegex "" "" "" "" tagret 
    178               forward (Cancel tagger) = forwardRegex headerName "" ":" "-" (name tagger) 
     213              forward (CancelTagger taggerCode) = forwardRegex headerName "" ":" "-" taggerCode 
    179214              forwardRegex header lookahead' value tagPrefix tagret 
    180                 = let modifier  
    181                         | '$' `elem` lookahead' = "TDi" 
    182                         | otherwise            = "Ti" 
     215                = let modifier | '$' `elem` lookahead' = "TDi" 
     216                               | otherwise             = "Ti" 
    183217                  in join ["s@^", header, lookahead', value, ".*@", tagPrefix, tagret, "@", modifier]  
    184218     
     
    191225    show (Switch enable BlockAction) = name enable ++ "block" 
    192226    show (Switch enable (TaggerAction tagger))  
    193         = join [name enable, name $ _taggerType $ _headerType $ tagger, "{", name tagger,  "}" ]  
    194  
     227        = intercalate " \\\n " $ mainText : (_forwarding tagger >>= cancelTaggerText) 
     228        where  
     229        mainText = join [name enable, name $ _taggerType $ _headerType $ tagger, "{", name tagger,  "}" ] 
     230        cancelTaggerText (CancelTagger cancelTaggerCode)  
     231            = [join [name enable, name $ _taggerType $ _headerType $ tagger, "{", cancelTaggerCode,  "}" ]] 
     232        cancelTaggerText _ = []                 
     233     
    195234instance Named Action where 
    196235    name = _actionCode 
     
    201240        where caption = '#' : code 
    202241              switches' = join ["{", intercalate " \\\n " (show <$> switches), " \\\n}"] 
    203               patterns'  
    204                 | hasTag    = join ["TAG:^", code, "$"] : patterns 
    205                 | otherwise = patterns   
     242              patterns' | hasTag    = join ["TAG:^", code, "$"] : patterns 
     243                        | otherwise = patterns   
    206244                 
    207245                 
  • src/UrlBlocker.hs-boot

    re90f7e4 r54de81f  
    44) where 
    55 
    6 data BlockMethod = Request | Xframe | Elem 
     6data BlockMethod = Request | Xframe | Elem | Dnt 
    77data TaggerType = Client | Server 
  • test-data/testData

    re90f7e4 r54de81f  
    11[Adblock Plus 2.0] 
    2 !! root level 
    3 !#@#root Level Unblocked Block 
    4 !#@#rootLevelUnblock 
    5 !##rootLevelBlock 
    6 !##rootLevelBlock 
    7 !##root Level Unblocked Block 
    8 !##more Root Level Block 
    9 !##root excluded 
    10 !#@#root excluded3 
    11 !! domain level 
    12 !a.domain##root excluded3 
    13 !one.com##little block 
    14 !one.com##one.com block 
    15 !ad.one.com##one.com block 
    16 !two.com.us##more block 
    17 !three.com.us,all.com.us,bla.com.us##more block 
    18 !~foo.one.ru,~baz.one.ru,~wrong.com,one.ru,two.ru##ru block 
    19 !one.org,other.org,~no.other.org,two.one.org##org blocked unblock 
    20 !~something.org,~something.one.org,~very.deep.one.org,free.one.org,deep.one.org,~two.one.org#@#org blocked unblock 
    21 !!smth.com#@#root excluded 
    22 !!~smth.nl##root excluded2 
     2e1.ru$image 
     3@@|www.e1.ru$image 
     4e1.ru##.small_black 
    235 
    24 !_adrotator. 
    25 !.co/ads/$popup 
    26 ||vivamob.net^$third-party 
Note: See TracChangeset for help on using the changeset viewer.