adblock2privoxy-1.3.0: src/PatternConverter.hs
module PatternConverter (
makePattern,
parseUrl
) where
import InputParser
import Control.Applicative hiding (many)
import Text.ParserCombinators.Parsec hiding (Line, (<|>))
import Control.Monad.State
import Data.List
import Data.Maybe
import Data.String.Utils (replace)
import Data.List.Utils (split)
import ParsecExt
import Utils
data SideBind = Hard | Soft | None deriving (Show, Eq)
data UrlPattern = UrlPattern {
_bindStart :: SideBind,
_proto :: String,
_host :: String,
_query :: String,
_bindEnd :: SideBind,
_regex :: Bool }
deriving (Show)
makePattern :: Bool -> UrlPattern -> Pattern
makePattern matchCase (UrlPattern bindStart proto host query bindEnd isRegex)
| query' == "" = host'
| otherwise = host' ++ separator' ++ query'
where
separator'
| matchCase = "/(?-i)"
| otherwise = "/"
host' = case host of
"" -> ""
_ -> changeFirst.changeLast $ host
where
changeLast [] = []
changeLast [lst]
| lst == '|' || lst `elem` hostSeparators = []
| lst == '*' || lst == '\0' = "*."
| otherwise = lst : "*."
changeLast (c:cs) = c : changeLast cs
changeFirst [] = []
changeFirst (first:cs)
| first == '*' = '.' : '*' : cs
| bindStart == Hard || proto /= "" = first : cs
| bindStart == Soft = '.' : first : cs
| otherwise = '.' : '*' : first : cs
query' = case query of
"" -> ""
(start:other) ->
if isRegex then query
else case query of
'*' : '/' : other' -> replaceQuery '/' other' True
'*' : '^' : other' -> replaceQuery '^' other' True
_ -> replaceQuery start other (bindStart == None && host == "")
where
replaceQuery c cs openStart = replaceFirst c openStart ++ (join . map replaceWildcard $ cs) ++ queryEnd
replaceFirst '*' _ = ".*"
replaceFirst c openStart
| c == '/' || c == '^' = if openStart
then "(.*" ++ replaceWildcard c ++ ")?"
else ""
| otherwise = if openStart
then ".*" ++ replaceWildcard c
else replaceWildcard c
queryEnd = if bindEnd == None then "" else "$"
replaceWildcard c
| c == '^' = "[^\\w%.-]"
| c == '*' = ".*"
| c `elem` special = '\\' : [c]
| otherwise = [c]
where special = "?$.+[]{}()\\|" -- also ^ and * are special
hostSeparators :: String
hostSeparators = "^/"
parseUrl :: Pattern -> Either ParseError [UrlPattern]
parseUrl =
let raw = makeUrls <$> bindStart <*> cases urlParts <*> bindEnd
in parse (join <$> (fmap.fmap) postfilter raw) "url"
where
makeUrls start mid end = makeUrl <$> pure start <*> mid <*> pure end
makeUrl start (proto, host, query) end = UrlPattern start proto host query end False
bindStart = (try (Soft <$ string "||") <|> try (Hard <$ string "|") <|> return None) <?> "query start"
queryEnd = (char '|' <* eof) <|> ('\0' <$ eof) <|> char '\0' <?> "query end"
bindEnd = (\c -> if c == '|' then Hard else None) <$> queryEnd
port = option False $ many1 (noneOf ":") *> char ':' *> many1 (digit <|> char '*') *> optionMaybe (oneOf "/^") *> (True <$ queryEnd)
hostChar :: Parser Char
hostChar = alphaNum <|> oneOf ".-:"
protocols :: [String]
protocols = ["https://", "http://"]
protocolsSeparator :: String
protocolsSeparator = ";"
protocolChar :: Parser Char
protocolChar = oneOf (delete '/' $ nub $ join protocols)
postfilter :: UrlPattern -> [UrlPattern]
postfilter url@(UrlPattern bs proto host query be _) = regular ++ regex -- ++ www
where
regex = if proto == ""
&& host == ""
&& "/" `isPrefixOf` query
&& length query > 2
&& "/" `isSuffixOf` query
then
let query' = take (length query - 2) . drop 1 $ query
in [UrlPattern bs "" "" query' be True]
else []
regular = let
leftBound = bs /= None || proto /= ""
rightBound = be /= None || query /= ""
orphanQuery = leftBound && host == "" && query /= "" && not ("*" `isPrefixOf` query)
duplicateHostStar = host == "*"
hostHasDot = isJust $ find (\c -> c == '.' || c == '*') host
firstLevelHost = host /= "" && not hostHasDot && leftBound && rightBound
hasLegalPort = case parse port "host" host of
Right val -> val
_ -> False
hasIllegalPort = not hasLegalPort && ":" `isInfixOf` host
in if not (orphanQuery || duplicateHostStar || firstLevelHost || hasIllegalPort)
then
let
query' = if "*" `isSuffixOf` host && query /= "" then '*' : query else query
in [url {_query = query'}]
else []
-- TODO: process port as an url part
urlParts :: [StringStateParser (String,String,String)]
urlParts = square3 proto (manyCases host) (oneCase query)
where
append xs x = xs ++ [x]
proto :: StringStateParser String
proto = do
masksString <- get
case masksString of
Nothing ->
do
put $ Just $ intercalate protocolsSeparator protocols
return "" --allow to skip proto
Just masksString' ->
do
let masks = split protocolsSeparator masksString'
if null masks
then lift pzero -- no continuations available (parser have finished on previous iteration)
else
do
lift $ skipMany $ char '*' --skip leading * if presented
name <- lift $ many protocolChar
sep <- lift $ many $ oneOf hostSeparators
let chars = name ++ replace "^" "//" sep -- concatenate input and expand separator wildcard
nextChar <- lift $ lookAhead anyChar
let masks' = filterProtoMasks masks chars nextChar -- find possible continuations for current input
if null masks' || null chars
then lift pzero -- fail parser if no continuations or no chars read
else
do
put $ Just $ if isJust (find null masks') -- if empty continuation found (i.e. parser finished)
then "" -- make no continuations available next time
else intercalate protocolsSeparator masks'
return $ if nextChar == '*' then chars ++ "*" else chars
host = try (append <$> many hostChar <*> char '*') <|>
try (append <$> many1 hostChar <*> lookAhead separator) <?> "host"
separator = (oneOf hostSeparators <|> queryEnd) <?> "separator"
query = notFollowedBy (try $ string "//") *> manyTill anyChar (lookAhead (try queryEnd)) <?> "query"
filterProtoMasks :: [String] -> String -> Char -> [String]
filterProtoMasks masks chars nextChar = mapMaybe filterProtoMask masks
where filterProtoMask mask = if nextChar /= '*'
then if chars `isSuffixOf` mask
then Just ""
else Nothing
else let tailFound = find (chars `isPrefixOf`) (tails mask)
in drop (length chars) <$> tailFound