module ElementBlocker (
elemBlock
) where
import InputParser hiding (Policy(..))
import qualified InputParser
import PolicyTree
import Control.Applicative
import qualified Data.Map as Map
import Data.Maybe
import Utils
import System.IO hiding (hGetContents)
import System.FilePath
import Data.List
import System.Directory
import qualified Templates
import Control.Monad
type BlockedRulesTree = DomainTree [Pattern]
data ElemBlockData = ElemBlockData [Pattern] BlockedRulesTree deriving Show
elemBlock :: String -> [String] -> [Line] -> IO ()
elemBlock path info = writeElemBlock . elemBlockData
where
writeElemBlock :: ElemBlockData -> IO ()
writeElemBlock (ElemBlockData flatPatterns rulesTree) =
do
let debugPath = path </> "debug"
createDirectoryIfMissing True path
cont <- getDirectoryContents path
_ <- sequence $ removeOld <$> cont
createDirectoryIfMissing True debugPath
writeBlockTree path debugPath rulesTree
writePatterns info (path </> "ab2p.common.css") (debugPath </> "ab2p.common.css") flatPatterns
removeOld entry' =
let entry = path </> entry'
in do
isDir <- doesDirectoryExist entry
if isDir then when (head entry' /= '.') $ removeDirectoryRecursive entry
else when (takeExtension entry == ".css") $ removeFile entry
writeBlockTree :: String -> String -> BlockedRulesTree -> IO ()
writeBlockTree normalNodePath debugNodePath (Node name patterns children) =
do
createDirectoryIfMissing True normalPath
createDirectoryIfMissing True debugPath
_ <- sequence (writeBlockTree normalPath debugPath <$> children)
writePatterns ["See ab2p.common.css for sources info"] normalFilename debugFilename patterns
where
normalPath
| null name = normalNodePath
| otherwise = normalNodePath </> name
debugPath
| null name = debugNodePath
| otherwise = debugNodePath </> name
normalFilename = normalPath </> "ab2p.css"
debugFilename = debugPath </> "ab2p.css"
writePatterns :: [String] -> String -> String -> [Pattern] -> IO ()
writePatterns _ _ _ [] = return ()
writePatterns info' normalFilename debugFilename patterns =
do
writeCssFile debugFilename $ intercalate "\n" $ (++ Templates.blockCss) <$> patterns
writeCssFile normalFilename $ intercalate "\n" $ (++ Templates.blockCss) <$> intercalate "," <$>
splitEvery 4000 patterns
where
splitEvery n = takeWhile (not . null) . unfoldr (Just . splitAt n)
writeCssFile filename content =
do outFile <- openFile filename WriteMode
hPutStrLn outFile "/*"
_ <- mapM (hPutStrLn outFile) info'
hPutStrLn outFile "*/"
hPutStrLn outFile content
hClose outFile
elemBlockData :: [Line] -> ElemBlockData
elemBlockData input = ElemBlockData
(Map.foldrWithKey appendFlatPattern [] policyTreeMap)
(Map.foldrWithKey appendTreePattern (Node "" [] []) policyTreeMap)
where
policyTreeMap :: Map.Map String PolicyTree
policyTreeMap = Map.unionWith (trimTree Block .*. mergePolicyTrees Unblock)
blockLinesMap
(erasePolicy Block <$> unblockLinesMap)
where
blockLinesMap = Map.fromListWith (mergeAndTrim Block) (mapMaybe blockLine input)
unblockLinesMap = Map.fromListWith (mergeAndTrim Unblock) (mapMaybe unblockLine input)
unblockLine (Line _ (ElementHide domains InputParser.Unblock pattern)) = (,) pattern <$> restrictionsTree Unblock domains
unblockLine _ = Nothing
blockLine (Line _ (ElementHide domains InputParser.Block pattern)) = (,) pattern <$> restrictionsTree Block domains
blockLine _ = Nothing
appendTreePattern :: Pattern -> PolicyTree -> BlockedRulesTree -> BlockedRulesTree
appendTreePattern pattern policyTree
| null $ _children policyTree = id
| otherwise = mergeTrees appendPattern policyTree
where appendPattern policy patterns = case policy of
Block -> pattern:patterns
_ -> patterns
appendFlatPattern :: Pattern -> PolicyTree -> [Pattern] -> [Pattern]
appendFlatPattern pattern policyTree patterns
| null (_children policyTree) && _value policyTree == Block = pattern:patterns
| otherwise = patterns