source: adblock2privoxy/adblock2privoxy/src/PatternConverter.hs @ e2b555c

Last change on this file since e2b555c was e2b555c, checked in by Alexey Zubritskiy <a.zubritskiy@…>, 4 years ago

Adapted to GHC 7.10, introduced stack build

  • Property mode set to 100644
File size: 9.8 KB
Line 
1module PatternConverter (
2makePattern,
3parseUrl
4) where
5import InputParser
6import Control.Applicative hiding (many)
7import Text.ParserCombinators.Parsec hiding (Line, (<|>))
8import Control.Monad.State
9import Data.List
10import Data.Maybe
11import Data.String.Utils (replace)
12import Data.List.Utils (split)
13import ParsecExt
14import Utils
15
16data SideBind = Hard | Soft | None deriving (Show, Eq)
17
18data UrlPattern = UrlPattern {
19                   _bindStart :: SideBind,
20                   _proto :: String,
21                   _host :: String,
22                   _query :: String,
23                   _bindEnd :: SideBind,
24                   _regex :: Bool }
25              deriving (Show)
26
27makePattern :: Bool -> UrlPattern -> Pattern
28makePattern matchCase (UrlPattern bindStart proto host query bindEnd isRegex)
29            | query' == "" = host'
30            | otherwise    = host' ++ separator' ++ query'
31    where
32        separator'
33            | matchCase = "/(?-i)"
34            | otherwise = "/"
35        host' = case host of
36                    "" -> ""
37                    _  -> changeFirst.changeLast $ host
38                    where
39                    changeLast []     = []
40                    changeLast [lst]
41                        | lst == '|' || lst `elem` hostSeparators   =  []
42                        | lst == '*' || lst == '\0'                 =  "*."
43                        | otherwise                                 =  lst : "*."
44                    changeLast (c:cs) = c : changeLast cs
45
46                    changeFirst []    = []
47                    changeFirst (first:cs)
48                        | first == '*'                       =       '.' :  '*'  : cs
49                        | bindStart == Hard || proto /= ""   =             first : cs
50                        | bindStart == Soft                  =       '.' : first : cs
51                        | otherwise                          = '.' : '*' : first : cs
52
53        query' = case query of
54                    ""     -> ""
55                    (start:other) ->
56                              if isRegex then query
57                              else case query of
58                                '*' : '/' : other' -> replaceQuery '/' other' True
59                                '*' : '^' : other' -> replaceQuery '^' other' True
60                                _                  -> replaceQuery start other (bindStart == None && host == "")
61                              where
62                                replaceQuery c cs openStart = replaceFirst c openStart ++ (join . map replaceWildcard $ cs) ++ queryEnd
63                                replaceFirst '*' _ = ".*"
64                                replaceFirst c openStart
65                                    | c == '/' || c == '^' = if openStart
66                                                             then "(.*" ++ replaceWildcard c ++ ")?"
67                                                             else ""
68                                    | otherwise            = if openStart
69                                                             then ".*" ++ replaceWildcard c
70                                                             else replaceWildcard c
71
72                                queryEnd = if bindEnd == None then "" else "$"
73
74                                replaceWildcard c
75                                    | c == '^'         = "[^\\w%.-]"
76                                    | c == '*'         = ".*"
77                                    | c `elem` special = '\\' : [c]
78                                    | otherwise        = [c]
79                                    where special = "?$.+[]{}()\\|" -- also ^ and * are special
80
81
82hostSeparators :: String
83hostSeparators = "^/"
84
85parseUrl :: Pattern -> Either ParseError [UrlPattern]
86parseUrl =
87    let  raw = makeUrls <$> bindStart <*> cases urlParts <*> bindEnd
88    in   parse (join <$> (fmap.fmap) postfilter raw) "url"
89    where
90        makeUrls start mid end = makeUrl <$> pure start <*> mid <*> pure end
91        makeUrl start (proto, host, query) end = UrlPattern start proto host query end False
92
93        bindStart = (try (Soft <$ string "||") <|> try (Hard <$ string "|") <|> return None) <?> "query start"
94        queryEnd = (char '|' <* eof) <|> ('\0' <$ eof) <|> char '\0' <?> "query end"
95        bindEnd = (\c -> if c == '|' then Hard else None) <$> queryEnd
96        port = option False $ many1 (noneOf ":") *> char ':' *> many1 (digit <|> char '*') *> optionMaybe (oneOf "/^") *> (True <$ queryEnd)
97
98        hostChar :: Parser Char
99        hostChar = alphaNum <|> oneOf ".-:"
100
101        protocols :: [String]
102        protocols = ["https://", "http://"]
103
104        protocolsSeparator :: String
105        protocolsSeparator = ";"
106
107        protocolChar :: Parser Char
108        protocolChar = oneOf (delete '/' $ nub $ join protocols)
109
110        postfilter :: UrlPattern -> [UrlPattern]
111        postfilter url@(UrlPattern bs proto host query be _) = regular ++ regex -- ++ www
112            where
113                regex = if     proto == ""
114                            && host == ""
115                            && "/" `isPrefixOf` query
116                            && length query > 2
117                            && "/" `isSuffixOf` query
118                            then
119                                let query' = take (length query - 2) . drop 1 $ query
120                                in [UrlPattern bs "" "" query' be True]
121                            else []
122                regular = let
123                             leftBound = bs /= None || proto /= ""
124                             rightBound = be /= None || query /= ""
125                             orphanQuery = leftBound && host == "" && query /= "" && not ("*" `isPrefixOf` query)
126                             duplicateHostStar = host == "*"
127                             hostHasDot = isJust $ find (\c -> c == '.' || c == '*') host
128                             firstLevelHost = host /= "" && not hostHasDot && leftBound && rightBound
129                             hasLegalPort = case parse port "host" host of
130                                                Right val -> val
131                                                _ -> False
132                             hasIllegalPort = not hasLegalPort && ":" `isInfixOf` host
133                          in if not (orphanQuery || duplicateHostStar || firstLevelHost || hasIllegalPort)
134                             then
135                                let
136                                    query' = if "*" `isSuffixOf` host && query /= "" then '*' : query else query
137                                in [url {_query = query'}]
138                             else []
139
140        -- TODO: process port as an url part
141        urlParts :: [StringStateParser (String,String,String)]
142        urlParts = square3 proto (manyCases host) (oneCase query)
143            where
144                append xs x = xs ++ [x]
145                proto :: StringStateParser String
146                proto = do
147                        masksString <- get
148                        case masksString of
149                            Nothing ->
150                                do
151                                put $ Just $ intercalate protocolsSeparator protocols
152                                return "" --allow to skip proto
153                            Just masksString' ->
154                                do
155                                let masks = split protocolsSeparator masksString'
156                                if null masks
157                                    then lift pzero -- no continuations available (parser have finished on previous iteration)
158                                    else
159                                        do
160                                        lift $ skipMany $ char '*' --skip leading * if presented
161                                        name <- lift $ many protocolChar
162                                        sep <- lift $ many $ oneOf hostSeparators
163                                        let chars = name ++ replace "^" "//" sep -- concatenate input and expand separator wildcard
164                                        nextChar <- lift $ lookAhead anyChar
165                                        let masks' = filterProtoMasks masks chars nextChar -- find possible continuations for current input
166                                        if null masks' || null chars
167                                            then lift pzero -- fail parser if no continuations or no chars read
168                                            else
169                                                do
170                                                put $ Just $ if isJust (find null masks')  -- if empty continuation found (i.e. parser finished)
171                                                                then "" -- make no continuations available next time
172                                                                else intercalate protocolsSeparator masks'
173                                                return $ if nextChar == '*' then chars ++ "*" else chars
174                host = try (append <$> many hostChar <*> char '*') <|>
175                       try (append <$> many1 hostChar <*> lookAhead separator) <?> "host"
176                separator = (oneOf hostSeparators <|> queryEnd) <?> "separator"
177                query = notFollowedBy (try $ string "//") *> manyTill anyChar (lookAhead (try queryEnd)) <?> "query"
178
179                filterProtoMasks :: [String] -> String -> Char -> [String]
180                filterProtoMasks masks chars nextChar = mapMaybe filterProtoMask masks
181                    where filterProtoMask mask = if nextChar /= '*'
182                                    then if chars `isSuffixOf` mask
183                                         then Just ""
184                                         else Nothing
185                                    else let tailFound = find (chars `isPrefixOf`) (tails mask)
186                                         in drop (length chars) <$> tailFound
Note: See TracBrowser for help on using the repository browser.