{-# LANGUAGE StrictData #-}
module InputParser
( Line (..),
Restrictions (..),
RequestOptions (..),
Record (..),
RequestType (..),
Pattern,
Domain,
Policy (..),
RecordSource (..),
adblockFile,
recordSourceText,
)
where
import Control.Applicative hiding ((<|>))
import Control.Monad
import Data.Char
import Data.Containers.ListUtils
import Data.Functor
import Data.List
import Data.Monoid
import System.FilePath
import Text.Parsec.Permutation
import Text.ParserCombinators.Parsec hiding (Line, many, optional)
import Utils (split)
--------------------------------------------------------------------------
---------------------------- data model ---------------------------------
--------------------------------------------------------------------------
-- composite
data Line = Line RecordSource Record
deriving (Show, Eq)
data RecordSource = RecordSource {_position :: SourcePos, _rawRecord :: String} deriving (Show, Eq)
data Policy = Block | Unblock deriving (Show, Eq, Read, Ord)
data Record
= Error String
| Comment String
| ElementHide (Restrictions Domain) Policy Pattern
| RequestBlock Policy Pattern RequestOptions
deriving (Read, Show, Eq)
data RequestType
= Script
| Image
| Stylesheet
| Object
| Xmlhttprequest
| Popup
| ObjectSubrequest
| Subdocument
| Document
| Other
deriving (Read, Show, Eq, Ord)
data RequestOptions = RequestOptions
{ _requestType :: Restrictions RequestType,
_thirdParty :: Maybe Bool,
_domain :: Restrictions Domain,
_matchCase :: Bool,
_collapse :: Maybe Bool,
_doNotTrack :: Bool,
_elemHide :: Bool,
_unknown :: [String]
}
deriving (Read, Show, Eq)
-- primitive
type Pattern = String
type Domain = String
-- helpers
data Restrictions a = Restrictions
{ _positive :: Maybe [a],
_negative :: [a]
}
deriving (Read, Show, Eq, Ord)
recordSourceText :: RecordSource -> String
recordSourceText (RecordSource position rawRecord) =
concat [rawRecord, " (", takeFileName $ sourceName position, ": ", show $ sourceLine position, ")"]
--------------------------------------------------------------------------
---------------------------- parsers ------------------------------------
--------------------------------------------------------------------------
adblockFile :: Parser [Line]
adblockFile = header *> sepEndBy line (oneOf eol)
where
-- Robust list headers across Adblock Plus, uBlock Origin
header = optional (try headerLine)
headerLine = string "[Adblock Plus " <* version <* string "]" <* lineEnd
version = join <$> sepBy (many1 digit) (char '.')
line :: Parser Line
line = do
position <- getPosition
let text = lookAhead (manyTill anyChar lineEnd)
sourcePosition = RecordSource position <$> text
Line <$> sourcePosition <*> choice (try <$> [comment, elementHide, match, unknown]) <?> "filtering rule"
elementHide :: Parser Record
elementHide = ElementHide <$> domains ',' <*> excludeMatch <*> pattern
where
-- Adblock Plus / uBlock Origin / AdGuard cosmetic-filter markers
excludeMatch = do
_ <- char '#'
isException <- option False (True <$ char '@')
_ <- many (oneOf "$?%")
_ <- char '#'
return $ if isException then Unblock else Block
pattern = manyTill anyChar (lookAhead lineEnd)
match :: Parser Record
match = RequestBlock <$> excludeMatch <*> pattern <*> options
where
excludeMatch = option Block $ Unblock <$ count 2 (char '@')
patternEnd = try (void (char '$') <* requestOptions <* lineEnd) <|> try (void lineEnd)
-- patternEnd looks for a '$' or EOL
pattern = manyTill anyChar (lookAhead patternEnd)
options = option '$' (char '$') *> requestOptions
comment :: Parser Record
comment = Comment <$> (separatorLine <|> commentText <|> hashComment)
where
commentText = char '!' *> many notLineEnd
separatorLine = lookAhead lineEnd $> ""
-- Hosts-file-style or informal lists use a single leading '#'
hashComment = try (char '#' *> notFollowedBy (oneOf "#@$%?") *> many notLineEnd)
unknown :: Parser Record
unknown = Error "Record type detection failed" <$ skipMany notLineEnd
requestOptions :: Parser RequestOptions
requestOptions =
runPermParser $
RequestOptions
<$> (fixRestrictions <$> requestTypes)
<*> (getMaybeAll <$> requestOptionNorm "ThirdParty")
<*> (fixRestrictions <$> optionalDomain)
<*> (getAllOrFalse <$> requestOptionNorm "MatchCase")
<*> (getMaybeAll <$> requestOptionNorm "Collapse")
<*> (getAllOrFalse <$> requestOptionNorm "Donottrack")
<*> (getAllOrFalse <$> requestOptionNorm "Elemhide")
<* manyPerm separator
<*> unknownOption
where
optionalDomain = optionPerm noRestrictions $ try domainOption
requestTypes = Restrictions <$> (Just <$> manyPerm (try requestTypeOption)) <*> manyPerm (try notRequestTypeOption)
notRequestTypeOption = char '~' *> requestTypeOption
requestOptionNorm = manyPerm . try . requestOption
separator = try (lineSpaces *> char ',' <* lineSpaces)
unknownOption = manyPerm $ try unknownOptionItem
-- Discard unknown options used by some filter-list extensions
unknownOptionItem = optionName <* optional (char '=' *> many (noneOf (',' : eol)))
requestOption :: String -> Parser All
requestOption name = All <$> option True (char '~' $> False) <* checkOptionName name
requestTypeOption :: Parser RequestType
requestTypeOption = do
t <- optionName
case reads t of
[(result, "")] -> return result
_ -> pzero <?> "request type"
domainOption :: Parser (Restrictions Domain)
domainOption = checkOptionName "Domain" *> lineSpaces *> char '=' *> lineSpaces *> domains '|'
optionName :: Parser String
optionName = asOptionName <$> ((:) <$> letter <*> many (alphaNum <|> char '-'))
where
capitalize [] = ""
capitalize (x : xs) = toUpper x : (toLower <$> xs)
ws = split "-"
asOptionName = capitalize <=< ws
checkOptionName :: String -> Parser ()
checkOptionName name = do
t <- optionName
when (name /= t) (pzero <?> "option type")
domain :: Parser Domain
domain = join . intersperse "." <$> parts
where
parts = sepBy1 domainPart (char '.')
-- '*' is a valid wildcard label in Adblock Plus / uBlock Origin
domainPart = many1 (alphaNum <|> char '-' <|> char '*')
domains :: Char -> Parser (Restrictions Domain)
domains sep = fixRestrictions <$> runPermParser restrictions
where
restrictions = Restrictions <$> (Just <$> manyPerm (try domain)) <*> manyPerm (try notDomain) <* manyPerm (try separator)
separator = lineSpaces *> char sep <* lineSpaces
notDomain = char '~' *> domain
-- helpers
eol :: String
eol = "\r\n"
lineSpaces :: Parser ()
lineSpaces = skipMany (satisfy isLineSpace) <?> "white space"
where
isLineSpace c = c == ' ' || c == '\t'
lineEnd :: Parser Char
lineEnd = oneOf eol <|> ('\0' <$ eof)
notLineEnd :: Parser Char
notLineEnd = noneOf eol
getMaybeAll :: [All] -> Maybe Bool
getMaybeAll [] = Nothing
getMaybeAll list = Just $ getAll $ mconcat list
getAllOrFalse :: [All] -> Bool
getAllOrFalse [] = False
getAllOrFalse list = getAll $ mconcat list
noRestrictions :: Restrictions a
noRestrictions = Restrictions Nothing []
fixRestrictions :: (Eq a, Ord a) => Restrictions a -> Restrictions a
fixRestrictions = deduplicate . allowAll
where
allowAll (Restrictions (Just []) n) = Restrictions Nothing n
allowAll a = a
deduplicate (Restrictions (Just p) n) = Restrictions (Just $ nubOrd p) (nubOrd n)
deduplicate a = a