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