source: adblock2privoxy/adblock2privoxy/src/OptionsConverter.hs @ 6bfb8d3

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

project structure refactoring

  • Property mode set to 100644
File size: 7.8 KB
Line 
1module OptionsConverter (
2    HeaderFilters,
3    Filter (..),
4    HeaderType (..),
5    HeaderFilter (..),
6    headerFilters
7) where
8import InputParser
9import Control.Applicative
10import Control.Monad
11import Data.List
12import Data.Monoid hiding (Any)
13import Data.Maybe
14import Data.String.Utils (replace)
15import {-# SOURCE #-}  UrlBlocker 
16
17type FilterFabrique = Policy -> RequestOptions -> HeaderPolicy
18data HeaderType = HeaderType {_name :: String, _taggerType :: TaggerType, _level :: Int,
19                              _typeCode :: Char, _fabrique :: FilterFabrique}
20data Filter = Filter { _code :: String, _regex :: String, _orEmpty :: Bool } deriving Eq 
21data HeaderPolicy = Specific Filter | Any | None deriving Eq 
22data HeaderFilter = HeaderFilter HeaderType Filter           
23type HeaderFilters = [[HeaderFilter]]
24
25allTypes :: [HeaderType]
26allTypes = [accept, contentType, requestedWith, referer]
27
28accept, contentType, requestedWith, referer :: HeaderType
29accept = HeaderType "accept" Client 1 'A' acceptFilter
30contentType = HeaderType "content-type" Server 1 'C' contentTypeFilter
31requestedWith = HeaderType "x-requested-with" Client 1 'X' requestedWithFilter
32referer = HeaderType "referer" Client 2 'R' refererFilter
33
34
35headerFilters :: Policy -> Int -> RequestOptions -> Maybe HeaderFilters
36headerFilters _ 0 _ = Just []
37headerFilters policy level requestOptions@RequestOptions{_requestType = requestType}
38    = let requestOptions' = requestOptions{_requestType = convertPopup $ convertOther requestType} 
39      in do 
40         nextLevel <- headerFilters policy (level - 1) requestOptions'
41         let
42            passthrough = checkPassthrough requestOptions' 
43            filters = do
44                       headerType <- allTypes
45                       guard (_level headerType == level)
46                       case (_fabrique headerType) policy requestOptions' of
47                          Specific filter' -> return $ Just $ HeaderFilter headerType filter'
48                          None -> return Nothing
49                          Any -> mzero
50         when (not passthrough && all isNothing filters && not (null filters)) $ fail "filters blocked"
51         return $ case catMaybes filters of
52                    []       -> nextLevel
53                    filters' -> filters' : nextLevel
54
55convertPopup :: Restrictions RequestType -> Restrictions RequestType
56convertPopup (Restrictions positive negative)= Restrictions positive' negative
57    where 
58    positiveContentTypes = fromMaybe [] positive >>= contentTypes True
59    positive' | Popup `elem` negative && null positiveContentTypes = Nothing
60              | otherwise                                          = positive
61
62convertOther :: Restrictions RequestType -> Restrictions RequestType
63convertOther (Restrictions positive negative)= Restrictions positive' negative'
64    where 
65    allContentOptions = [Script, Image, Stylesheet, Object, ObjectSubrequest, Document]
66    positiveList = fromMaybe [] positive
67    negative' | Other `elem` positiveList = allContentOptions \\ positiveList
68              | otherwise                 = negative
69    positive' | Other `elem` negative     = Just $ allContentOptions \\ negative'
70              | positive == Just [Other]  = Nothing
71              | otherwise                 = positive
72   
73checkPassthrough :: RequestOptions -> Bool
74checkPassthrough RequestOptions {_requestType = (Restrictions positive _) }
75    = fromMaybe False $ (not . null . intersect [Subdocument, Popup]) <$> positive
76 
77acceptFilter, contentTypeFilter, requestedWithFilter, refererFilter :: FilterFabrique
78
79contentTypeFilter  policy (RequestOptions (Restrictions positive negative) thirdParty _ _ _ _ _ _)
80    | fromMaybe True emptyPositive && (not $ isNothing positive) = None
81    | result == mempty = Any 
82    | otherwise = Specific $ Filter code regex orEmpty
83    where 
84    negative' | isNothing positive && fromMaybe False thirdParty = Document : negative
85              | otherwise                  = negative   
86    negativePart = mappend ("n", "") <$> convert False negative'
87    positivePart = positive >>= convert True
88    result@(code, regex) = mconcat $ catMaybes [positivePart, negativePart]
89    orEmpty = (policy == Unblock) && isNothing positive
90    emptyPositive = null . filter (`notElem` (fromMaybe "" $ fst <$> negativePart)) . fst <$> positivePart
91   
92    convert  _      []                        = Nothing
93    convert include requestTypes | null code' = Nothing
94                                 | otherwise  = Just (code', regex')
95        where   contentTypes' = nub $ requestTypes >>= contentTypes include
96                code' = sort $ (head . dropWhile (`elem` "/(?:x-)")) <$> contentTypes'
97                regex' = lookahead contentTypes' "[\\s\\w]*" include
98   
99acceptFilter excludePattern options = case contentTypeFilter excludePattern options of
100                                            Specific res -> Specific res {_orEmpty = False}
101                                            other      -> other
102                             
103                                       
104requestedWithFilter _ RequestOptions{ _requestType = Restrictions positive negative } =
105        case result of
106            Nothing       -> Any
107            Just result'  -> Specific $ Filter (code result') (lookahead ["xmlhttprequest"] "\\s*" result')  (not result')
108    where
109    code True = "x"
110    code False = "nx"
111    result | Xmlhttprequest `elem` negative                                  = Just False
112           | Xmlhttprequest `elem` fromMaybe [] positive                     = Just True
113           |                           (hasContentTypes False    negative) 
114             && (fromMaybe True $ not . hasContentTypes True <$> positive)   = Just True
115           | otherwise                                                       = Nothing
116    hasContentTypes include = not . all null . fmap (contentTypes include)
117
118
119refererFilter policy RequestOptions{ _thirdParty = thirdParty, _domain = Restrictions positive negative }
120    | fromMaybe False emptyPositive  = None
121    | result == mempty = Any 
122    | otherwise = Specific $ Filter code regex orEmpty
123    where
124    negativePart = mappend ("n", "") <$> convert False negative
125    positivePart = positive >>= convert True
126    thirdPartyPart tp = (if tp then "t" else "nt", 
127                         concat ["(?", lookAheadPolicy $ not tp, 
128                                 ":\\s*(?:https?:\\/\\/)?(?:[\\w.-]*\\.)?([\\w-]+\\.[\\w-]+)[^\\w.-].*\\1$)",
129                                 "\ns@^referer:.*@$&\\t$host@Di"])
130    result@(code, regex) = mconcat $ catMaybes [positivePart, negativePart, thirdPartyPart <$> thirdParty]   
131    emptyPositive = null . filter (`notElem` negative) <$> positive
132    orEmpty =  (policy == Unblock) && (isNothing positive || (not $ fromMaybe True thirdParty))
133    convert _ [] = Nothing
134    convert include domains = let
135        code' = intercalate "][" $ sort domains
136        regex' = lookahead domains "[^\\n]*[./]" include
137        in Just ("[" ++ code' ++ "]", regex')
138
139lookAheadPolicy :: Bool -> [Char]
140lookAheadPolicy True = "="   
141lookAheadPolicy False = "!"           
142   
143lookahead :: [String] -> String -> Bool -> String   
144lookahead list prefix include = join ["(?", lookAheadPolicy include, 
145                  ":", prefix ,"(?:", intercalate "|" $ excapeRx <$> list, "))"]
146                  where
147                  excapeRx = replace "/" "\\/" . replace "." "\\."                         
148                                       
149contentTypes :: Bool -> RequestType -> [String]
150contentTypes _ Script = ["/(?:x-)?javascript"]
151contentTypes _ Image = ["image/"]
152contentTypes _ Stylesheet = ["/css"]
153contentTypes _ Object = ["video/","audio/","/(?:x-)?shockwave-flash"]
154contentTypes _ ObjectSubrequest = ["video/","audio/","/octet-stream"]
155contentTypes _ Document = ["/html", "/xml"]
156contentTypes False Subdocument = ["/html", "/xml"]
157contentTypes _ _ = [] 
158                 
Note: See TracBrowser for help on using the repository browser.