source: adblock2privoxy/adblock2privoxy/src/ElementBlocker.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: 4.9 KB
Line 
1module ElementBlocker (
2elemBlock
3) where
4import InputParser hiding (Policy(..))
5import qualified InputParser
6import PolicyTree
7import qualified Data.Map as Map
8import Data.Maybe
9import Utils
10import System.IO
11import System.FilePath
12import Data.List
13import System.Directory
14import qualified Templates
15import Control.Monad
16import Data.String.Utils (startswith)
17
18
19type BlockedRulesTree = DomainTree [Pattern]
20data ElemBlockData = ElemBlockData [Pattern] BlockedRulesTree deriving Show
21
22elemBlock :: String -> [String] -> [Line] -> IO ()
23elemBlock path info = writeElemBlock . elemBlockData
24    where
25    writeElemBlock :: ElemBlockData -> IO ()
26    writeElemBlock (ElemBlockData flatPatterns rulesTree) =
27        do
28           let debugPath = path </> "debug"
29               filteredInfo = filter ((||) <$> not . startswith "Url:" <*> startswith "Url: http") info
30           createDirectoryIfMissing True path
31           cont <- getDirectoryContents path
32           _ <- sequence $ removeOld <$> cont
33           createDirectoryIfMissing True debugPath
34           writeBlockTree path debugPath rulesTree
35           writePatterns filteredInfo (path </> "ab2p.common.css") (debugPath </> "ab2p.common.css") flatPatterns
36    removeOld entry' =
37        let entry = path </> entry'
38        in do
39           isDir <- doesDirectoryExist entry
40           if isDir then when (head entry' /= '.') $ removeDirectoryRecursive entry
41                    else when (takeExtension entry == ".css") $ removeFile entry
42    writeBlockTree :: String -> String -> BlockedRulesTree -> IO ()
43    writeBlockTree normalNodePath debugNodePath (Node name patterns children) =
44        do
45            createDirectoryIfMissing True normalPath
46            createDirectoryIfMissing True debugPath
47            _ <- sequence (writeBlockTree normalPath debugPath <$> children)
48            writePatterns ["See ab2p.common.css for sources info"] normalFilename debugFilename patterns
49        where
50            normalPath
51                | null name = normalNodePath
52                | otherwise = normalNodePath </> name
53            debugPath
54                | null name = debugNodePath
55                | otherwise = debugNodePath </> name
56            normalFilename = normalPath </> "ab2p.css"
57            debugFilename = debugPath </> "ab2p.css"
58    writePatterns :: [String] -> String -> String -> [Pattern] -> IO ()
59    writePatterns _ _ _ [] = return ()
60    writePatterns info' normalFilename debugFilename patterns =
61         do
62            writeCssFile debugFilename $ intercalate "\n" $ (++ Templates.blockCss) <$> patterns
63            writeCssFile normalFilename $ intercalate "\n" ((++ Templates.blockCss) . intercalate "," <$>
64                                                                            splitEvery 4000 patterns)
65         where
66         splitEvery n = takeWhile (not . null) . unfoldr (Just . splitAt n)
67         writeCssFile filename content =
68                do outFile <- openFile filename WriteMode
69                   hSetEncoding outFile utf8
70                   hPutStrLn outFile "/*"
71                   _ <- mapM (hPutStrLn outFile) info'
72                   hPutStrLn outFile "*/"
73                   hPutStrLn outFile content
74                   hClose outFile
75
76elemBlockData :: [Line] -> ElemBlockData
77elemBlockData input = ElemBlockData
78                        (Map.foldrWithKey appendFlatPattern []              policyTreeMap)
79                        (Map.foldrWithKey appendTreePattern (Node "" [] []) policyTreeMap)
80    where
81    policyTreeMap :: Map.Map String PolicyTree
82    policyTreeMap =  Map.unionWith (trimTree Block .*. mergePolicyTrees Unblock)
83                            blockLinesMap
84                            (erasePolicy Block <$> unblockLinesMap)
85        where
86        blockLinesMap = Map.fromListWith (mergeAndTrim Block) (mapMaybe blockLine input)
87        unblockLinesMap = Map.fromListWith (mergeAndTrim Unblock) (mapMaybe unblockLine input)
88        unblockLine (Line _ (ElementHide domains InputParser.Unblock pattern)) = (,) pattern <$> restrictionsTree Unblock domains
89        unblockLine _ = Nothing
90        blockLine (Line _ (ElementHide domains InputParser.Block pattern)) = (,) pattern <$> restrictionsTree Block domains
91        blockLine _ = Nothing
92
93    appendTreePattern ::  Pattern -> PolicyTree -> BlockedRulesTree -> BlockedRulesTree
94    appendTreePattern pattern policyTree
95          | null $ _children policyTree     = id
96          | otherwise                       = mergeTrees appendPattern policyTree
97       where appendPattern policy patterns = case policy of
98                                                Block -> pattern:patterns
99                                                _     -> patterns
100
101    appendFlatPattern ::  Pattern -> PolicyTree -> [Pattern] -> [Pattern]
102    appendFlatPattern pattern policyTree patterns
103          | null (_children policyTree) && _value policyTree == Block  = pattern:patterns
104          | otherwise                                                  = patterns
Note: See TracBrowser for help on using the repository browser.