1+ {-# LANGUAGE StrictData #-}
2+
13module ElementBlocker (
24elemBlock
35) where
46import InputParser hiding (Policy (.. ))
57import qualified InputParser
68import PolicyTree
9+ import ProgramOptions (DebugLevel (DebugLevel ))
710import qualified Data.Map as Map
811import Data.Maybe
912import Utils
@@ -19,51 +22,45 @@ import Data.String.Utils (startswith)
1922type BlockedRulesTree = DomainTree [Pattern ]
2023data ElemBlockData = ElemBlockData [Pattern ] BlockedRulesTree deriving Show
2124
22- elemBlock :: String -> [String ] -> [Line ] -> IO ()
23- elemBlock path info = writeElemBlock . elemBlockData
25+ elemBlock :: String -> [String ] -> DebugLevel -> [Line ] -> IO ()
26+ elemBlock path info debug = writeElemBlock . elemBlockData
2427 where
2528 writeElemBlock :: ElemBlockData -> IO ()
2629 writeElemBlock (ElemBlockData flatPatterns rulesTree) =
2730 do
28- let filteredInfo = filter ( (||) <$> not . startswith " Url: " <*> startswith " Url: http " ) info
29- -- debugPath = path </> "debug"
31+ let debugPath = path </> " debug "
32+ filteredInfo = filter ( (||) <$> not . startswith " Url: " <*> startswith " Url: http " ) info
3033 createDirectoryIfMissing True path
3134 cont <- getDirectoryContents path
32- _ <- sequence $ removeOld <$> cont
33- -- createDirectoryIfMissing True debugPath
34- -- writeBlockTree path debugPath rulesTree
35- writeBlockTree path rulesTree
36- writePatterns_with_debug filteredInfo (path </> " ab2p.common.css" ) " " flatPatterns
37- -- writePatterns_with_debug filteredInfo (path </> "ab2p.common.css") (debugPath </> "ab2p.common.css") flatPatterns
35+ mapM_ removeOld cont
36+ when (debug > DebugLevel 0 ) $ createDirectoryIfMissing True debugPath
37+ writeBlockTree path debugPath rulesTree
38+ writePatterns filteredInfo (path </> " ab2p.common.css" ) (if debug > DebugLevel 0 then debugPath </> " ab2p.common.css" else " " ) flatPatterns
3839 removeOld entry' =
3940 let entry = path </> entry'
4041 in do
4142 isDir <- doesDirectoryExist entry
4243 if isDir then when (head entry' /= ' .' ) $ removeDirectoryRecursive entry
4344 else when (takeExtension entry == " .css" ) $ removeFile entry
44- -- writeBlockTree :: String -> String -> BlockedRulesTree -> IO ()
45- -- writeBlockTree normalNodePath debugNodePath (Node name patterns children) =
46- writeBlockTree :: String -> BlockedRulesTree -> IO ()
47- writeBlockTree normalNodePath (Node name patterns children) =
45+ writeBlockTree :: String -> String -> BlockedRulesTree -> IO ()
46+ writeBlockTree normalNodePath debugNodePath (Node name patterns children) =
4847 do
4948 createDirectoryIfMissing True normalPath
50- -- createDirectoryIfMissing True debugPath
51- -- _ <- sequence (writeBlockTree normalPath debugPath <$> children)
52- -- writePatterns ["See ab2p.common.css for sources info"] normalFilename debugFilename patterns
53- _ <- sequence (writeBlockTree normalPath <$> children)
54- writePatterns [" See ab2p.common.css for sources info" ] normalFilename patterns
49+ when (debug > DebugLevel 1 ) $ createDirectoryIfMissing True debugPath
50+ mapM_ (writeBlockTree normalPath debugPath) children
51+ writePatterns [" See ab2p.common.css for sources info" ] normalFilename (if debug > DebugLevel 1 then debugFilename else " " ) patterns
5552 where
5653 normalPath
5754 | null name = normalNodePath
5855 | otherwise = normalNodePath </> name
59- -- debugPath
60- -- | null name = debugNodePath
61- -- | otherwise = debugNodePath </> name
56+ debugPath
57+ | null name = debugNodePath
58+ | otherwise = debugNodePath </> name
6259 normalFilename = normalPath </> " ab2p.css"
63- -- debugFilename = debugPath </> "ab2p.css"
64- writePatterns_with_debug :: [String ] -> String -> String -> [Pattern ] -> IO ()
65- writePatterns_with_debug _ _ _ [] = return ()
66- writePatterns_with_debug info' normalFilename debugFilename patterns =
60+ debugFilename = debugPath </> " ab2p.css"
61+ writePatterns :: [String ] -> String -> String -> [Pattern ] -> IO ()
62+ writePatterns _ _ _ [] = return ()
63+ writePatterns info' normalFilename debugFilename patterns =
6764 do
6865 writeCssFile normalFilename $ intercalate " \n " ((++ Templates. blockCss) . intercalate " ," <$>
6966 splitEvery 4000 patterns)
@@ -75,24 +72,7 @@ elemBlock path info = writeElemBlock . elemBlockData
7572 do outFile <- openFile filename WriteMode
7673 hSetEncoding outFile utf8
7774 hPutStrLn outFile " /*"
78- _ <- mapM (hPutStrLn outFile) info'
79- hPutStrLn outFile " */"
80- hPutStrLn outFile content
81- hClose outFile
82- writePatterns :: [String ] -> String -> [Pattern ] -> IO ()
83- writePatterns _ _ [] = return ()
84- writePatterns info' normalFilename patterns =
85- do
86- -- writeCssFile debugFilename $ intercalate "\n" $ (++ Templates.blockCss) <$> patterns
87- writeCssFile normalFilename $ intercalate " \n " ((++ Templates. blockCss) . intercalate " ," <$>
88- splitEvery 4000 patterns)
89- where
90- splitEvery n = takeWhile (not . null ) . unfoldr (Just . splitAt n)
91- writeCssFile filename content =
92- do outFile <- openFile filename WriteMode
93- hSetEncoding outFile utf8
94- hPutStrLn outFile " /*"
95- _ <- mapM (hPutStrLn outFile) info'
75+ mapM_ (hPutStrLn outFile) info'
9676 hPutStrLn outFile " */"
9777 hPutStrLn outFile content
9878 hClose outFile
0 commit comments