adblock2privoxy-3.0.0: src/OptionsConverter.hs

{-# LANGUAGE StrictData #-}

module OptionsConverter
  ( HeaderFilters,
    Filter (..),
    HeaderType (..),
    HeaderFilter (..),
    headerFilters,
  )
where

import Control.Monad
import Data.Containers.ListUtils
import Data.List
import Data.Maybe
import InputParser
import {-# SOURCE #-} UrlBlocker
import Utils (replace)

type FilterFabrique = Policy -> RequestOptions -> HeaderPolicy

data HeaderType = HeaderType
  { _name :: String,
    _taggerType :: TaggerType,
    _level :: Int,
    _typeCode :: Char,
    _fabrique :: FilterFabrique
  }

data Filter = Filter {_code :: String, _regex :: String, _orEmpty :: Bool} deriving (Eq)

data HeaderPolicy = Specific Filter | Any | None deriving (Eq)

data HeaderFilter = HeaderFilter HeaderType Filter

type HeaderFilters = [[HeaderFilter]]

allTypes :: [HeaderType]
allTypes = [accept, contentType, requestedWith, referer]

accept, contentType, requestedWith, referer :: HeaderType
accept = HeaderType "accept" Client 1 'A' acceptFilter
contentType = HeaderType "content-type" Server 1 'C' contentTypeFilter
requestedWith = HeaderType "x-requested-with" Client 1 'X' requestedWithFilter
referer = HeaderType "referer" Client 2 'R' refererFilter

headerFilters :: Policy -> Int -> RequestOptions -> Maybe HeaderFilters
headerFilters _ 0 _ = Just []
headerFilters policy level requestOptions@RequestOptions {_requestType = requestType} =
  let requestOptions' = requestOptions {_requestType = convertPopup $ convertOther requestType}
   in do
        nextLevel <- headerFilters policy (level - 1) requestOptions'
        let passthrough = checkPassthrough requestOptions'
            filters = do
              headerType <- allTypes
              guard (_level headerType == level)
              case _fabrique headerType policy requestOptions' of
                Specific filter' -> return $ Just $ HeaderFilter headerType filter'
                None -> return Nothing
                Any -> mzero
        when (not passthrough && all isNothing filters && not (null filters)) $ fail "filters blocked"
        return $ case catMaybes filters of
          [] -> nextLevel
          filters' -> filters' : nextLevel

convertPopup :: Restrictions RequestType -> Restrictions RequestType
convertPopup (Restrictions positive negative) = Restrictions positive' negative
  where
    positiveContentTypes = fromMaybe [] positive >>= contentTypes True
    positive'
      | Popup `elem` negative && null positiveContentTypes = Nothing
      | otherwise = positive

convertOther :: Restrictions RequestType -> Restrictions RequestType
convertOther (Restrictions positive negative) = Restrictions positive' negative'
  where
    allContentOptions = [Script, Image, Stylesheet, Object, ObjectSubrequest, Document]
    positiveList = fromMaybe [] positive
    negative'
      | Other `elem` positiveList = allContentOptions \\ positiveList
      | otherwise = negative
    positive'
      | Other `elem` negative = Just $ allContentOptions \\ negative'
      | positive == Just [Other] = Nothing
      | otherwise = positive

checkPassthrough :: RequestOptions -> Bool
checkPassthrough RequestOptions {_requestType = (Restrictions positive _)} =
  maybe False (not . null . intersect [Subdocument, Popup]) positive

acceptFilter, contentTypeFilter, requestedWithFilter, refererFilter :: FilterFabrique
contentTypeFilter policy (RequestOptions (Restrictions positive negative) thirdParty _ _ _ _ _ _)
  | fromMaybe True emptyPositive && isJust positive = None
  | result == mempty = Any
  | otherwise = Specific $ Filter code regex orEmpty
  where
    negative'
      | isNothing positive && fromMaybe False thirdParty = Document : negative
      | otherwise = negative
    negativePart = mappend ("n", "") <$> convert False negative'
    positivePart = positive >>= convert True
    result@(code, regex) = mconcat $ catMaybes [positivePart, negativePart]
    orEmpty = (policy == Unblock) && isNothing positive
    emptyPositive = not . any (`notElem` maybe "" fst negativePart) . fst <$> positivePart

    convert _ [] = Nothing
    convert include requestTypes
      | null code' = Nothing
      | otherwise = Just (code', regex')
      where
        contentTypes' = nubOrd $ requestTypes >>= contentTypes include
        code' = sort $ mapMaybe (listToMaybe . dropWhile (`elem` "/(?:x-)")) contentTypes'
        regex' = lookahead contentTypes' "[\\s\\w]*" include
acceptFilter excludePattern options = case contentTypeFilter excludePattern options of
  Specific res -> Specific res {_orEmpty = False}
  other -> other
requestedWithFilter _ RequestOptions {_requestType = Restrictions positive negative} =
  case result of
    Nothing -> Any
    Just result' -> Specific $ Filter (code result') (lookahead ["xmlhttprequest"] "\\s*" result') (not result')
  where
    code True = "x"
    code False = "nx"
    result
      | Xmlhttprequest `elem` negative = Just False
      | Xmlhttprequest `elem` fromMaybe [] positive = Just True
      | hasContentTypes False negative
          && maybe True (not . hasContentTypes True) positive =
          Just True
      | otherwise = Nothing
    hasContentTypes include = not . all (null . contentTypes include)
refererFilter policy RequestOptions {_thirdParty = thirdParty, _domain = Restrictions positive negative}
  | fromMaybe False emptyPositive = None
  | result == mempty = Any
  | otherwise = Specific $ Filter code regex orEmpty
  where
    negativePart = mappend ("n", "") <$> convert False negative
    positivePart = positive >>= convert True
    thirdPartyPart tp =
      ( if tp then "t" else "nt",
        concat
          [ "(?",
            lookAheadPolicy $ not tp,
            ":\\s*(?:https?:\\/\\/)?(?:[\\w.-]*\\.)?([\\w-]+\\.[\\w-]+)[^\\w.-].*\\1$)",
            "\ns@^referer:.*@$&\\t$host@Di"
          ]
      )
    result@(code, regex) = mconcat $ catMaybes [positivePart, negativePart, thirdPartyPart <$> thirdParty]
    emptyPositive = not . any (`notElem` negative) <$> positive
    orEmpty = (policy == Unblock) && (isNothing positive || not (fromMaybe True thirdParty))
    convert _ [] = Nothing
    convert include domains =
      let code' = intercalate "][" $ sort domains
          regex' = lookahead domains "[^\\n]*[./]" include
       in Just ("[" ++ code' ++ "]", regex')

lookAheadPolicy :: Bool -> String
lookAheadPolicy True = "="
lookAheadPolicy False = "!"

lookahead :: [String] -> String -> Bool -> String
lookahead list prefix include =
  join
    [ "(?",
      lookAheadPolicy include,
      ":",
      prefix,
      "(?:",
      intercalate "|" $ excapeRx <$> list,
      "))"
    ]
  where
    excapeRx = replace "/" "\\/" . replace "." "\\."

contentTypes :: Bool -> RequestType -> [String]
contentTypes _ Script = ["/(?:x-)?javascript"]
contentTypes _ Image = ["image/"]
contentTypes _ Stylesheet = ["/css"]
contentTypes _ Object = ["video/", "audio/", "/(?:x-)?shockwave-flash"]
contentTypes _ ObjectSubrequest = ["video/", "audio/", "/octet-stream"]
contentTypes _ Document = ["/html", "/xml"]
contentTypes False Subdocument = ["/html", "/xml"]
contentTypes _ _ = []