content: {-# LANGUAGE StrictData #-}
  
  module UrlBlocker (
  BlockMethod(..),
  TaggerType(..),
  urlBlock
  ) where
  import InputParser
  import Control.Monad
  import Data.List
  import Data.Char (toLower)
  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
              hSetEncoding outFile utf8
              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 pttrn options))
              = filteringNodes policy (errorToPattern expandedPatterns) options
              where
              expandedPatterns = makePattern (_matchCase options) <<$> parseUrl pttrn
              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 = if getter requestOptions
          then Nothing
          else 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') target) = forwardRegex headerName (_regex filter') ":" "" target
                forward (Forward Nothing target) = forwardRegex "" "" "" "" target
                forward (CancelTagger taggerCode) = forwardRegex headerName "" ":" "-" taggerCode
                forwardRegex header expression value tagPrefix target
                  = let (modifier, lookahead', additionalLines) 
                          = case split "\n" expression of
                              [x]    -> ("Ti", x, [])
                              (x:xs) -> ("i", x, xs) -- the case for third-party
                              _      -> ("Ti", expression, [])
                    in intercalate "\n" $ additionalLines ++
                          [join ["s@^", header, lookahead', value, ".*@", tagPrefix, target, "@", 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
  