Changeset 861fbae in adblock2privoxy


Ignore:
Timestamp:
Sep 3, 2013 8:40:30 PM (6 years ago)
Author:
zubr <a@…>
Branches:
master
Children:
dcd1d6c
Parents:
f7023f1
Message:

url pattern translation made

Location:
src
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • src/Foo.hs

    rb6b5fc1 r861fbae  
    33 
    44 
    5 l :: b -> (a -> b)  
    6 l x _ = x 
    75 
    8 g12 = l -- first item: concatenate l with prev level first item  
    9 g22 = l$id -- next items: pass prev level item to l 
    10  
    11 g13 :: a1 -> a2 -> a3 -> a1 
    12 g13 = l.l 
    13 g23 :: a1 -> a2 -> a3 -> a2 
    14 g23 = l$l 
    15 --g33 :: a1 -> a2 -> a3 -> a3 
    16 g33 = l$g23 
    17    
    18 g41 = l.l.l  
    19 g42 = l$l.l 
    20 g43 = l$l$l 
    21 g44 = l$l$l$id 
    22  
    23 g51 = l.l.l.l  
    24 g52 = l$l.l.l 
    25 g53 = l$l$l.l 
    26 g54 = l$l$l$l 
    27 g55 = l$l$l$l$id 
    28  
    29  
  • src/InputParser.hs

    rf7023f1 r861fbae  
    1 module InputParser where 
     1module InputParser (  
     2Line (..), 
     3Restrictions (..), 
     4RequestOptions (..), 
     5Record (..), 
     6Pattern 
     7) 
     8where 
    29import Control.Applicative hiding ((<|>)) 
    310import Text.ParserCombinators.Parsec hiding (Line, many, optional) 
     
    1724        deriving (Read,Show,Eq) 
    1825         
    19 data Record =   Unknown | 
     26data Record =   Error String | 
    2027                Comment |  
    2128                ElementHide (Restrictions Domain) Exclude Pattern |  
     
    8895 
    8996unknown :: Parser Record 
    90 unknown = Unknown <$ skipMany notLineEnd 
     97unknown = Error "Record type detection failed" <$ skipMany notLineEnd 
    9198 
    9299requestOptions :: Parser RequestOptions 
     
    167174getMaybeAll :: [All] -> Maybe Bool 
    168175getMaybeAll [] = Nothing 
    169 getMaybeAll list = Just$getAll$mconcat list 
     176getMaybeAll list = Just $ getAll $ mconcat list 
    170177 
    171178getAllOrFalse :: [All] -> Bool 
    172179getAllOrFalse [] = False 
    173 getAllOrFalse list = getAll$mconcat list 
     180getAllOrFalse list = getAll $ mconcat list 
    174181 
    175182noRestrictions :: Restrictions a 
  • src/Normalizer.hs

    rf7023f1 r861fbae  
    1010import ParsecExt 
    1111import Utils 
    12  
    13 type Path' = ( 
    14                 String,  -- proto 
    15                 String,  -- host 
    16                 String  -- query    
    17               ) 
    18  
    19  
    20 url :: String -> Either ParseError [Path] 
    21 url = parse (makePaths <$> bindStart <*> cases urlParts <*> bindEnd) "url" 
    22     where 
    23         bindStart = try (string "||") <|> try (string "|") <|> return "" <?> "query start" 
    24         bindEnd = (char '|' <* eof) <|> ('\0' <$ eof) <?> "query end" 
    25         makePath start (proto, host, query) end = Path (length start) proto host query end  
    26         makePaths start mid end = makePath start <$> mid <*> (pure (end == '|'))  
    27  
    28 urlParts :: [StringStateParser Path'] 
    29 urlParts = square3 proto (manyCases host) (oneCase query) 
    30         where           
    31             append xs x = xs ++ [x] 
    32             proto :: StringStateParser String 
    33             proto = do 
    34                     masksString <- get 
    35                     case masksString of 
    36                         Nothing ->  
    37                             do 
    38                             put $ Just $ intercalate protocolsSeparator protocols 
    39                             return "" 
    40                         Just masksString' ->  
    41                             do 
    42                             let masks = split protocolsSeparator masksString' 
    43                             if null masks  
    44                                 then lift pzero 
    45                                 else  
    46                                     do 
    47                                     name <- lift $ many $ protocolChar 
    48                                     sep <- lift $ many $ oneOf $ hostSeparators 
    49                                     let chars = name ++ (replace "^" "//" sep) 
    50                                     nextChar <- lift $ lookAhead anyChar 
    51                                     let masks' = filterProtoMasks masks chars nextChar 
    52                                     if null masks' || null chars 
    53                                         then lift pzero 
    54                                         else 
    55                                             do 
    56                                             if isJust $ find null masks'  
    57                                                 then put $ Just $ "" 
    58                                                 else put $ Just $ intercalate protocolsSeparator masks'   
    59                                             if nextChar == '*'  
    60                                                 then return $ chars ++ ['*'] 
    61                                                 else return chars 
    62             host = try (append <$> many hostChar <*> char '*') <|> 
    63                    try (append <$> many1 hostChar <*> lookAhead (separator)) <?> "host" 
    64             separator = (oneOf hostSeparators <|> queryEnd) <?> "separator" 
    65             query = notFollowedBy (try $ string "//") *> manyTill anyChar (lookAhead (try queryEnd)) <?> "query" 
    66             queryEnd = (char '|' <* eof) <|> ('\0' <$ eof) <?> "query end" 
    67              
    68 filterProtoMasks :: [String] -> String -> Char -> [String] 
    69 filterProtoMasks masks chars nextChar = catMaybes $ map filterProtoMask masks 
    70     where filterProtoMask mask = if nextChar /= '*'  
    71                                     then if isSuffixOf chars mask 
    72                                          then Just "" 
    73                                          else Nothing  
    74                                     else let tailFound = find (chars `isPrefixOf`) (tails mask) 
    75                                          in drop (length chars) <$> tailFound  
    76  
    77                     
    78 data Path = Path { _bindStart :: Int, 
    79                    _proto :: String, 
    80                    _hosts :: String, 
    81                    _query :: String, 
    82                    _bindEnd :: Bool 
    83                    } 
    84               deriving (Show) 
    85  
    86 hostChar :: Parser Char 
    87 hostChar = alphaNum <|> oneOf ".-:" 
    88  
    89 protocols :: [String] 
    90 protocols = ["https://", "http://"] 
    91  
    92 protocolsSeparator :: String 
    93 protocolsSeparator = ";" 
    94  
    95 protocolChar :: Parser Char 
    96 protocolChar = oneOf (delete '/' $ nub $ join $ protocols) 
    97  
    98 hostSeparators :: String 
    99 hostSeparators = "^/" 
    100  
    101 normalizeLines :: [Line] -> [Line] 
    102 normalizeLines = join.fmap normalizeLine 
    103  
    104 normalizeLine :: Line -> [Line] 
    105 normalizeLine (Line text (ElementHide restr excl pattern)) =  
    106         [(Line text (ElementHide (normalizeRestrictions restr) excl pattern))] 
    107 normalizeLine (Line text (RequestBlock excl pattern  
    108        (RequestOptions restrRt tp restrDom mc coll dnt u))) = newLine <$> (normalizeBlockPattern pattern) 
    109         where newLine pattern' = 
    110                 (Line text (RequestBlock excl pattern'  
    111                  (RequestOptions (normalizeRestrictions restrRt) tp (normalizeRestrictions restrDom) mc coll dnt u)))  
    112 normalizeLine a = [a] 
    113  
    114 normalizeBlockPattern :: Pattern -> [Pattern] 
    115 normalizeBlockPattern p = undefined 
    116  
    117 normalizeRestrictions :: (Eq a) => Restrictions a -> Restrictions a 
    118 normalizeRestrictions = annigilate.allowAll.deduplicate 
    119     where  
     12  
     13opa s = case parseUrl s of 
     14        Left e -> putStrLn $ show e 
     15        Right urls -> putStrLn $ intercalate "\n" $ makePattern <$> urls   
     16  
     17fixLines :: [Line] -> [Line] 
     18fixLines = join . fmap fixLine 
     19 
     20fixLine :: Line -> [Line] 
     21fixLine  (Line text (ElementHide                  restr  excl pattern))  
     22       = [Line text (ElementHide (fixRestrictions restr) excl pattern)] 
     23  
     24fixLine  (Line text                     requestBlock@(RequestBlock _ _ _))  
     25       =  Line text <$> fixRequestBlock requestBlock  
     26          where     
     27              fixRequestBlock      (RequestBlock excl                       pattern                  options) 
     28                             = case RequestBlock excl <<$> (fixBlockPattern pattern) $>> (fixOptions options) of 
     29                                    Right res     -> res 
     30                                    Left  problem -> [Error $ show problem] 
     31              fixRequestBlock _ = undefined 
     32                              
     33              fixOptions (RequestOptions                  restrRt  tp                  restrDom  mc coll dnt u)  
     34                        = RequestOptions (fixRestrictions restrRt) tp (fixRestrictions restrDom) mc coll dnt u  
     35               
     36              fixBlockPattern :: Pattern -> Either ParseError [Pattern] 
     37              fixBlockPattern pattern = makePattern <<$> (parseUrl pattern) 
     38                                                    
     39          
     40fixLine a = [a] 
     41 
     42fixRestrictions :: (Eq a) => Restrictions a -> Restrictions a 
     43fixRestrictions = annigilate.allowAll.deduplicate 
     44        where  
    12045        deduplicate (Restrictions (Just p) n) = Restrictions (Just $ nub p) (nub n) 
    12146        deduplicate a = a 
     
    12348        allowAll a = a 
    12449        annigilate (Restrictions (Just p) n) =  
    125                             let notN x = not (x `elem` n) 
     50                            let notN x = x `notElem` n 
    12651                            in Restrictions (Just $ filter notN p) n 
    12752        annigilate a = a 
     53         
     54 
     55data SideBind = Hard | Soft | None deriving (Show, Eq)  
     56 
     57data UrlPattern = UrlPattern {  
     58                   _bindStart :: SideBind, 
     59                   _proto :: String, 
     60                   _host :: String, 
     61                   _query :: String, 
     62                   _bindEnd :: SideBind, 
     63                   _regex :: Bool } 
     64              deriving (Show) 
     65 
     66makePattern :: UrlPattern -> Pattern 
     67makePattern (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 
     114hostSeparators :: String 
     115hostSeparators = "^/" 
     116 
     117parseUrl :: Pattern -> Either ParseError [UrlPattern] 
     118parseUrl =   
     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                 
     228         
     229 
     230 
     231 
    128232 
    129233             
  • src/ParserExtTests.hs

    rf7023f1 r861fbae  
    1111import Data.Maybe 
    1212import Control.Monad.State 
    13 import Debug.Trace 
    1413 
    1514-------------------------------------------------------------------------------- 
  • src/Utils.hs

    rf7023f1 r861fbae  
    1111maxList, 
    1212minList, 
    13 compareList 
     13compareList, 
     14pure', 
     15pure'', 
     16(<<$>), 
     17(<<<$>), 
     18(<<*>>), 
     19(<<<*>>>), 
     20($>), 
     21($>>), 
     22($>>>) 
    1423) where 
    1524import Control.Applicative hiding (many) 
     
    7685instance Struct5 (,,,,) where struct5 = (,,,,) 
    7786 
     87 
    7888--------------------------------------------------------------------------------------------- 
    7989------------------------- usage sample ------------------------------------------------------ 
     
    8494--  Just ( "" ,  1,  False ), 
    8595--  Just ( "" ,  0 , True  )] 
    86 ------------------------- 
     96-------------------------  
    8797testSquare :: [Maybe (String, Sum Int, Any)] 
    88 testSquare = square3 (Just "a") (Just (Sum 1)) (Just (Any True)) 
     98testSquare = square3 (Just "a") (Just (Sum $ length "")) (Just (Any True)) 
    8999 
    90100----------------------------------------------------------------------------------------------- 
     
    113123                                       -> f a -- becomes State Int (Int -> f a) after lift with valueOnDiagonal 
    114124                                       -> State Int (Int -> f b) 
    115 (<%>) a b = (liftA2.liftA2 $ (<*>)) a (valueOnDiagonal b) 
     125(<%>) a b = a <<<*>>> valueOnDiagonal b 
    116126 
    117127-- creates square matrix from given lines 
     
    122132                  in    line' <$> [start .. size - 1] 
    123133                   
     134-- pure level 2 
     135pure' :: (Applicative f, Applicative g) => a -> f (g a) 
     136pure' = pure.pure 
     137 
    124138-- pure level 3 
    125139pure'' :: (Applicative f, Applicative g, Applicative h) => a -> f (g (h a)) 
    126140pure'' = pure.pure.pure 
     141 
     142infixl 4 <<$>, <<<$>, $>, $>>, $>>>, <<*>>, <<<*>>> 
     143 
     144(<<$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) 
     145(<<$>) = fmap.fmap 
     146 
     147(<<<$>) :: (Functor f, Functor g, Functor h) => (a -> b) -> f (g (h a)) -> f (g (h b)) 
     148(<<<$>) = fmap.fmap.fmap 
     149 
     150($>) :: (Applicative f) => f (a -> b) -> a -> f b 
     151($>) a b = a <*> pure b  
     152 
     153($>>) :: (Applicative f, Applicative g) => f (g (a -> b)) -> a -> f (g b) 
     154($>>) a b = a <<*>> pure' b  
     155 
     156($>>>) :: (Applicative f, Applicative g, Applicative h) => f (g (h (a -> b))) -> a -> f (g (h b)) 
     157($>>>) a b = a <<<*>>> pure'' b  
     158 
     159(<<*>>) :: (Applicative f, Applicative g) => f (g (a -> b)) -> f (g a) -> f (g b) 
     160(<<*>>) = liftA2 (<*>) 
     161 
     162(<<<*>>>) :: (Applicative f, Applicative g, Applicative h) => f (g (h (a -> b))) ->  f (g (h a)) -> f (g (h b)) 
     163(<<<*>>>) = liftA2 (<<*>>) 
Note: See TracChangeset for help on using the changeset viewer.