source: adblock2privoxy/adblock2privoxy/src/InputParser.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: 7.5 KB
Line 
1module InputParser (
2Line (..),
3Restrictions (..),
4RequestOptions (..),
5Record (..),
6RequestType (..),
7Pattern,
8Domain,
9Policy (..),
10RecordSource (..),
11adblockFile,
12recordSourceText
13)
14where
15import Control.Applicative hiding ((<|>))
16import Text.ParserCombinators.Parsec hiding (Line, many, optional)
17import Data.List.Utils (split)
18import Data.List
19import Data.Char
20import Data.Monoid
21import Control.Monad
22import Text.Parsec.Permutation
23import System.FilePath
24
25--------------------------------------------------------------------------
26---------------------------- data model  ---------------------------------
27--------------------------------------------------------------------------
28
29-- composite
30data Line = Line RecordSource Record
31        deriving (Show,Eq)
32
33data RecordSource = RecordSource { _position :: SourcePos, _rawRecord :: String } deriving (Show,Eq)
34data Policy = Block | Unblock deriving (Show, Eq, Read, Ord)
35data Record =   Error String |
36                Comment String |
37                ElementHide (Restrictions Domain) Policy Pattern |
38                RequestBlock Policy Pattern RequestOptions
39        deriving (Read,Show,Eq)
40
41data RequestType =  Script | Image | Stylesheet | Object | Xmlhttprequest | Popup |
42                    ObjectSubrequest | Subdocument | Document | Other
43                    deriving (Read, Show,Eq)
44
45data RequestOptions = RequestOptions {
46                            _requestType :: Restrictions RequestType,
47                            _thirdParty  :: Maybe Bool,
48                            _domain      :: Restrictions Domain,
49                            _matchCase   :: Bool,
50                            _collapse    :: Maybe Bool,
51                            _doNotTrack  :: Bool,
52                            _elemHide    :: Bool,
53                            _unknown     :: [String]
54                      }
55        deriving (Read,Show,Eq)
56
57-- primitive
58type Pattern = String
59type Domain = String
60
61-- helpers
62data Restrictions a = Restrictions {
63                          _positive :: Maybe [a],
64                          _negative :: [a]}
65        deriving (Read,Show,Eq)
66
67recordSourceText :: RecordSource -> String
68recordSourceText (RecordSource position rawRecord)
69   = concat [rawRecord, " (", takeFileName $ sourceName position, ": ", show $ sourceLine position, ")"]
70
71--------------------------------------------------------------------------
72---------------------------- parsers  ------------------------------------
73--------------------------------------------------------------------------
74
75adblockFile :: Parser [Line]
76adblockFile = header *> sepEndBy line (oneOf eol)
77    where
78        header = string "[Adblock Plus " <* version <* string "]"  <* lineEnd
79        version = join <$> sepBy (many1 digit) (char '.')
80
81
82line :: Parser Line
83line = do
84    position <- getPosition
85    let text = lookAhead (manyTill anyChar lineEnd)
86        sourcePosition = RecordSource position <$> text
87    Line <$> sourcePosition <*> choice (try <$> [comment, elementHide, match, unknown]) <?> "filtering rule"
88
89
90
91elementHide :: Parser Record
92elementHide = ElementHide <$> domains ',' <*> excludeMatch <*> pattern
93    where
94        excludeMatch = char '#' *> ((Block <$ string "#") <|> (Unblock <$ string "@#"))
95        pattern = manyTill anyChar (lookAhead lineEnd)
96
97match :: Parser Record
98match = RequestBlock <$> excludeMatch <*> pattern <*> options
99    where
100        excludeMatch = option Block $ Unblock <$ count 2 (char '@')
101        patternEnd = try (return () <* char '$' <* requestOptions <* lineEnd) <|> try (return () <* lineEnd)
102        pattern = manyTill (noneOf "#") (lookAhead patternEnd)
103        options = option '$' (char '$') *> requestOptions
104
105comment :: Parser Record
106comment = Comment <$> (separatorLine <|> commentText)
107            where commentText = char '!' *> many notLineEnd
108                  separatorLine = lookAhead lineEnd *> return ""
109
110unknown :: Parser Record
111unknown = Error "Record type detection failed" <$ skipMany notLineEnd
112
113requestOptions :: Parser RequestOptions
114requestOptions = runPermParser $ RequestOptions
115                                    <$> (fixRestrictions <$> requestTypes)
116                                    <*> (getMaybeAll <$> requestOptionNorm "ThirdParty")
117                                    <*> (fixRestrictions <$> optionalDomain)
118                                    <*> (getAllOrFalse <$> requestOptionNorm  "MatchCase")
119                                    <*> (getMaybeAll <$> requestOptionNorm "Collapse")
120                                    <*> (getAllOrFalse <$> requestOptionNorm "Donottrack")
121                                    <*> (getAllOrFalse <$> requestOptionNorm "Elemhide")
122                                    <* manyPerm separator
123                                    <*> unknownOption
124    where
125        optionalDomain = optionPerm noRestrictions $ try domainOption
126        requestTypes = Restrictions <$> (Just <$> manyPerm  (try requestTypeOption)) <*> manyPerm (try notRequestTypeOption)
127        notRequestTypeOption = char '~' *> requestTypeOption
128        requestOptionNorm = manyPerm.try.requestOption
129        separator = try (lineSpaces *> char ',' <* lineSpaces)
130        unknownOption = manyPerm $ try optionName
131
132requestOption :: String -> Parser All
133requestOption name = All <$> option True (char '~' *> return False) <* checkOptionName name
134
135
136
137requestTypeOption :: Parser RequestType
138requestTypeOption =  do  t <- optionName
139                         case reads t of
140                            [(result, "")] -> return result
141                            _ -> pzero <?> "request type"
142
143
144
145domainOption :: Parser (Restrictions Domain)
146domainOption =  checkOptionName "Domain" *> lineSpaces *> char '=' *> lineSpaces *> domains '|'
147
148optionName :: Parser String
149optionName = asOptionName <$> ((:) <$> letter <*> many (alphaNum <|> char '-'))
150                where
151                     capitalize [] = ""
152                     capitalize (x:xs) = toUpper x:(toLower<$>xs)
153                     ws = split "-"
154                     asOptionName = join.liftA capitalize.ws
155
156checkOptionName :: String -> Parser ()
157checkOptionName name =  do t <- optionName
158                           when (name /= t) (pzero <?> "option type")
159
160domain :: Parser Domain
161domain = join <$> intersperse "." <$> parts
162            where
163            parts = sepBy1 domainPart (char '.')
164            domainPart = many1 (alphaNum <|> char '-')
165
166domains :: Char -> Parser (Restrictions Domain)
167domains sep = fixRestrictions <$> runPermParser restrictions
168    where
169        restrictions = Restrictions <$> (Just <$> manyPerm  (try domain)) <*> manyPerm  (try notDomain) <* manyPerm (try separator)
170        separator = lineSpaces *> char sep <* lineSpaces
171        notDomain = char '~' *> domain
172
173--helpers
174eol :: String
175eol = "\r\n"
176
177lineSpaces :: Parser ()
178lineSpaces = skipMany (satisfy isLineSpace) <?> "white space"
179    where isLineSpace c = c == ' ' || c == '\t'
180
181lineEnd :: Parser Char
182lineEnd = oneOf eol <|> ('\0' <$ eof)
183
184notLineEnd :: Parser Char
185notLineEnd = noneOf eol
186
187
188getMaybeAll :: [All] -> Maybe Bool
189getMaybeAll [] = Nothing
190getMaybeAll list = Just $ getAll $ mconcat list
191
192getAllOrFalse :: [All] -> Bool
193getAllOrFalse [] = False
194getAllOrFalse list = getAll $ mconcat list
195
196noRestrictions :: Restrictions a
197noRestrictions = Restrictions Nothing []
198
199fixRestrictions :: (Eq a) => Restrictions a -> Restrictions a
200fixRestrictions = deduplicate.allowAll
201        where
202        allowAll (Restrictions (Just []) n) = Restrictions Nothing n
203        allowAll a = a
204        deduplicate (Restrictions (Just p) n) = Restrictions (Just $ nub p) (nub n)
205        deduplicate a = a
Note: See TracBrowser for help on using the repository browser.