module UrlBlocker (
BlockMethod(..),
TaggerType(..),
urlBlock
) where
import InputParser
import Control.Applicative
import Control.Monad
import Data.List
import Data.Char (toLower)
import Data.Monoid
import OptionsConverter
import Utils
import Control.Monad.State
import qualified Templates
import qualified Data.Map as Map
import Data.String.Utils (split)
import Data.Maybe
import System.IO
import System.FilePath
import PatternConverter
data TaggerType = Client | Server
data TaggerForwarder = Forward (Maybe Filter) String | CancelTagger String
data Tagger = Tagger { _taggerCode :: String, _forwarding :: [TaggerForwarder], _headerType :: HeaderType }
data ActionType = TaggerAction Tagger | BlockAction | TerminalAction BlockMethod
data ActionSwitch = Switch Bool ActionType
data Action = Action { _actionCode :: String, _switches :: [ActionSwitch], _patterns :: [Pattern], _hasTag :: Bool }
data ChainType = Regular | Nested | Negate deriving (Eq, Ord)
type UrlBlockData = ([Tagger], [Action])
data BlockMethod = Request | Xframe | Elem | Dnt | Xpopup deriving (Show, Eq)
data FilteringNode = Node { _pattern :: [Pattern], _filters :: HeaderFilters, _nodeType :: ChainType,
_policy :: Policy, _method :: BlockMethod }
class Named a where
name :: a -> String
urlBlock :: String -> [String] -> [Line] -> IO()
urlBlock path info = writeBlockData . urlBlockData
where
writeBlockData :: UrlBlockData -> IO()
writeBlockData (taggers, actions) =
do writeContent (path </> "ab2p.filter") Templates.filtersFilePrefix taggers
writeContent (path </> "ab2p.action") Templates.actionsFilePrefix actions
writeContent filename header content =
do outFile <- openFile filename WriteMode
hPutStrLn outFile (header)
_ <- mapM (hPutStrLn outFile) $ ('#':) <$> info
hPutStrLn outFile $ intercalate "\n\n" $ show <$> content
hClose outFile
urlBlockData :: [Line] -> UrlBlockData
urlBlockData lns = filterBlockData $ result
where
result = mconcat [nodeResult node | node <- shortenNodes $ sortBy cmpPolicy $ filterNodesList blockLines]
cmpPolicy node1 node2 = compare (_policy node1) (_policy node2)
blockLines = lns >>= blockLine
where
blockLine (Line position (RequestBlock policy pattern options))
= filteringNodes policy (errorToPattern expandedPatterns) options
where
expandedPatterns = makePattern (_matchCase options) <<$> parseUrl pattern
sourceText = recordSourceText position
errorToPattern (Left parseError) = ["# ERROR: " ++ sourceText ++ " - " ++ show parseError]
errorToPattern (Right patterns') = ("# " ++ sourceText) : patterns'
blockLine _ = []
filterNodesList :: [FilteringNode] -> [FilteringNode]
filterNodesList nodes = Map.foldr (:) [] $ Map.fromListWith joinNodes $ list
where
list = [(name node, node) | node <- nodes]
joinNodes (Node patterns1 filters1 type1 policy1 method1)
(Node patterns2 _ type2 _ _)
= Node (patterns1 ++ patterns2) filters1 (max type1 type2) policy1 method1
filterBlockData :: UrlBlockData -> UrlBlockData
filterBlockData blockData = (result, snd blockData)
where
result = Map.foldr (:) [] $ Map.fromListWith joinTaggers taggerItems
taggerItems = [(name tagger, tagger) | tagger <- fst blockData]
metric = length._forwarding
joinTaggers tagger1 tagger2 | metric tagger1 >= metric tagger2 = tagger1
| otherwise = tagger2
shortenNodes :: [FilteringNode] -> [FilteringNode]
shortenNodes nodes = evalState (mapM shortenNode nodes) initialState
where
initialState = Map.empty :: Map.Map String String
shortenNode node = (\f -> node {_filters = f}) <$> ((mapM.mapM) shortenFilter $ _filters node)
shortenFilter headerFilter@(HeaderFilter headerType flt)
= let filterCode = _code flt
in do
dictionary <- get
case Map.lookup filterCode dictionary of
Just shortenCode -> return $ HeaderFilter headerType flt { _code = shortenCode }
Nothing -> case break (=='[') filterCode of
(_,[]) -> return headerFilter
(start, rest) ->
let end = last $ split "]" rest
shortenCode' = start ++ (show $ Map.size dictionary + 1) ++ end
in do put $ Map.insert filterCode shortenCode' dictionary
return $ HeaderFilter headerType flt { _code = shortenCode' }
filteringNodes :: Policy -> [Pattern] -> RequestOptions -> [FilteringNode]
filteringNodes policy patterns requestOptions
= join.join $ [mainResult, subdocumentResult, elemhideResult, dntResult, popupResult]
where
mainResult = optionsToNodes mainOptions $> Request
subdocumentResult = maybeToList (optionsToNodes (singleTypeOptions Subdocument) $> Xframe)
elemhideResult = maybeToList (optionsToNodes (boolOptions _elemHide) $> Elem)
dntResult = maybeToList (optionsToNodes (boolOptions _doNotTrack) $> Dnt)
popupResult = maybeToList (optionsToNodes (singleTypeOptions Popup) $> Xpopup)
requestType = _requestType requestOptions
mainOptions = [requestOptions {_requestType = requestType { _positive = mainPosRequestTypes } }]
mainPosRequestTypes = filter (`notElem` [Subdocument]) <$> (_positive requestType)
boolOptions getter = case getter requestOptions of
False -> Nothing
True -> Just requestOptions {_requestType = Restrictions Nothing [], _thirdParty = Nothing}
singleTypeOptions singleType =
do
foundTypes <- filter (== singleType) <$> (_positive requestType)
foundType <- listToMaybe foundTypes
return requestOptions {_requestType = requestType { _positive = Just [foundType] } }
optionsToNodes options = collectNodes patterns <$> headerFilters policy 2 <$> options
nestedOrRegular True = Nested
nestedOrRegular False = Regular
collectNodes :: [Pattern] -> Maybe HeaderFilters -> BlockMethod -> [FilteringNode]
collectNodes _ Nothing _ = []
collectNodes patterns' (Just []) method = [Node patterns' [] (nestedOrRegular $ null patterns') policy method]
collectNodes patterns' (Just filters@(levelFilters: next)) method
= Node patterns' filters (nestedOrRegular $ null patterns') policy method
: (levelFilters >>= negateNode)
++ collectNodes [] (Just next) method
where
negateNode negateFilter@(HeaderFilter _ (Filter {_orEmpty = True}))
= [Node [] ([negateFilter] : next) Negate policy method]
negateNode _ = []
nodeResult :: FilteringNode -> UrlBlockData
nodeResult node@(Node patterns [] nodeType policy method) = ([], [baseAction])
where baseAction = Action (name node) [Switch (policy == Block) $ TerminalAction method] patterns (nodeType == Nested)
nodeResult node@(Node _ ([flt] : nextLevelFilters) Negate policy method)
= ([negateTagger], [negateAction])
where
negateAction = Action (name node) [Switch False $ TaggerAction negateTagger] [] True
negateTagger = newTagger flt nextLevelFilters policy method Negate []
nodeResult node@(Node patterns (levelFilters : nextLevelFilters) nodeType policy method)
= (taggers, [action])
where
action = Action { _actionCode = name node,
_switches = appendIf (policy == Unblock && method == Request)
(Switch False BlockAction)
(Switch True . TaggerAction <$> taggers),
_patterns = patterns,
_hasTag = (nodeType == Nested) }
taggers = filterTaggers <$> levelFilters
filterTaggers flt@(HeaderFilter _ (Filter _ _ orEmpty))
= newTagger flt nextLevelFilters policy method Regular moreForwarding
where
orEmptyTaggerCode = filtersCode ([flt] : nextLevelFilters) Negate policy method ""
moreForwarding | orEmpty = [CancelTagger orEmptyTaggerCode]
| otherwise = []
newTagger :: HeaderFilter -> HeaderFilters -> Policy -> BlockMethod -> ChainType -> [TaggerForwarder] -> Tagger
newTagger flt@(HeaderFilter headerType filter') nextLevelFilters policy method chainType moreForwarding
= Tagger { _taggerCode = taggerCode,
_forwarding = Forward filter'' nextLevelActionCode : moreForwarding,
_headerType = headerType }
where
filter'' | chainType == Negate = Nothing
| otherwise = Just filter'
taggerCode = filtersCode ([flt] : nextLevelFilters) chainType policy method ""
nextLevelActionCode = filtersCode nextLevelFilters Nested policy method ""
instance Named FilteringNode where
name (Node _ filters Negate policy method) = '-' : filtersCode filters Negate policy method ""
name (Node _ filters _ policy method) = filtersCode filters Nested policy method ""
filtersCode :: HeaderFilters -> ChainType -> Policy -> BlockMethod -> String -> String
filtersCode [] _ policy method rest
= join [Templates.ab2pPrefix, toLower <$> show policy, "-" ,toLower <$> show method,(if null rest then "" else "-"), rest]
filtersCode (levelFilters : nextLevelFilters) chainType policy method rest
= filtersCode nextLevelFilters Nested policy method $ join [levelCode, (if null rest then "" else "-when-"), rest]
where
levelCode = (intercalate "-" $ filterCode <$> levelFilters)
filterCode (HeaderFilter HeaderType {_typeCode = typeCode} (Filter code _ orEmpty))
| chainType == Negate = negateCode
| chainType == Nested && orEmpty = negateCode ++ '-' : mainCode
| otherwise = mainCode
where
mainCode = typeCode : code
negateCode = 'n' : [typeCode]
instance Show TaggerType where
show Client = "CLIENT-HEADER-TAGGER"
show Server = "SERVER-HEADER-TAGGER"
instance Named TaggerType where
name = fmap toLower . show
instance Named Tagger where
name = _taggerCode
instance Show Tagger where
show (Tagger code forwarding HeaderType {_name = headerName, _taggerType = taggerType })
= intercalate "\n" (caption : (forward <$> forwarding))
where caption = show taggerType ++ (':' : ' ' : code)
forward (Forward (Just filter') tagret) = forwardRegex headerName (_regex filter') ":" "" tagret
forward (Forward Nothing tagret) = forwardRegex "" "" "" "" tagret
forward (CancelTagger taggerCode) = forwardRegex headerName "" ":" "-" taggerCode
forwardRegex header expression value tagPrefix tagret
= let (modifier, lookahead' : additionalLines)
| '\n' `elem` expression = ("i", split "\n" expression) -- the case for third-party
| otherwise = ("Ti", [expression])
in intercalate "\n" $ additionalLines ++
[join ["s@^", header, lookahead', value, ".*@", tagPrefix, tagret, "@", modifier]]
instance Named Bool where
name True = "+"
name False = "-"
instance Show ActionSwitch where
show (Switch enable (TerminalAction method)) = Templates.terminalActionSwitch enable method
show (Switch enable BlockAction) = name enable ++ "block"
show (Switch enable (TaggerAction tagger))
= intercalate " \\\n " $ mainText : (_forwarding tagger >>= cancelTaggerText)
where
mainText = join [name enable, name $ _taggerType $ _headerType $ tagger, "{", name tagger, "}" ]
cancelTaggerText (CancelTagger cancelTaggerCode)
= [join [name enable, name $ _taggerType $ _headerType $ tagger, "{", cancelTaggerCode, "}" ]]
cancelTaggerText _ = []
instance Named Action where
name = _actionCode
instance Show Action where
show (Action code switches patterns hasTag)
= intercalate "\n" (caption : switches' : patterns')
where caption = '#' : code
switches' = join ["{", intercalate " \\\n " (show <$> switches), " \\\n}"]
patterns' | hasTag = join ["TAG:^", code, "$"] : patterns
| otherwise = patterns