source: adblock2privoxy/adblock2privoxy/src/UrlBlocker.hs @ ff7ee56

Last change on this file since ff7ee56 was ff7ee56, checked in by zubr <a@…>, 5 years ago

Fixes and docs

  • Property mode set to 100644
File size: 12.9 KB
Line 
1module UrlBlocker (
2BlockMethod(..),
3TaggerType(..),
4urlBlock
5) where
6import InputParser
7import Control.Applicative
8import Control.Monad
9import Data.List
10import Data.Char (toLower)
11import Data.Monoid
12import OptionsConverter
13import Utils 
14import Control.Monad.State
15import qualified Templates 
16import qualified Data.Map as Map
17import Data.String.Utils (split)
18import Data.Maybe   
19import System.IO 
20import System.FilePath
21import PatternConverter         
22
23data TaggerType = Client | Server
24data TaggerForwarder = Forward (Maybe Filter) String | CancelTagger String
25data Tagger = Tagger { _taggerCode :: String, _forwarding :: [TaggerForwarder], _headerType :: HeaderType }
26
27data ActionType   = TaggerAction Tagger | BlockAction | TerminalAction BlockMethod
28data ActionSwitch = Switch Bool ActionType
29data Action = Action { _actionCode :: String, _switches :: [ActionSwitch], _patterns :: [Pattern], _hasTag :: Bool }
30
31data ChainType = Regular | Nested | Negate deriving (Eq, Ord)
32type UrlBlockData = ([Tagger], [Action])
33data BlockMethod = Request | Xframe | Elem | Dnt | Xpopup deriving (Show, Eq)
34data FilteringNode = Node { _pattern :: [Pattern], _filters :: HeaderFilters, _nodeType :: ChainType, 
35    _policy :: Policy, _method :: BlockMethod }
36
37
38class Named a where
39    name :: a -> String
40
41urlBlock :: String -> [String] -> [Line] -> IO()
42urlBlock path info = writeBlockData . urlBlockData
43    where   
44    writeBlockData :: UrlBlockData -> IO()
45    writeBlockData (taggers, actions) = 
46        do writeContent (path </> "ab2p.filter") Templates.filtersFilePrefix taggers
47           writeContent (path </> "ab2p.action") Templates.actionsFilePrefix actions
48    writeContent filename header content = 
49         do outFile <- openFile filename WriteMode
50            hSetEncoding outFile utf8
51            hPutStrLn outFile header
52            _ <- mapM (hPutStrLn outFile) $ ('#':) <$> info
53            hPutStrLn outFile $ intercalate "\n\n" $ show <$> content
54            hClose outFile
55
56urlBlockData :: [Line] -> UrlBlockData 
57urlBlockData lns = filterBlockData result
58    where
59    result = mconcat [nodeResult node | node <- shortenNodes $ sortBy cmpPolicy $ filterNodesList blockLines]
60    cmpPolicy node1 node2 = compare (_policy node1) (_policy node2)
61    blockLines = lns >>= blockLine
62        where 
63        blockLine (Line position (RequestBlock policy pattern options)) 
64            = filteringNodes policy (errorToPattern expandedPatterns) options
65            where 
66            expandedPatterns = makePattern (_matchCase options) <<$> parseUrl pattern
67            sourceText = recordSourceText position
68            errorToPattern (Left parseError) = ["# ERROR: " ++ sourceText  ++ " - " ++ show parseError]
69            errorToPattern (Right patterns') = ("# " ++ sourceText) : patterns'
70        blockLine _ = []
71   
72filterNodesList :: [FilteringNode] -> [FilteringNode]
73filterNodesList nodes = Map.foldr (:) [] $ Map.fromListWith joinNodes list
74    where
75    list = [(name node, node) | node <- nodes]
76    joinNodes (Node patterns1 filters1 type1 policy1 method1) 
77              (Node patterns2 _ type2 _ _) 
78        = Node (patterns1 ++ patterns2) filters1 (max type1 type2) policy1 method1
79
80filterBlockData :: UrlBlockData -> UrlBlockData
81filterBlockData blockData = (result, snd blockData)
82    where
83    result = Map.foldr (:) [] $ Map.fromListWith joinTaggers taggerItems
84    taggerItems = [(name tagger, tagger) | tagger <- fst blockData]
85    metric = length._forwarding
86    joinTaggers tagger1 tagger2 | metric tagger1 >= metric tagger2 = tagger1
87                                | otherwise                        = tagger2
88         
89shortenNodes :: [FilteringNode] -> [FilteringNode]     
90shortenNodes nodes = evalState (mapM shortenNode nodes) initialState
91    where 
92    initialState = Map.empty :: Map.Map String String
93    shortenNode node = (\f -> node {_filters = f}) <$> (mapM.mapM) shortenFilter (_filters node)       
94    shortenFilter headerFilter@(HeaderFilter headerType flt) 
95        = let filterCode = _code flt
96          in do 
97             dictionary <- get
98             case Map.lookup filterCode dictionary of 
99                 Just shortenCode -> return $ HeaderFilter headerType flt { _code = shortenCode }
100                 Nothing -> case break (=='[') filterCode of
101                    (_,[]) -> return headerFilter
102                    (start, rest) -> 
103                        let end = last $ split "]" rest
104                            shortenCode' = start ++ show (Map.size dictionary + 1) ++  end
105                        in do put $ Map.insert filterCode shortenCode' dictionary
106                              return $ HeaderFilter headerType flt { _code = shortenCode' }
107                           
108
109filteringNodes :: Policy -> [Pattern] -> RequestOptions -> [FilteringNode]
110filteringNodes policy patterns requestOptions
111    = join.join $  [mainResult, subdocumentResult, elemhideResult, dntResult, popupResult]
112    where 
113    mainResult = optionsToNodes mainOptions $> Request
114    subdocumentResult = maybeToList (optionsToNodes (singleTypeOptions Subdocument) $> Xframe)
115    elemhideResult = maybeToList (optionsToNodes (boolOptions _elemHide) $> Elem)
116    dntResult = maybeToList (optionsToNodes (boolOptions _doNotTrack) $> Dnt)
117    popupResult = maybeToList (optionsToNodes (singleTypeOptions Popup) $> Xpopup)
118    requestType = _requestType requestOptions
119    mainOptions = [requestOptions {_requestType = requestType { _positive = mainPosRequestTypes } }]
120    mainPosRequestTypes = filter (`notElem` [Subdocument]) <$> _positive requestType
121    boolOptions getter = if getter requestOptions
122        then Nothing
123        else Just requestOptions {_requestType = Restrictions Nothing [], _thirdParty = Nothing}
124    singleTypeOptions singleType = 
125        do
126        foundTypes <- filter (== singleType) <$> _positive requestType
127        foundType <- listToMaybe foundTypes
128        return requestOptions {_requestType = requestType { _positive = Just [foundType] } }
129    optionsToNodes options = collectNodes patterns <$> headerFilters policy 2 <$> options
130    nestedOrRegular True = Nested
131    nestedOrRegular False = Regular
132    collectNodes :: [Pattern] -> Maybe HeaderFilters -> BlockMethod -> [FilteringNode]
133    collectNodes _ Nothing _ = [] 
134    collectNodes patterns' (Just []) method = [Node patterns' [] (nestedOrRegular $ null patterns') policy method]
135    collectNodes patterns' (Just filters@(levelFilters: next)) method
136            = Node patterns' filters (nestedOrRegular $ null patterns') policy method
137              : (levelFilters >>= negateNode) 
138              ++ collectNodes [] (Just next) method
139        where 
140        negateNode negateFilter@(HeaderFilter _ (Filter {_orEmpty = True})) 
141                = [Node [] ([negateFilter] : next) Negate policy method]
142        negateNode _ = [] 
143         
144nodeResult :: FilteringNode -> UrlBlockData
145nodeResult node@(Node patterns [] nodeType policy method) = ([], [baseAction])
146    where baseAction = Action (name node) [Switch (policy == Block) $ TerminalAction method] patterns (nodeType == Nested)
147nodeResult node@(Node _ ([flt] : nextLevelFilters) Negate policy method)
148    = ([negateTagger], [negateAction])
149    where
150    negateAction = Action (name node) [Switch False $ TaggerAction negateTagger] [] True
151    negateTagger = newTagger flt nextLevelFilters policy method Negate []
152nodeResult node@(Node patterns (levelFilters : nextLevelFilters) nodeType policy method)
153    = (taggers, [action])
154    where 
155    action = Action { _actionCode = name node,
156                      _switches   = appendIf (policy == Unblock && method == Request) 
157                                        (Switch False BlockAction)
158                                        (Switch True . TaggerAction <$> taggers),
159                      _patterns   = patterns,
160                      _hasTag     = nodeType == Nested } 
161    taggers = filterTaggers <$> levelFilters
162    filterTaggers flt@(HeaderFilter _ (Filter _ _ orEmpty)) 
163        = newTagger flt nextLevelFilters policy method Regular moreForwarding
164        where
165        orEmptyTaggerCode   = filtersCode ([flt] : nextLevelFilters) Negate  policy method ""
166        moreForwarding  | orEmpty = [CancelTagger orEmptyTaggerCode]
167                        | otherwise = []
168           
169newTagger :: HeaderFilter -> HeaderFilters -> Policy -> BlockMethod -> ChainType -> [TaggerForwarder] -> Tagger
170newTagger flt@(HeaderFilter headerType filter') nextLevelFilters policy method chainType moreForwarding
171   = Tagger { _taggerCode = taggerCode,
172              _forwarding = Forward filter'' nextLevelActionCode : moreForwarding,
173              _headerType = headerType }     
174   where
175   filter'' | chainType == Negate = Nothing
176            | otherwise           = Just filter'
177   taggerCode          = filtersCode ([flt] : nextLevelFilters) chainType policy method ""       
178   nextLevelActionCode = filtersCode nextLevelFilters  Nested policy method ""   
179           
180instance Named FilteringNode where
181    name (Node _ filters Negate policy method)  = '-' : filtersCode filters Negate policy method "" 
182    name (Node _ filters _ policy method)  = filtersCode filters Nested policy method "" 
183   
184filtersCode :: HeaderFilters -> ChainType -> Policy -> BlockMethod -> String -> String
185filtersCode [] _ policy method rest
186    = join [Templates.ab2pPrefix, toLower <$> show policy, "-" ,toLower <$> show method, if null rest then "" else "-", rest]
187filtersCode (levelFilters : nextLevelFilters) chainType policy method rest
188    = filtersCode nextLevelFilters Nested policy method $ join [levelCode, if null rest then "" else "-when-", rest]
189    where 
190    levelCode = intercalate "-" $ filterCode <$> levelFilters
191    filterCode (HeaderFilter HeaderType {_typeCode = typeCode} (Filter code _ orEmpty))
192        | chainType == Negate            = negateCode
193        | chainType == Nested && orEmpty = negateCode ++ '-' : mainCode 
194        | otherwise                      = mainCode
195        where 
196        mainCode = typeCode : code
197        negateCode = 'n' : [typeCode]
198
199instance Show TaggerType where
200    show Client = "CLIENT-HEADER-TAGGER"
201    show Server = "SERVER-HEADER-TAGGER"
202
203instance Named TaggerType where
204    name = fmap toLower . show
205
206instance Named Tagger where
207    name = _taggerCode
208
209instance Show Tagger where
210    show (Tagger code forwarding HeaderType {_name = headerName, _taggerType =  taggerType }) 
211        = intercalate "\n" (caption : (forward <$> forwarding))
212        where caption = show taggerType ++ (':' : ' ' : code)
213              forward (Forward (Just filter') tagret) = forwardRegex headerName (_regex filter') ":" "" tagret
214              forward (Forward Nothing tagret) = forwardRegex "" "" "" "" tagret
215              forward (CancelTagger taggerCode) = forwardRegex headerName "" ":" "-" taggerCode
216              forwardRegex header expression value tagPrefix tagret
217                = let  (modifier, lookahead' : additionalLines) 
218                            | '\n' `elem` expression = ("i", split "\n" expression) -- the case for third-party
219                            | otherwise              = ("Ti", [expression])
220                  in intercalate "\n" $ additionalLines ++ 
221                        [join ["s@^", header, lookahead', value, ".*@", tagPrefix, tagret, "@", modifier]] 
222
223instance Named Bool where
224    name True = "+"
225    name False = "-"                 
226
227instance Show ActionSwitch where
228    show (Switch enable (TerminalAction method)) = Templates.terminalActionSwitch enable method
229    show (Switch enable BlockAction) = name enable ++ "block"
230    show (Switch enable (TaggerAction tagger)) 
231        = intercalate " \\\n " $ mainText : (_forwarding tagger >>= cancelTaggerText)
232        where 
233        mainText = join [name enable, name . _taggerType . _headerType $ tagger, "{", name tagger,  "}" ]
234        cancelTaggerText (CancelTagger cancelTaggerCode) 
235            = [join [name enable, name . _taggerType . _headerType $ tagger, "{", cancelTaggerCode,  "}" ]]
236        cancelTaggerText _ = []               
237   
238instance Named Action where
239    name = _actionCode
240   
241instance Show Action where
242    show (Action code switches patterns hasTag)
243        = intercalate "\n" (caption : switches' : patterns')
244        where caption = '#' : code
245              switches' = join ["{", intercalate " \\\n " (show <$> switches), " \\\n}"]
246              patterns' | hasTag    = join ["TAG:^", code, "$"] : patterns
247                        | otherwise = patterns 
248               
249               
250             
251                                       
252                                       
253                                       
254                                       
255                                       
256                                       
257                                       
258                                       
259                                       
260                                       
261                                       
262                                       
263                                       
264   
265   
Note: See TracBrowser for help on using the repository browser.