adblock2privoxy 1.3.3 → 1.4.0
raw patch · 28 files changed
+686/−560 lines, 28 filesdep +case-insensitivedep ~parsec-permutation
Dependencies added: case-insensitive
Dependency ranges changed: parsec-permutation
Files
- INSTALL.rst +8/−19
- README.rst +24/−24
- adblock2privoxy.cabal +21/−16
- distribution/buildWin.bat +39/−17
- distribution/debbuild/DEBIAN/control +35/−0
- distribution/makeDeb.sh +52/−0
- distribution/makeFedoraRpm.sh +0/−28
- distribution/makeRpm.sh +56/−0
- distribution/rpmbuild/SPECS/adblock2privoxy.spec +12/−14
- man/man1/adblock2privoxy.1 +1/−1
- src/ElementBlocker.hs +38/−40
- src/InputParser.hs +37/−42
- src/Main.hs +26/−36
- src/Network.hs +23/−0
- src/OptionsConverter.hs +41/−44
- src/ParsecExt.hs +15/−15
- src/PatternConverter.hs +54/−55
- src/PolicyTree.hs +16/−23
- src/PopupBlocker.hs +0/−1
- src/ProgramOptions.hs +14/−15
- src/SourceInfo.hs +26/−26
- src/Statistics.hs +5/−10
- src/Task.hs +7/−9
- src/Templates.hs +11/−12
- src/UrlBlocker.hs +71/−91
- src/UrlBlocker.hs-boot +0/−0
- src/Utils.hs +22/−22
- stack.yaml +32/−0
INSTALL.rst view
@@ -1,5 +1,5 @@ ============================-Adblock2Privoxy installation +Adblock2Privoxy installation ============================ From binary package@@ -13,27 +13,16 @@ ------------ You can install adblock2privoxy from sources if there is no binary package for your system. -1. Ensure you have Haskell compiler and Cabal -- * For Windows: you can download `MinGHC installer <https://s3.amazonaws.com/download.fpcomplete.com/minghc/minghc-7.8.3.exe>`_ (It includes GHC 7.8.3 compiler and Cabal)- * From Linux: Install Haskell platform from your distributive repository or follow `the guide <http://www.stackage.org/install>`_-2. Obtain sources. You can -- * Either download and extract sources from `Hackage <http://hackage.haskell.org/package/adblock2privoxy>`_- * Or clone git repository with `git clone http://projects.zubr.me/adblock2privoxy.git`+1. Ensure you have Haskell compiler and Cabal -3. Open console and go to the sources folder -4. Run:: + * Install `Stack <http://docs.haskellstack.org/en/stable/install_and_upgrade.html>`_ for your platform+2. Run:: - cabal update- runhaskell Setup.hs configure --user- runhaskell Setup.hs build- runhaskell Setup.hs install+ stack setup+ stack install adblock2privoxy Packaging ----------You can create your own binary package for adblock2privoxy. There are two ways: -- * Use scripts from `distribution` folder- * Or do the same actions as for installing from sources, but use `--prefix=[package directory]` option on configure step. After that you put content of [package directory] to package or archive. +You can create your own binary package for adblock2privoxy. + * Use scripts from `distribution` folder for your platform.
README.rst view
@@ -1,5 +1,5 @@ ===============-Adblock2Privoxy +Adblock2Privoxy =============== **Convert adblock config files to privoxy format**@@ -15,10 +15,10 @@ AdBlock Plus browser plugin has great block lists provided by big community, but it is client software and cannot work on a server as a proxy. -Privoxy proxy has good potential to block ads at server side, +Privoxy proxy has good potential to block ads at server side, but it experiences acute shortage of updated block lists. -This software converts adblock lists to privoxy config files format. +This software converts adblock lists to privoxy config files format. Almost all adblock features are supported including @@ -34,31 +34,31 @@ * Supported: script, image, stylesheet, object, xmlhttprequest, object-subrequest, subdocument,document, elemhide, other, popup, third-party, domain=..., match-case, donottrack * Unsupported: collapse, background, xbl, ping and dtd- + Tested with privoxy version 3.0.21. Element hiding feature requires a webserver to serve CSS files. See Nginx and Apache config examples provided. Description ----------- -Adblock files specified by [URL]... are converted to privoxy config files and auxiliarly elemHide CSS files. Local file names and http(s) addresses are accepted as URLs. +Adblock files specified by [URL]... are converted to privoxy config files and auxiliarly elemHide CSS files. Local file names and http(s) addresses are accepted as URLs. -If no source URLs are specified, task file is used to determine sources: previously processed sources are processed again if any of them is expired. Nothing is done if all sources in the task file are up to date. +If no source URLs are specified, task file is used to determine sources: previously processed sources are processed again if any of them is expired. Nothing is done if all sources in the task file are up to date. Options -------- - -v --version ++ -v --version Show version number- -p PATH --privoxyDir=PATH + -p PATH --privoxyDir=PATH Privoxy config output path- -w PATH --webDir=PATH + -w PATH --webDir=PATH Css files output path- -d DOMAIN --domainCSS=DOMAIN + -d DOMAIN --domainCSS=DOMAIN Domain of CSS web server (required for Element Hide functionality)- -t PATH --taskFile=PATH + -t PATH --taskFile=PATH Path to task file containing urls to process and options.- -f --forced + -f --forced Run even if no sources are expired If taskFile is not specified explicilty, [privoxyDir]/ab2p.task is used.@@ -67,9 +67,9 @@ If webDir is not specified (and cannot be taken from task file), privoxyDir value is used for webDir. -If domainCSS is not specified (and cannot be taken from task file), Element Hide functionality become disabled (and no webserver is needed). +If domainCSS is not specified (and cannot be taken from task file), Element Hide functionality become disabled (and no webserver is needed). -domainCSS can contain just IP address if no CSS web server has no associated domain. +domainCSS can contain just IP address if no CSS web server has no associated domain. Usage -----@@ -84,22 +84,22 @@ The app generates following files - * privoxyDir: + * privoxyDir: * ab2p.system.action * ab2p.action * ab2p.system.filter * ab2p.filter - * webDir: + * webDir: * ab2p.common.css * ab2p.css- * [lot of directories for all levels of domain names] + * [lot of directories for all levels of domain names] * taskFile: - * special file containing execution details. It can be reused to update privoxy config from same sources with same options. + * special file containing execution details. It can be reused to update privoxy config from same sources with same options. How to apply results --------------------@@ -122,8 +122,8 @@ #ab2p css domain name (optional, should be equal to domainCSS parameter) server_name www.example.com; - #root = webDir parameter value - root /var/www/privoxy; + #root = webDir parameter value+ root /var/www/privoxy; location ~ ^/[^/.]+\..+/ab2p.css$ { # first reverse domain names order@@ -134,7 +134,7 @@ # then try to get CSS for current domain # if it is unavailable - get CSS for parent domain try_files $uri $1ab2p.css;- } + } } @@ -142,9 +142,9 @@ <VirtualHost *:80> #ab2p css domain name (optional, should be equal to domainCSS parameter)- ServerName www.example.com + ServerName www.example.com - #root = webDir parameter value + #root = webDir parameter value DocumentRoot /var/www/privoxy
adblock2privoxy.cabal view
@@ -1,22 +1,24 @@ name: adblock2privoxy-version: 1.3.3+version: 1.4.0 cabal-version: >= 1.10 build-type: Simple-tested-with: - GHC==7.8.3,- GHC==7.6.3+tested-with:+ GHC==7.10.2 author: Alexey Zubritsky <adblock2privoxy@zubr.me>-data-files: +data-files: templates/ab2p.system.action, templates/ab2p.system.filter-extra-source-files: +extra-source-files:+ stack.yaml README.rst INSTALL.rst changelog man/man1/adblock2privoxy.1 distribution/rpmbuild/SPECS/adblock2privoxy.spec distribution/buildWin.bat- distribution/makeFedoraRpm.sh+ distribution/makeRpm.sh+ distribution/debbuild/DEBIAN/control+ distribution/makeDeb.sh license: GPL-3 maintainer: Alexey Zubritskiy <adblock2privoxy@zubr.me> license-file: LICENSE@@ -24,7 +26,7 @@ homepage: https://projects.zubr.me/wiki/adblock2privoxy category: Web synopsis: Convert adblock config files to privoxy format-description: +description: AdBlock Plus browser plugin has great block list files provided by big community, but it is client software and cannot work on a server as proxy. .@@ -56,11 +58,12 @@ main-is: Main.hs default-language: Haskell2010 default-extensions:- RankNTypes, - ScopedTypeVariables, + RankNTypes,+ ScopedTypeVariables, FlexibleInstances,- GeneralizedNewtypeDeriving- build-depends: + GeneralizedNewtypeDeriving,+ FlexibleContexts+ build-depends: base >= 4 && < 5, parsec, mtl,@@ -68,18 +71,20 @@ filepath, directory, MissingH,- parsec-permutation,+ parsec-permutation >= 0.1.2.0, time >=1.4, old-locale >=1.0, strict >=0.3, network >=2.4, http-conduit, text >=0.11,- network-uri + network-uri,+ case-insensitive ghc-options: -Wall- other-modules: + other-modules: ElementBlocker, InputParser,+ Network, OptionsConverter, ParsecExt, Paths_adblock2privoxy,@@ -98,4 +103,4 @@ type: git location: http://projects.zubr.me/adblock2privoxy.git subdir: adblock2privoxy- tag: 1.3.3+ tag: 1.4.0
distribution/buildWin.bat view
@@ -1,17 +1,39 @@-@ECHO OFF-ECHO This script compiles adblock2privoxy to windows binary.--ECHO Make sure you have Haskell comiler and Cabal installed before run of this script.-ECHO You can download MinGHC installer (including GHC 7.8.3 compiler and Cabal) -ECHO from https://s3.amazonaws.com/download.fpcomplete.com/minghc/minghc-7.8.3.exe.--MKDIR binary\adblock2privoxy-CD ..-cabal update-runhaskell Setup.hs configure --user --prefix=%cd%\distribution\binary\adblock2privoxy-runhaskell Setup.hs build-runhaskell Setup.hs install-CD distribution\binary--ECHO Build is done. The result is in current folder-ECHO You can copy it to the final destination and run the executable from bin folder+@ECHO OFF +ECHO This script compiles adblock2privoxy to windows binary. + +ECHO Make sure you have Haskell Stack installed before running this script. +ECHO See http://docs.haskellstack.org/en/stable/install_and_upgrade.html#windows +ECHO for installation details. + +SET "startpath=%~dp0\.." +SET "prefix=%~dp0\binary\adblock2privoxy" +SET "stack=%appdata%\local\bin\stack" +ECHO Install GHC and Cabal +CD %USERPROFILE% +"%stack%" setup +"%stack%" build cabal-install + +ECHO Build package dependencies with stack first +CD "%startpath%" + +"%stack%" build --only-dependencies + +FOR /F "tokens=* USEBACKQ" %%F IN (`"%stack%" path --snapshot-pkg-db`) DO ( +SET snapshotdb=%%F +) + +FOR /F "tokens=* USEBACKQ" %%F IN (`"%stack%" path --local-pkg-db`) DO ( +SET localdb=%%F +) + +ECHO snapshots package DB = %snapshotdb% +ECHO local package DB = %localdb% + +MKDIR "%prefix%" +"%stack%" exec --no-ghc-package-path runhaskell -- Setup.hs configure --user --prefix="%prefix%" --package-db=clear --package-db=global --package-db="%snapshotdb%" --package-db="%localdb%" +"%stack%" exec --no-ghc-package-path runhaskell -- Setup.hs build +"%stack%" exec --no-ghc-package-path runhaskell -- Setup.hs install +CD "%prefix%" + +ECHO Build is done. The result is in current folder +ECHO You can copy it to the final destination and run the executable from bin folder
+ distribution/debbuild/DEBIAN/control view
@@ -0,0 +1,35 @@+Package: adblock2privoxy+Version: 1.4.0+Depends: libgmp10+Architecture: #ARCH#+Maintainer: Alexey Zubritskiy <adblock2privoxy@zubr.me>+Homepage: https://projects.zubr.me/wiki/adblock2privoxy+Section: web+Priority: extra+Recommends: privoxy, nginx+Description: Convert adblock config files to privoxy format+ AdBlock Plus browser plugin has great block list files provided by big community,+ but it is client software and cannot work on a server as proxy.+ .+ Privoxy proxy has good potential to block ads at server side,+ but it experiences acute shortage of updated block lists.+ .+ This software converts adblock lists to privoxy config files format.+ .+ Almost all adblock features are supported including+ .+ * block/unblock requests (on privoxy)+ .+ all syntax features are supported except for regex templates matching host name+ .+ * hide/unhide page elements (via CSS)+ .+ all syntax features are supported+ .+ * all block request options except for outdated ones:+ .+ Supported: script, image, stylesheet, object, xmlhttprequest, object-subrequest, subdocument,+ document, elemhide, other, popup, third-party, domain=..., match-case, donottrack+ .+ Unsupported: collapse, background, xbl, ping and dtd+
+ distribution/makeDeb.sh view
@@ -0,0 +1,52 @@+#!/bin/bash+set -e+echo "This script builds adblock2privoxy to binary DEB on Debian 7-8 x64"+echo "It can be easilly adapted to any other linux system with replacing pathes and apt-get calls to corresponding package manager"++echo "remember dirs"+initialDir=$PWD+script="$(readlink -f ${BASH_SOURCE[0]})"+scriptDir="$(dirname $script)"+codename="$(lsb_release -c | sed -r 's/.+:\s+(\w+)/\1/')"++echo "install tools"+echo "deb http://download.fpcomplete.com/debian $codename main" | sudo tee /etc/apt/sources.list.d/fpco.list++sudo apt-get update+sudo apt-get -y --force-yes install stack++echo "install ghc and cabal"+cd ~+stack setup+stack install cabal-install++echo "change dir to $scriptDir"+cd $scriptDir+echo "working dir is $PWD"++echo "build adblock2privoxy"+cd ..+stack build --only-dependencies++stack exec --no-ghc-package-path runhaskell -- Setup.hs configure --user --prefix=/usr --package-db=clear --package-db=global --package-db="$(stack path --snapshot-pkg-db)" --package-db="$(stack path --local-pkg-db)"+stack exec --no-ghc-package-path runhaskell -- Setup.hs build+stack exec --no-ghc-package-path runhaskell -- Setup.hs copy --destdir=distribution/debbuild+cp -r man distribution/debbuild/usr/share/+echo "set architecture"+sed -i -e "s/#ARCH#/$(dpkg --print-architecture)/" distribution/debbuild/DEBIAN/control++echo "create DEB"+mkdir -p $initialDir/result+dpkg-deb -b distribution/debbuild $initialDir/result+cd $initialDir/result+echo "rename result"+find . -name '*.deb' -exec sh -c 'mv "$0" "${0%.deb}.debian${cat /etc/debian_version}.deb"' {} \;++echo "Build is done."++read -t 15 -n 1 -p "Press any key to cancel shutdown"+if [ $? == 0 ]; then+ echo "The result is in current folder"+else+ sudo shutdown -h +10+fi
− distribution/makeFedoraRpm.sh
@@ -1,28 +0,0 @@-#!/bin/bash-set -e-echo This script compiles adblock2privoxy to binary RPM and DEB on Fedora Core.--echo "create build folders"-mkdir -p rpmbuild/BUILD-ln -nsf ../../.. rpmbuild/BUILD/root-mkdir -p rpmbuild/BUILDROOT-mkdir -p rpmbuild/RPMS--echo "install build tools and dependencies"-sudo yum -y install @development-tools-sudo yum -y install fedora-packager-#sudo yum -y install alien-#sudo yum -y install dpkg-dev-sudo yum-builddep -y rpmbuild/SPECS/adblock2privoxy.spec--echo "build RPM"-rpmbuild --define "_topdir `pwd`/rpmbuild" -bb rpmbuild/SPECS/adblock2privoxy.spec--mkdir -p binary-mv rpmbuild/RPMS/*/* binary/-cd binary--#echo "convert to DEB"-#sudo alien *--echo Build is done. The result is in current folder
+ distribution/makeRpm.sh view
@@ -0,0 +1,56 @@+#!/bin/bash+set -e+echo "This script compiles adblock2privoxy to binary RPM on Fedora Core 19-23, CentOS 6-7 x64"++echo "determine OS version"+if [ -e /etc/os-release ]+ then+ source /etc/os-release+ else+ VERSION_ID=$(cat /etc/centos-release | sed -r 's/[^0-9]+([0-9]).*/\1/')+ ID='centos'+fi++echo "change dir"+initialDir=$PWD+script="$(readlink -f ${BASH_SOURCE[0]})"+scriptDir="$(dirname $script)"+cd $scriptDir+echo "working dir is $PWD"++echo "create build folders"+mkdir -p rpmbuild/BUILD+ln -nsf ../../.. rpmbuild/BUILD/root+mkdir -p rpmbuild/BUILDROOT+mkdir -p rpmbuild/RPMS++echo "setup repository"+curl -sSL https://s3.amazonaws.com/download.fpcomplete.com/$ID/$VERSION_ID/fpco.repo | sudo tee /etc/yum.repos.d/fpco.repo++echo "install build tools and dependencies"++if [ "$VERSION_ID" -gt "21" ]+ then+ sudo dnf -y install rpm-build+ sudo dnf builddep -y rpmbuild/SPECS/adblock2privoxy.spec+ else+ sudo yum -y install rpm-build+ sudo yum-builddep -y rpmbuild/SPECS/adblock2privoxy.spec+fi++echo "build RPM"+rpmbuild --define "_topdir `pwd`/rpmbuild" -bb rpmbuild/SPECS/adblock2privoxy.spec++echo "move RPM to result dir"+mkdir -p $initialDir/result+mv rpmbuild/RPMS/*/* $initialDir/result/+cd $initialDir/result++echo "Build is done."++read -t 15 -n 1 -p "Press any key to cancel shutdown"+if [ $? == 0 ]; then+ echo "The result is in current folder"+else+ sudo shutdown -h +10+fi
distribution/rpmbuild/SPECS/adblock2privoxy.spec view
@@ -1,17 +1,15 @@ Name: adblock2privoxy-Version: 1.3.3+Version: 1.4.0 Release: 1%{?dist} Summary: Convert adblock config files to privoxy format License: GPL-3 URL: https://projects.zubr.me/wiki/adblock2privoxy-Source0: http://hackage.haskell.org/package/adblock2privoxy-1.3.3/adblock2privoxy-1.3.3.tar.gz+Source0: http://hackage.haskell.org/package/adblock2privoxy-1.4.0/adblock2privoxy-1.4.0.tar.gz Vendor: Alexey Zubritskiy <adblock2privoxy@zubr.me> Group: Web -BuildRequires: ghc-Cabal-devel-BuildRequires: ghc-rpm-macros-BuildRequires: cabal-install+BuildRequires: stack BuildRequires: zlib-devel %description@@ -40,22 +38,22 @@ Unsupported: collapse, background, xbl, ping and dtd +%define debug_package %{nil} %prep %setup -q -T -D -n root-cabal update-cabal install --user --only-dependencies --enable-optimization=2+stack setup+stack install cabal-install %build-%global cabal_configure_options --user-%global ghc_user_conf 1-%global ghc_without_dynamic 1-%ghc_bin_build+stack build --only-dependencies+stack exec --no-ghc-package-path runhaskell -- Setup.hs configure --user --package-db=clear --package-db=global --package-db="$(stack path --snapshot-pkg-db)" --package-db="$(stack path --local-pkg-db)" --prefix=%{_prefix} --libdir=%{_libdir} --docdir=%{?_pkgdocdir}%{!?_pkgdocdir:%{_docdir}/%{name}-%{version}} --libsubdir='$compiler/$pkgid' --datasubdir='$pkgid'+stack exec --no-ghc-package-path runhaskell -- Setup.hs build %install-%ghc_bin_install+stack exec --no-ghc-package-path runhaskell -- Setup.hs copy --destdir=%{buildroot} -v cp -r man %{buildroot}%{_mandir} @@ -67,5 +65,5 @@ %changelog-* Sat Feb 07 2015 Alexey Zubritskiy <adblock2privoxy@zubr.me> - 1.3.3-- Rpm release for new version (generated from cabal file)+* Thu Dec 24 2015 Alexey Zubritskiy <adblock2privoxy@zubr.me> - 1.4.0+- Rpm release for version 1.4.0 (generated from cabal file)
man/man1/adblock2privoxy.1 view
@@ -1,4 +1,4 @@-.TH "ADBLOCK2PRIVOXY" "1" "2015\-02\-07" "adblock2privoxy 1.3.3" "General Commands Manual"+.TH "ADBLOCK2PRIVOXY" "1" "2015\-02\-21" "adblock2privoxy 1.3.4" "General Commands Manual" .SH ADBLOCK2PRIVOXY .PP \f[B]Convert adblock config files to privoxy format\f[]
src/ElementBlocker.hs view
@@ -2,95 +2,94 @@ elemBlock ) where import InputParser hiding (Policy(..))-import qualified InputParser +import qualified InputParser import PolicyTree-import Control.Applicative import qualified Data.Map as Map import Data.Maybe import Utils import System.IO import System.FilePath-import Data.List +import Data.List import System.Directory-import qualified Templates -import Control.Monad +import qualified Templates+import Control.Monad import Data.String.Utils (startswith)- -type BlockedRulesTree = DomainTree [Pattern] ++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) = + writeElemBlock (ElemBlockData flatPatterns rulesTree) = do let debugPath = path </> "debug" filteredInfo = filter ((||) <$> not . startswith "Url:" <*> startswith "Url: http") info createDirectoryIfMissing True path cont <- getDirectoryContents path- _ <- sequence $ removeOld <$> cont + _ <- sequence $ removeOld <$> cont createDirectoryIfMissing True debugPath- writeBlockTree path debugPath rulesTree - writePatterns filteredInfo (path </> "ab2p.common.css") (debugPath </> "ab2p.common.css") flatPatterns - removeOld entry' = + writeBlockTree path debugPath rulesTree+ writePatterns filteredInfo (path </> "ab2p.common.css") (debugPath </> "ab2p.common.css") flatPatterns+ removeOld entry' = let entry = path </> entry'- in do + in do isDir <- doesDirectoryExist entry- if isDir then when (head entry' /= '.') $ removeDirectoryRecursive entry - else when (takeExtension entry == ".css") $ removeFile 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 + writePatterns ["See ab2p.common.css for sources info"] normalFilename debugFilename patterns where- normalPath + normalPath | null name = normalNodePath | otherwise = normalNodePath </> name- debugPath + debugPath | null name = debugNodePath | otherwise = debugNodePath </> name normalFilename = normalPath </> "ab2p.css"- debugFilename = debugPath </> "ab2p.css" + debugFilename = debugPath </> "ab2p.css" writePatterns :: [String] -> String -> String -> [Pattern] -> IO () writePatterns _ _ _ [] = return ()- writePatterns info' normalFilename debugFilename patterns = - do + writePatterns info' normalFilename debugFilename patterns =+ do writeCssFile debugFilename $ intercalate "\n" $ (++ Templates.blockCss) <$> patterns- writeCssFile normalFilename $ intercalate "\n" $ (++ Templates.blockCss) <$> intercalate "," <$> - splitEvery 4000 patterns- where + writeCssFile normalFilename $ intercalate "\n" ((++ Templates.blockCss) . intercalate "," <$>+ splitEvery 4000 patterns)+ where splitEvery n = takeWhile (not . null) . unfoldr (Just . splitAt n)- writeCssFile filename content = + writeCssFile filename content = do outFile <- openFile filename WriteMode hSetEncoding outFile utf8 hPutStrLn outFile "/*" _ <- mapM (hPutStrLn outFile) info' hPutStrLn outFile "*/" hPutStrLn outFile content- hClose outFile - -elemBlockData :: [Line] -> ElemBlockData -elemBlockData input = ElemBlockData + 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 + (Map.foldrWithKey appendTreePattern (Node "" [] []) policyTreeMap)+ where+ policyTreeMap :: Map.Map String PolicyTree+ policyTreeMap = Map.unionWith (trimTree Block .*. mergePolicyTrees Unblock)+ blockLinesMap (erasePolicy Block <$> unblockLinesMap)- where + 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 + unblockLine _ = Nothing blockLine (Line _ (ElementHide domains InputParser.Block pattern)) = (,) pattern <$> restrictionsTree Block domains- blockLine _ = Nothing - + blockLine _ = Nothing+ appendTreePattern :: Pattern -> PolicyTree -> BlockedRulesTree -> BlockedRulesTree appendTreePattern pattern policyTree | null $ _children policyTree = id@@ -100,7 +99,6 @@ _ -> patterns appendFlatPattern :: Pattern -> PolicyTree -> [Pattern] -> [Pattern]- appendFlatPattern pattern policyTree patterns + appendFlatPattern pattern policyTree patterns | null (_children policyTree) && _value policyTree == Block = pattern:patterns | otherwise = patterns-
src/InputParser.hs view
@@ -1,4 +1,4 @@-module InputParser ( +module InputParser ( Line (..), Restrictions (..), RequestOptions (..),@@ -21,31 +21,31 @@ import Control.Monad import Text.Parsec.Permutation import System.FilePath- + -------------------------------------------------------------------------- ---------------------------- data model --------------------------------- -------------------------------------------------------------------------- --- composite+-- composite data Line = Line RecordSource Record deriving (Show,Eq) -data RecordSource = RecordSource { _position :: SourcePos, _rawRecord :: String } deriving (Show,Eq) -data Policy = Block | Unblock deriving (Show, Eq, Read, Ord) +data RecordSource = RecordSource { _position :: SourcePos, _rawRecord :: String } deriving (Show,Eq)+data Policy = Block | Unblock deriving (Show, Eq, Read, Ord) data Record = Error String |- Comment String | - ElementHide (Restrictions Domain) Policy Pattern | + Comment String |+ ElementHide (Restrictions Domain) Policy Pattern | RequestBlock Policy Pattern RequestOptions deriving (Read,Show,Eq)- + data RequestType = Script | Image | Stylesheet | Object | Xmlhttprequest | Popup | ObjectSubrequest | Subdocument | Document | Other deriving (Read, Show,Eq) data RequestOptions = RequestOptions {- _requestType :: Restrictions RequestType, - _thirdParty :: Maybe Bool, - _domain :: Restrictions Domain, + _requestType :: Restrictions RequestType,+ _thirdParty :: Maybe Bool,+ _domain :: Restrictions Domain, _matchCase :: Bool, _collapse :: Maybe Bool, _doNotTrack :: Bool,@@ -54,7 +54,7 @@ } deriving (Read,Show,Eq) --- primitive +-- primitive type Pattern = String type Domain = String @@ -67,27 +67,27 @@ recordSourceText :: RecordSource -> String recordSourceText (RecordSource position rawRecord) = concat [rawRecord, " (", takeFileName $ sourceName position, ": ", show $ sourceLine position, ")"]- + -------------------------------------------------------------------------- ---------------------------- parsers ------------------------------------ -------------------------------------------------------------------------- -adblockFile :: Parser [Line] +adblockFile :: Parser [Line] adblockFile = header *> sepEndBy line (oneOf eol)- where + where header = string "[Adblock Plus " <* version <* string "]" <* lineEnd version = join <$> sepBy (many1 digit) (char '.') -line :: Parser Line +line :: Parser Line line = do- position <- getPosition + position <- getPosition let text = lookAhead (manyTill anyChar lineEnd) sourcePosition = RecordSource position <$> text- Line <$> sourcePosition <*> choice (try <$> [comment, elementHide, match, unknown]) <?> "filtering rule" - - + Line <$> sourcePosition <*> choice (try <$> [comment, elementHide, match, unknown]) <?> "filtering rule" ++ elementHide :: Parser Record elementHide = ElementHide <$> domains ',' <*> excludeMatch <*> pattern where@@ -111,37 +111,37 @@ unknown = Error "Record type detection failed" <$ skipMany notLineEnd requestOptions :: Parser RequestOptions-requestOptions = runPermParser $ RequestOptions - <$> (fixRestrictions <$> requestTypes) - <*> (getMaybeAll <$> requestOptionNorm "ThirdParty") +requestOptions = runPermParser $ RequestOptions+ <$> (fixRestrictions <$> requestTypes)+ <*> (getMaybeAll <$> requestOptionNorm "ThirdParty") <*> (fixRestrictions <$> optionalDomain) <*> (getAllOrFalse <$> requestOptionNorm "MatchCase") <*> (getMaybeAll <$> requestOptionNorm "Collapse") <*> (getAllOrFalse <$> requestOptionNorm "Donottrack") <*> (getAllOrFalse <$> requestOptionNorm "Elemhide")- <* manyPerm separator + <* manyPerm separator <*> unknownOption- where + where optionalDomain = optionPerm noRestrictions $ try domainOption requestTypes = Restrictions <$> (Just <$> manyPerm (try requestTypeOption)) <*> manyPerm (try notRequestTypeOption) notRequestTypeOption = char '~' *> requestTypeOption requestOptionNorm = manyPerm.try.requestOption separator = try (lineSpaces *> char ',' <* lineSpaces) unknownOption = manyPerm $ try optionName- + requestOption :: String -> Parser All requestOption name = All <$> option True (char '~' *> return False) <* checkOptionName name- + requestTypeOption :: Parser RequestType-requestTypeOption = do t <- optionName +requestTypeOption = do t <- optionName case reads t of [(result, "")] -> return result- _ -> pzero <?> "request type" + _ -> pzero <?> "request type" - - ++ domainOption :: Parser (Restrictions Domain) domainOption = checkOptionName "Domain" *> lineSpaces *> char '=' *> lineSpaces *> domains '|' @@ -156,20 +156,20 @@ checkOptionName :: String -> Parser () checkOptionName name = do t <- optionName when (name /= t) (pzero <?> "option type")- + domain :: Parser Domain domain = join <$> intersperse "." <$> parts- where - parts = sepBy1 domainPart (char '.') + where+ parts = sepBy1 domainPart (char '.') domainPart = many1 (alphaNum <|> char '-') domains :: Char -> Parser (Restrictions Domain) domains sep = fixRestrictions <$> runPermParser restrictions- where + where restrictions = Restrictions <$> (Just <$> manyPerm (try domain)) <*> manyPerm (try notDomain) <* manyPerm (try separator) separator = lineSpaces *> char sep <* lineSpaces notDomain = char '~' *> domain- + --helpers eol :: String eol = "\r\n"@@ -198,13 +198,8 @@ fixRestrictions :: (Eq a) => Restrictions a -> Restrictions a fixRestrictions = deduplicate.allowAll- where + where allowAll (Restrictions (Just []) n) = Restrictions Nothing n allowAll a = a deduplicate (Restrictions (Just p) n) = Restrictions (Just $ nub p) (nub n) deduplicate a = a-- - - -
src/Main.hs view
@@ -4,41 +4,31 @@ import UrlBlocker import Text.ParserCombinators.Parsec hiding (Line, many, optional) import Task-import Control.Applicative hiding (many) import SourceInfo as Source import ProgramOptions as Options import System.Environment import Templates-import Data.Time.Clock +import Data.Time.Clock import Network.HTTP.Conduit import Network.URI-import Data.Text.Lazy.Encoding-import Data.Text.Lazy (unpack)-import Network.Socket import System.Directory import System.IO-import Control.Monad -+import Network - -getResponse :: String -> IO String-getResponse url = do- putStrLn $ "load " ++ url ++ "..."- withSocketsDo $ unpack . decodeUtf8 <$> simpleHttp url- getFileContent :: String -> IO String getFileContent url = do- handle <- openFile url ReadMode + handle <- openFile url ReadMode hSetEncoding handle utf8 hGetContents handle processSources :: Options -> String -> [SourceInfo]-> IO ()-processSources options taskFile sources = do - (parsed, sourceInfo) <- unzip <$> mapM parseSource sources - let parsed' = concat parsed +processSources options taskFile sources = do+ manager <- newManager tlsManagerSettings+ (parsed, sourceInfo) <- unzip <$> mapM (parseSource manager) sources+ let parsed' = concat parsed sourceInfoText = showInfo sourceInfo optionsText = logOptions options- createDirectoryIfMissing True $ _privoxyDir options + createDirectoryIfMissing True $ _privoxyDir options writeTask taskFile (sourceInfoText ++ optionsText) parsed' if null._cssDomain $ options then putStrLn "WARNING: CSS generation is not run because webserver domain is not specified"@@ -46,48 +36,48 @@ urlBlock (_privoxyDir options) sourceInfoText parsed' writeTemplateFiles (_privoxyDir options) (_cssDomain options) putStrLn $ "Run 'adblock2privoxy -t " ++ taskFile ++ "' every 1-2 days to process data updates."- where - parseSource sourceInfo = do- let + where+ parseSource manager sourceInfo = do+ let url = _url sourceInfo- loader = if isURI url then getResponse else getFileContent+ loader = if isURI url then downloadHttp manager 5 else getFileContent putStrLn $ "process " ++ url text <- loader url now <- getCurrentTime- case parse adblockFile url text of- Right parsed -> - let sourceInfo' = updateInfo now parsed sourceInfo + let strictParse = text `seq` parse adblockFile url text+ case strictParse of+ Right parsed ->+ let sourceInfo' = updateInfo now parsed sourceInfo url' = _url sourceInfo'- in if url == url' + in if url == url' then return (parsed, sourceInfo')- else parseSource sourceInfo'+ else parseSource manager sourceInfo' Left msg -> return ([], sourceInfo) <$ putStrLn $ show msg main::IO()-main = do +main = do now <- getCurrentTime args <- getArgs (options@(Options printVersion _ _ taskFile _ forced), urls) <- parseOptions args (options', task) <- do fileExists <- doesFileExist taskFile if fileExists- then do task <- readTask taskFile + then do task <- readTask taskFile return (fillFromLog options task, Just task)- else return (options, Nothing) - let + else return (options, Nothing)+ let action | printVersion = putStrLn versionText- | not . null $ urls + | not . null $ urls = processSources options' taskFile (makeInfo <$> urls) | otherwise = case task of- Nothing -> writeError "no input specified" + Nothing -> writeError "no input specified" (Just task') -> do let sources = Source.readLogInfos task'- if forced || or (infoExpired now <$> sources) + if forced || or (infoExpired now <$> sources) then processSources options' taskFile sources else putStrLn "all sources are up to date"- + action now' <- getCurrentTime putStrLn $ concat ["Execution done in ", show $ diffUTCTime now' now, " seconds."]-
+ src/Network.hs view
@@ -0,0 +1,23 @@+module Network (+ downloadHttp+)+where++import Network.HTTP.Conduit+import Control.Monad (liftM)+import Data.Text.Lazy.Encoding+import Data.Text.Lazy+import Control.Exception++-- | A simpleHttp alternative that specifies bigger timeout and retries connection attempts+downloadHttp :: Manager -> Int -> String -> IO String+downloadHttp manager retries url = do+ putStrLn $ "load " ++ url ++ " (" ++ show retries ++ " more attempts)..."+ req <- parseUrl url+ let req' = req {responseTimeout = Just 15000000}+ result <- try $ liftM responseBody $ httpLbs req' manager+ case result of+ Left e@(FailedConnectionException _ _) ->+ if retries > 0 then downloadHttp manager (retries - 1) url else throw e+ Left e -> throw e+ Right content -> return $ unpack.decodeUtf8 $ content
src/OptionsConverter.hs view
@@ -6,20 +6,18 @@ headerFilters ) where import InputParser-import Control.Applicative import Control.Monad import Data.List-import Data.Monoid hiding (Any) import Data.Maybe import Data.String.Utils (replace)-import {-# SOURCE #-} UrlBlocker +import {-# SOURCE #-} UrlBlocker 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 +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]@@ -35,15 +33,15 @@ 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 + = let requestOptions' = requestOptions{_requestType = convertPopup $ convertOther requestType}+ in do nextLevel <- headerFilters policy (level - 1) requestOptions' let- passthrough = checkPassthrough requestOptions' + passthrough = checkPassthrough requestOptions' filters = do headerType <- allTypes guard (_level headerType == level)- case (_fabrique headerType) policy requestOptions' of+ case _fabrique headerType policy requestOptions' of Specific filter' -> return $ Just $ HeaderFilter headerType filter' None -> return Nothing Any -> mzero@@ -54,53 +52,53 @@ convertPopup :: Restrictions RequestType -> Restrictions RequestType convertPopup (Restrictions positive negative)= Restrictions positive' negative- where + where positiveContentTypes = fromMaybe [] positive >>= contentTypes True positive' | Popup `elem` negative && null positiveContentTypes = Nothing- | otherwise = positive + | otherwise = positive convertOther :: Restrictions RequestType -> Restrictions RequestType convertOther (Restrictions positive negative)= Restrictions positive' negative'- where + 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' | Other `elem` negative = Just $ allContentOptions \\ negative' | positive == Just [Other] = Nothing | otherwise = positive- + checkPassthrough :: RequestOptions -> Bool checkPassthrough RequestOptions {_requestType = (Restrictions positive _) }- = fromMaybe False $ (not . null . intersect [Subdocument, Popup]) <$> positive - + = fromMaybe False $ (not . null . intersect [Subdocument, Popup]) <$> positive+ acceptFilter, contentTypeFilter, requestedWithFilter, refererFilter :: FilterFabrique contentTypeFilter policy (RequestOptions (Restrictions positive negative) thirdParty _ _ _ _ _ _)- | fromMaybe True emptyPositive && (not $ isNothing positive) = None- | result == mempty = Any + | fromMaybe True emptyPositive && isJust positive = None+ | result == mempty = Any | otherwise = Specific $ Filter code regex orEmpty- where + where negative' | isNothing positive && fromMaybe False thirdParty = Document : negative- | otherwise = 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 = null . filter (`notElem` (fromMaybe "" $ fst <$> negativePart)) . fst <$> positivePart- + emptyPositive = not . any (`notElem` (fromMaybe "" $ fst <$> negativePart)) . fst <$> positivePart+ convert _ [] = Nothing convert include requestTypes | null code' = Nothing | otherwise = Just (code', regex') where contentTypes' = nub $ requestTypes >>= contentTypes include code' = sort $ (head . 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@@ -110,42 +108,42 @@ code False = "nx" result | Xmlhttprequest `elem` negative = Just False | Xmlhttprequest `elem` fromMaybe [] positive = Just True- | (hasContentTypes False negative) - && (fromMaybe True $ not . hasContentTypes True <$> positive) = Just True+ | hasContentTypes False negative+ && fromMaybe True (not . hasContentTypes True <$> positive) = Just True | otherwise = Nothing hasContentTypes include = not . all null . fmap (contentTypes include) refererFilter policy RequestOptions{ _thirdParty = thirdParty, _domain = Restrictions positive negative } | fromMaybe False emptyPositive = None- | result == mempty = Any + | 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, + 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 = null . filter (`notElem` negative) <$> positive- orEmpty = (policy == Unblock) && (isNothing positive || (not $ fromMaybe True thirdParty))+ 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 -> [Char]-lookAheadPolicy True = "=" -lookAheadPolicy False = "!" - -lookahead :: [String] -> String -> Bool -> String -lookahead list prefix include = join ["(?", lookAheadPolicy include, +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 "." "\\." - + excapeRx = replace "/" "\\/" . replace "." "\\."+ contentTypes :: Bool -> RequestType -> [String] contentTypes _ Script = ["/(?:x-)?javascript"] contentTypes _ Image = ["image/"]@@ -154,5 +152,4 @@ contentTypes _ ObjectSubrequest = ["video/","audio/","/octet-stream"] contentTypes _ Document = ["/html", "/xml"] contentTypes False Subdocument = ["/html", "/xml"]-contentTypes _ _ = [] - +contentTypes _ _ = []
src/ParsecExt.hs view
@@ -11,23 +11,23 @@ import Utils import Control.Applicative hiding (many) import Text.ParserCombinators.Parsec hiding ((<|>),State)-import Control.Monad.Trans +import Control.Monad.Trans import Control.Monad.RWS import Control.Monad.State import Data.Maybe- --- parser should consume some input to prevent infinite loop ++-- parser should consume some input to prevent infinite loop manyCases :: (Monoid a, Monoid st) => Parser a -> StateParser st a manyCases p = do acc <- get put $ Just mempty- lift $ if isNothing acc - then return mempty + lift $ if isNothing acc+ then return mempty else p- + oneCase :: (Monoid a, Monoid st) => Parser a -> StateParser st a oneCase p = do acc <- get put $ Just mempty- lift $ if isNothing acc + lift $ if isNothing acc then p else pzero @@ -46,29 +46,29 @@ where stateParser = do input <- lift getInput let boxedParser = (mapRWST.mapStateT) lookAhead $ casesParser mempty parsers- (input', res) <- execRWST boxedParser () input + (input', res) <- execRWST boxedParser () input lift (setInput input') return res- - ++ casesParser :: forall r st.(Monoid r) => r -> [StateParser st r] -> CasesParser st r () casesParser _ [] = error "Empty parser list is not accepted" casesParser acc parsers@(parser:next) = do maybeRes <- lift (optionMaybeTry parser)- case maybeRes of + case maybeRes of Nothing -> return () Just res -> do input <- lift.lift $ getInput let acc' = acc <> res- if null input || null next + if null input || null next then do modify (minList input) -- TODO: somehow use processed length to select min input tell [acc']- else do + else do st <- lift get lift (put Nothing) (mapRWST.mapStateT) lookAhead $ casesParser acc' next lift (put st)- unless (null input) $ casesParser acc' parsers - + unless (null input) $ casesParser acc' parsers+ ------------------------------------------------------------------------------------------------
src/PatternConverter.hs view
@@ -13,9 +13,9 @@ import ParsecExt import Utils -data SideBind = Hard | Soft | None deriving (Show, Eq) +data SideBind = Hard | Soft | None deriving (Show, Eq) -data UrlPattern = UrlPattern { +data UrlPattern = UrlPattern { _bindStart :: SideBind, _proto :: String, _host :: String,@@ -25,11 +25,11 @@ deriving (Show) makePattern :: Bool -> UrlPattern -> Pattern-makePattern matchCase (UrlPattern bindStart proto host query bindEnd isRegex) - | query' == "" = host' - | otherwise = host' ++ separator' ++ query' - where - separator' +makePattern matchCase (UrlPattern bindStart proto host query bindEnd isRegex)+ | query' == "" = host'+ | otherwise = host' ++ separator' ++ query'+ where+ separator' | matchCase = "/(?-i)" | otherwise = "/" host' = case host of@@ -37,125 +37,125 @@ _ -> changeFirst.changeLast $ host where changeLast [] = []- changeLast [lst] - | lst == '|' || lst `elem` hostSeparators = [] + changeLast [lst]+ | lst == '|' || lst `elem` hostSeparators = [] | lst == '*' || lst == '\0' = "*." | otherwise = lst : "*." changeLast (c:cs) = c : changeLast cs- + changeFirst [] = []- changeFirst (first:cs) + changeFirst (first:cs) | first == '*' = '.' : '*' : cs | bindStart == Hard || proto /= "" = first : cs- | bindStart == Soft = '.' : first : cs + | bindStart == Soft = '.' : first : cs | otherwise = '.' : '*' : first : cs- + query' = case query of "" -> ""- (start:other) -> + (start:other) -> if isRegex then query else case query of '*' : '/' : other' -> replaceQuery '/' other' True- '*' : '^' : other' -> replaceQuery '^' other' True - _ -> replaceQuery start other (bindStart == None && host == "") + '*' : '^' : other' -> replaceQuery '^' other' True+ _ -> replaceQuery start other (bindStart == None && host == "") where- replaceQuery c cs openStart = replaceFirst c openStart ++ (join . map replaceWildcard $ cs) ++ queryEnd + replaceQuery c cs openStart = replaceFirst c openStart ++ (join . map replaceWildcard $ cs) ++ queryEnd replaceFirst '*' _ = ".*" replaceFirst c openStart | c == '/' || c == '^' = if openStart then "(.*" ++ replaceWildcard c ++ ")?" else ""- | otherwise = if openStart + | otherwise = if openStart then ".*" ++ replaceWildcard c else replaceWildcard c- + queryEnd = if bindEnd == None then "" else "$"- + replaceWildcard c | c == '^' = "[^\\w%.-]" | c == '*' = ".*" | c `elem` special = '\\' : [c] | otherwise = [c] where special = "?$.+[]{}()\\|" -- also ^ and * are special- + hostSeparators :: String hostSeparators = "^/" parseUrl :: Pattern -> Either ParseError [UrlPattern]-parseUrl = +parseUrl = let raw = makeUrls <$> bindStart <*> cases urlParts <*> bindEnd in parse (join <$> (fmap.fmap) postfilter raw) "url" where makeUrls start mid end = makeUrl <$> pure start <*> mid <*> pure end makeUrl start (proto, host, query) end = UrlPattern start proto host query end False- - bindStart = (try (Soft <$ string "||") <|> try (Hard <$ string "|") <|> return None) <?> "query start" ++ bindStart = (try (Soft <$ string "||") <|> try (Hard <$ string "|") <|> return None) <?> "query start" queryEnd = (char '|' <* eof) <|> ('\0' <$ eof) <|> char '\0' <?> "query end" bindEnd = (\c -> if c == '|' then Hard else None) <$> queryEnd port = option False $ many1 (noneOf ":") *> char ':' *> many1 (digit <|> char '*') *> optionMaybe (oneOf "/^") *> (True <$ queryEnd)- + hostChar :: Parser Char hostChar = alphaNum <|> oneOf ".-:"- + protocols :: [String] protocols = ["https://", "http://"]- + protocolsSeparator :: String protocolsSeparator = ";"- + protocolChar :: Parser Char protocolChar = oneOf (delete '/' $ nub $ join protocols)- + postfilter :: UrlPattern -> [UrlPattern] postfilter url@(UrlPattern bs proto host query be _) = regular ++ regex -- ++ www- where - regex = if proto == "" - && host == "" - && "/" `isPrefixOf` query + where+ regex = if proto == ""+ && host == ""+ && "/" `isPrefixOf` query && length query > 2- && "/" `isSuffixOf` query - then + && "/" `isSuffixOf` query+ then let query' = take (length query - 2) . drop 1 $ query- in [UrlPattern bs "" "" query' be True] + in [UrlPattern bs "" "" query' be True] else []- regular = let + regular = let leftBound = bs /= None || proto /= "" rightBound = be /= None || query /= "" orphanQuery = leftBound && host == "" && query /= "" && not ("*" `isPrefixOf` query) duplicateHostStar = host == "*" hostHasDot = isJust $ find (\c -> c == '.' || c == '*') host- firstLevelHost = host /= "" && not hostHasDot && leftBound && rightBound + firstLevelHost = host /= "" && not hostHasDot && leftBound && rightBound hasLegalPort = case parse port "host" host of Right val -> val- _ -> False + _ -> False hasIllegalPort = not hasLegalPort && ":" `isInfixOf` host- in if not (orphanQuery || duplicateHostStar || firstLevelHost || hasIllegalPort) + in if not (orphanQuery || duplicateHostStar || firstLevelHost || hasIllegalPort) then let- query' = if "*" `isSuffixOf` host && query /= "" then '*' : query else query - in [url {_query = query'}] + query' = if "*" `isSuffixOf` host && query /= "" then '*' : query else query+ in [url {_query = query'}] else [] - -- TODO: process port as an url part + -- TODO: process port as an url part urlParts :: [StringStateParser (String,String,String)] urlParts = square3 proto (manyCases host) (oneCase query)- where + where append xs x = xs ++ [x] proto :: StringStateParser String proto = do masksString <- get- case masksString of - Nothing -> + case masksString of+ Nothing -> do put $ Just $ intercalate protocolsSeparator protocols return "" --allow to skip proto- Just masksString' -> + Just masksString' -> do let masks = split protocolsSeparator masksString'- if null masks + if null masks then lift pzero -- no continuations available (parser have finished on previous iteration)- else + else do lift $ skipMany $ char '*' --skip leading * if presented name <- lift $ many protocolChar@@ -169,19 +169,18 @@ do put $ Just $ if isJust (find null masks') -- if empty continuation found (i.e. parser finished) then "" -- make no continuations available next time- else intercalate protocolsSeparator masks' + else intercalate protocolsSeparator masks' return $ if nextChar == '*' then chars ++ "*" else chars host = try (append <$> many hostChar <*> char '*') <|> try (append <$> many1 hostChar <*> lookAhead separator) <?> "host" separator = (oneOf hostSeparators <|> queryEnd) <?> "separator" query = notFollowedBy (try $ string "//") *> manyTill anyChar (lookAhead (try queryEnd)) <?> "query"- + filterProtoMasks :: [String] -> String -> Char -> [String] filterProtoMasks masks chars nextChar = mapMaybe filterProtoMask masks- where filterProtoMask mask = if nextChar /= '*' + where filterProtoMask mask = if nextChar /= '*' then if chars `isSuffixOf` mask then Just ""- else Nothing + else Nothing else let tailFound = find (chars `isPrefixOf`) (tails mask)- in drop (length chars) <$> tailFound - + in drop (length chars) <$> tailFound
src/PolicyTree.hs view
@@ -11,7 +11,7 @@ ,domainTree ) where-import Control.Applicative+--import Control.Applicative import InputParser hiding (Policy(..)) import Data.String.Utils (split) import Utils@@ -21,10 +21,10 @@ type PolicyTree = DomainTree NodePolicy showTree :: Show a => Int -> DomainTree a -> String-showTree lvl (Node name value children) - = concat $ +showTree lvl (Node name value children)+ = concat $ [replicate (lvl * 2) ' ', "\"", name, "\" - ", show value]- ++ (('\n':) <$> showTree (lvl + 1) <$> children)+ ++ (('\n':) . showTree (lvl + 1) <$> children) instance Show a => Show (DomainTree a) where show = showTree 0@@ -34,7 +34,7 @@ where negativePolicy = case positivePolicy of Block -> Unblock- _ -> Block + _ -> Block positiveTree = case p of Nothing -> Just $ Node "" positivePolicy [] Just p' -> concatTrees positivePolicy $ domainTree positivePolicy <$> p'@@ -59,14 +59,14 @@ mergeAndTrim :: NodePolicy -> PolicyTree -> PolicyTree -> PolicyTree mergeAndTrim trump = trimTree trump .*. mergePolicyTrees trump- + concatTrees :: NodePolicy -> [PolicyTree] -> Maybe PolicyTree concatTrees _ [] = Nothing concatTrees _ [tree] = Just tree concatTrees trump (tree:trees) = mergePolicyTrees trump tree <$> concatTrees trump trees mergePolicyTrees :: NodePolicy -> PolicyTree -> PolicyTree -> PolicyTree-mergePolicyTrees trump = mergeTrees mergePolicy +mergePolicyTrees trump = mergeTrees mergePolicy where mergePolicy policy1 policy2 | policy1 == None = policy2@@ -79,33 +79,26 @@ = Node mergeName (mergeValue value1 value2) (mergeChildren children1 children2) where -- names expected to be equal and/or empty- mergeName + mergeName | name1 == "" = name2 | otherwise = name1- - t1Default = t1{_name = "", _children = []} - t2Default = t2{_name = "", _children = []} - ++ t1Default = t1{_name = "", _children = []}+ t2Default = t2{_name = "", _children = []}+ mergeChildren [] [] = [] mergeChildren (t1Child:t1Children') [] = mergeTrees mergeValue t1Child t2Default : mergeChildren t1Children' [] mergeChildren [] (t2Child:t2Children') = mergeTrees mergeValue t1Default t2Child : mergeChildren [] t2Children'- mergeChildren t1Children@(t1Child:t1Children') t2Children@(t2Child:t2Children') + mergeChildren t1Children@(t1Child:t1Children') t2Children@(t2Child:t2Children') | _name t1Child == _name t2Child = mergeTrees mergeValue t1Child t2Child : mergeChildren t1Children' t2Children' | _name t1Child > _name t2Child = mergeTrees mergeValue t1Child t2Default : mergeChildren t1Children' t2Children | otherwise = mergeTrees mergeValue t1Default t2Child : mergeChildren t1Children t2Children'- + trimTree :: NodePolicy -> PolicyTree -> PolicyTree trimTree trump (Node name policy children) = Node name policy childrenFiltered- where + where childrenFiltered = filter (not.redundantChild) childrenTrimmed childrenTrimmed = trimTree trump <$> children redundantChild (Node _ childPolicy childChildren) = samePolicy childPolicy && null childChildren- samePolicy childPolicy = childPolicy == policy || (policy == None && childPolicy /= trump) - - -----+ samePolicy childPolicy = childPolicy == policy || (policy == None && childPolicy /= trump)
src/PopupBlocker.hs view
@@ -1,2 +1,1 @@ module PopupBlocker where-
src/ProgramOptions.hs view
@@ -21,7 +21,7 @@ , _privoxyDir :: FilePath , _webDir :: FilePath , _taskFile :: FilePath- , _cssDomain :: String + , _cssDomain :: String , _forced :: Bool } @@ -52,9 +52,9 @@ ] parseOptions :: [String] -> IO (Options, [String])-parseOptions argv = +parseOptions argv = case getOpt Permute options argv of- (opts,nonOpts,[] ) -> + (opts,nonOpts,[] ) -> case foldl (flip id) emptyOptions opts of Options False "" _ "" _ _ -> writeError "Privoxy dir or task file should be specified.\n" opts'@Options{_showVersion = True} -> return (opts', nonOpts)@@ -63,20 +63,20 @@ where setDefaults opts@(Options _ (privoxyDir@(_:_)) "" _ _ _) = setDefaults opts{ _webDir = privoxyDir } setDefaults opts@(Options _ privoxyDir _ "" _ _) = setDefaults opts{ _taskFile = privoxyDir </> "ab2p.task" }- setDefaults opts = opts + setDefaults opts = opts -versionText :: String +versionText :: String versionText = "adblock2privoxy version " ++ showVersion version writeError :: String -> IO a writeError msg = ioError $ userError $ msg ++ "\n" ++ usageInfo header options- where + where header = versionText ++ "\nSee home page for more details and updates: http://projects.zubr.me/wiki/adblock2privoxy\n" ++ "Usage: adblock2privoxy [OPTION...] [URL...]" -logOptions :: Options -> [String] +logOptions :: Options -> [String] logOptions options' = [ startMark, "Privoxy path: " ++ _privoxyDir options',@@ -94,25 +94,24 @@ emptyOptions :: Options emptyOptions = Options False "" "" "" "" False - + fillFromLog :: Options -> [String] -> Options fillFromLog existing lns = execState (sequence $ parseLogOptions <$> lns') existing- where + where lns' = filter (not.null) $ takeWhile (/= endMark).dropWhile (/= startMark) $ lns parseLogOptions :: String -> State Options () parseLogOptions text = do info <- get- let - ifEmpty getter x = + let+ ifEmpty getter x = let oldValue = getter info in- if null oldValue then x else oldValue + if null oldValue then x else oldValue privoxyPathParser = (\x -> info{_privoxyDir = ifEmpty _privoxyDir x}) <$> (string "Privoxy path: " *> many1 anyChar) webPathParser = (\x -> info{_webDir = ifEmpty _webDir x}) <$> (string "Web path: " *> many1 anyChar) cssDomainParser = (\x -> info{_cssDomain = ifEmpty _cssDomain x}) <$> (string "CSS web server domain: " *> many1 anyChar)- stringParser = skipMany (char ' ') *> + stringParser = skipMany (char ' ') *> (try privoxyPathParser <|> try webPathParser <|> cssDomainParser) case parse stringParser "" text of Left _ -> return ()- Right info' -> put info' - + Right info' -> put info'
src/SourceInfo.hs view
@@ -12,14 +12,14 @@ import Control.Applicative hiding (many) import Text.ParserCombinators.Parsec hiding ((<|>),State,Line) import Data.Time.Clock-import Data.Time.Calendar -import System.Locale+import Data.Time.Calendar+--import System.Locale import Data.Time.Format import Data.Maybe (catMaybes) import Data.String.Utils (split) -data SourceInfo = SourceInfo { _title, _url, _license, _homepage :: String, +data SourceInfo = SourceInfo { _title, _url, _license, _homepage :: String, _lastUpdated :: UTCTime, _expires, _version :: Integer, _expired :: Bool } emptySourceInfo :: SourceInfo@@ -31,48 +31,48 @@ endMark :: String endMark = "------- end ------" -showInfo :: [SourceInfo] -> [String] +showInfo :: [SourceInfo] -> [String] showInfo sourceInfos = (sourceInfos >>= showInfoItem) ++ [endMark ++ "\n"] -showInfoItem :: SourceInfo -> [String] -showInfoItem sourceInfo@(SourceInfo _ url _ _ lastUpdated expires _ expired) = +showInfoItem :: SourceInfo -> [String]+showInfoItem sourceInfo@(SourceInfo _ url _ _ lastUpdated expires _ expired) = catMaybes [ Just separator, optionalLine "Title: " _title, Just $ "Url: " ++ url, Just $ "Last modified: " ++ formatTime defaultTimeLocale "%d %b %Y %H:%M %Z" lastUpdated,- Just $ concat ["Expires: ", show expires, " hours", expiredMark], + Just $ concat ["Expires: ", show expires, " hours", expiredMark], optionalLine "Version: " $ show . _version, optionalLine "License: " _license, optionalLine "Homepage: " _homepage ]- where + where expiredMark | expired = " (expired)" | otherwise = "" optionalLine caption getter | getter sourceInfo == getter emptySourceInfo = Nothing- | otherwise = Just $ caption ++ getter sourceInfo + | otherwise = Just $ caption ++ getter sourceInfo updateInfo :: UTCTime -> [Line] -> SourceInfo -> SourceInfo updateInfo now lns old- = updated { _expired = infoExpired now updated } - where - initial = old { _lastUpdated = now } + = updated { _expired = infoExpired now updated }+ where+ initial = old { _lastUpdated = now } updated = execState (sequence $ parseInfo . lineComment <$> take 50 lns) initial- + makeInfo :: String -> SourceInfo makeInfo url = emptySourceInfo { _url = url } readLogInfos :: [String] -> [SourceInfo] readLogInfos lns = chunkInfo <$> chunks- where + where chunks = filter (not.null) . split [separator] . takeWhile (/= endMark) $ lns chunkInfo chunk = execState (sequence $ parseInfo <$> chunk) emptySourceInfo infoExpired :: UTCTime -> SourceInfo -> Bool-infoExpired now (SourceInfo _ _ _ _ lastUpdated expires _ _ ) = +infoExpired now (SourceInfo _ _ _ _ lastUpdated expires _ _ ) = diffUTCTime now lastUpdated > fromInteger (expires * 60 * 60) lineComment :: Line -> String lineComment (Line _ (Comment text)) = text-lineComment _ = "" +lineComment _ = "" parseInfo :: String -> State SourceInfo () parseInfo text = do@@ -80,20 +80,20 @@ let urlParser = (\x -> info{_url = x}) <$> ((string "Url: " <|> string "Redirect: ") *> many1 anyChar) titleParser = (\x -> info{_title = x}) <$> (string "Title: " *> many1 anyChar) homepageParser = (\x -> info{_homepage = x}) <$> (string "Homepage: " *> many1 anyChar)- lastUpdatedParser = (\x -> case x of + lastUpdatedParser = (\x -> case x of Just time -> info{_lastUpdated = time}- Nothing -> info) - <$> parseTime defaultTimeLocale "%d %b %Y %H:%M %Z" + Nothing -> info)+ . parseTimeM True defaultTimeLocale "%d %b %Y %H:%M %Z" <$> (string "Last modified: " *> many1 anyChar)- licenseParser = (\x -> info{_license = x}) - <$> ((string "Licen" <|> string "Лицензия") *> manyTill anyChar (char ':') + licenseParser = (\x -> info{_license = x})+ <$> ((string "Licen" <|> string "Лицензия") *> manyTill anyChar (char ':') *> skipMany (char ' ') *> many1 anyChar)- expiresParser = (\n unit -> info{_expires = unit * read n}) - <$> (string "Expires: " *> many1 digit) <*> (24 <$ string " days" <|> 1 <$ string " hours") + expiresParser = (\n unit -> info{_expires = unit * read n})+ <$> (string "Expires: " *> many1 digit) <*> (24 <$ string " days" <|> 1 <$ string " hours") versionParser = (\x -> info{_version = read x}) <$> (string "Version: " *> many1 digit)- stringParser = skipMany (char ' ') *> - (try urlParser <|> try titleParser <|> try expiresParser <|> try versionParser + stringParser = skipMany (char ' ') *>+ (try urlParser <|> try titleParser <|> try expiresParser <|> try versionParser <|> try licenseParser <|> try homepageParser <|> try lastUpdatedParser) case parse stringParser "" text of Left _ -> return ()- Right info' -> put info' + Right info' -> put info'
src/Statistics.hs view
@@ -3,11 +3,11 @@ )where import qualified Data.Map as Map import InputParser-import Data.Maybe -import Control.Applicative +import Data.Maybe+import Control.Applicative import Control.Monad.State -type Stat = Map.Map String Int +type Stat = Map.Map String Int collectStat :: [Line] -> [String] collectStat = liftA resultLine . Map.toAscList . foldr getStat Map.empty@@ -22,12 +22,12 @@ isJustFilled (Just list) = not.null $ list -getStat :: Line -> Stat-> Stat +getStat :: Line -> Stat-> Stat getStat (Line _ Comment {} ) = increment "Comments" getStat (Line _ Error {}) = increment "Errors" getStat (Line _ ElementHide {}) = increment "Elements hiding rules" getStat (Line _ (RequestBlock policy _ (RequestOptions _ thirdParty domains _ _ _ _ _))) = execState stateState- where + where incrementState = modify . increment stateState = do incrementState "Request block rules total"@@ -35,8 +35,3 @@ when (isJust thirdParty) $ incrementState "Rules with third party option" when ((not.null._negative $ domains) || (isJustFilled . _positive $ domains)) $ incrementState "Request block rules with domain option" when ((not.null._negative $ domains) || (isJustFilled . _positive $ domains)) $ incrementState "Request block rules with request type options"- -- - -
src/Task.hs view
@@ -6,24 +6,22 @@ import System.IO import InputParser import Statistics-import Control.Applicative ((<$>)) writeTask :: String -> [String] -> [Line] -> IO ()-writeTask filename info lns = - let +writeTask filename info lns =+ let statistics = collectStat lns- errorLine (Line position (Error text)) + errorLine (Line position (Error text)) = [concat ["ERROR: ", recordSourceText position, " - ", text]] errorLine _ = []- in do + in do outFile <- openFile filename WriteMode _ <- mapM (hPutStrLn outFile) info- _ <- sequence $ hPutStrLn outFile <$> statistics + _ <- sequence $ hPutStrLn outFile <$> statistics _ <- sequence $ hPutStrLn outFile <$> (lns >>= errorLine) hClose outFile -readTask :: String -> IO [String] -readTask path = do +readTask :: String -> IO [String]+readTask path = do result <- lines <$> Strict.readFile path return $ length result `seq` result --read whole file to allow its overwriting-
src/Templates.hs view
@@ -3,7 +3,6 @@ import Paths_adblock2privoxy import System.FilePath ((</>)) import Data.String.Utils (replace, startswith)-import Control.Applicative blockCss, ab2pPrefix, actionsFilePrefix, filtersFilePrefix :: String blockCss = "{display:none!important;visibility:hidden!important}"@@ -12,22 +11,22 @@ filtersFilePrefix = "#AbBlock generated filters -- don't edit --" terminalActionSwitch :: Bool -> BlockMethod -> String-terminalActionSwitch True Request = +terminalActionSwitch True Request = "+block{ adblock rules } \\\n\ \+server-header-tagger{ab2p-block-s}"-terminalActionSwitch False Request = +terminalActionSwitch False Request = "-block \\\n\ \-server-header-tagger{ab2p-block-s} \\\n\ \+server-header-tagger{ab2p-unblock-d} \\\n\ \+server-header-tagger{ab2p-unblock-s} \\\n\ \+client-header-tagger{ab2b-unblock-u}"-terminalActionSwitch True Xframe = "+server-header-filter{ab2p-xframe-filter}" -terminalActionSwitch False Xframe = "-server-header-filter{ab2p-xframe-filter}" -terminalActionSwitch False Elem = "-filter{ab2p-elemhide-filter}" -terminalActionSwitch True Xpopup = "+filter{ab2p-popup-filter}" -terminalActionSwitch False Xpopup = "-filter{ab2p-popup-filter}" +terminalActionSwitch True Xframe = "+server-header-filter{ab2p-xframe-filter}"+terminalActionSwitch False Xframe = "-server-header-filter{ab2p-xframe-filter}"+terminalActionSwitch False Elem = "-filter{ab2p-elemhide-filter}"+terminalActionSwitch True Xpopup = "+filter{ab2p-popup-filter}"+terminalActionSwitch False Xpopup = "-filter{ab2p-popup-filter}" terminalActionSwitch True Dnt = "+add-header{DNT: 1}"-terminalActionSwitch _ _ = "" +terminalActionSwitch _ _ = "" writeTemplateFiles :: String -> String -> IO () writeTemplateFiles outDir cssDomain = do@@ -39,9 +38,9 @@ lns = lines content replace' line (from, to) = replace from to line filterLine line- | null cssDomain && startswith "[?CSS_DOMAIN]" line = "" - | otherwise = foldl replace' line [("[?CSS_DOMAIN]", ""), ("[CSS_DOMAIN]", cssDomain)] - + | null cssDomain && startswith "[?CSS_DOMAIN]" line = ""+ | otherwise = foldl replace' line [("[?CSS_DOMAIN]", ""), ("[CSS_DOMAIN]", cssDomain)]+ copySystem file = do dataDir <- getDataDir content <- readFile $ dataDir </> "templates" </> file
src/UrlBlocker.hs view
@@ -4,21 +4,19 @@ urlBlock ) where import InputParser-import Control.Applicative import Control.Monad import Data.List import Data.Char (toLower)-import Data.Monoid import OptionsConverter-import Utils +import Utils import Control.Monad.State-import qualified Templates +import qualified Templates import qualified Data.Map as Map import Data.String.Utils (split)-import Data.Maybe -import System.IO +import Data.Maybe+import System.IO import System.FilePath-import PatternConverter +import PatternConverter data TaggerType = Client | Server data TaggerForwarder = Forward (Maybe Filter) String | CancelTagger String@@ -31,7 +29,7 @@ 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, +data FilteringNode = Node { _pattern :: [Pattern], _filters :: HeaderFilters, _nodeType :: ChainType, _policy :: Policy, _method :: BlockMethod } @@ -39,42 +37,42 @@ name :: a -> String urlBlock :: String -> [String] -> [Line] -> IO()-urlBlock path info = writeBlockData . urlBlockData - where +urlBlock path info = writeBlockData . urlBlockData+ where writeBlockData :: UrlBlockData -> IO()- writeBlockData (taggers, actions) = + writeBlockData (taggers, actions) = do writeContent (path </> "ab2p.filter") Templates.filtersFilePrefix taggers writeContent (path </> "ab2p.action") Templates.actionsFilePrefix actions- writeContent filename header content = + writeContent filename header content = do outFile <- openFile filename WriteMode hSetEncoding outFile utf8- hPutStrLn outFile header + hPutStrLn outFile header _ <- mapM (hPutStrLn outFile) $ ('#':) <$> info hPutStrLn outFile $ intercalate "\n\n" $ show <$> content hClose outFile -urlBlockData :: [Line] -> UrlBlockData +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 pattern options)) + where+ blockLine (Line position (RequestBlock policy pattern options)) = filteringNodes policy (errorToPattern expandedPatterns) options- where + where expandedPatterns = makePattern (_matchCase options) <<$> parseUrl pattern- sourceText = recordSourceText position + 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 _ _) + joinNodes (Node patterns1 filters1 type1 policy1 method1)+ (Node patterns2 _ type2 _ _) = Node (patterns1 ++ patterns2) filters1 (max type1 type2) policy1 method1 filterBlockData :: UrlBlockData -> UrlBlockData@@ -85,31 +83,31 @@ metric = length._forwarding joinTaggers tagger1 tagger2 | metric tagger1 >= metric tagger2 = tagger1 | otherwise = tagger2- -shortenNodes :: [FilteringNode] -> [FilteringNode] ++shortenNodes :: [FilteringNode] -> [FilteringNode] shortenNodes nodes = evalState (mapM shortenNode nodes) initialState- where + 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 + 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 + (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 +filteringNodes policy patterns requestOptions = join.join $ [mainResult, subdocumentResult, elemhideResult, dntResult, popupResult]- where + where mainResult = optionsToNodes mainOptions $> Request subdocumentResult = maybeToList (optionsToNodes (singleTypeOptions Subdocument) $> Xframe) elemhideResult = maybeToList (optionsToNodes (boolOptions _elemHide) $> Elem)@@ -121,7 +119,7 @@ boolOptions getter = if getter requestOptions then Nothing else Just requestOptions {_requestType = Restrictions Nothing [], _thirdParty = Nothing}- singleTypeOptions singleType = + singleTypeOptions singleType = do foundTypes <- filter (== singleType) <$> _positive requestType foundType <- listToMaybe foundTypes@@ -130,17 +128,17 @@ nestedOrRegular True = Nested nestedOrRegular False = Regular collectNodes :: [Pattern] -> Maybe HeaderFilters -> BlockMethod -> [FilteringNode]- collectNodes _ Nothing _ = [] + 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) + = Node patterns' filters (nestedOrRegular $ null patterns') policy method+ : (levelFilters >>= negateNode) ++ collectNodes [] (Just next) method- where - negateNode negateFilter@(HeaderFilter _ (Filter {_orEmpty = True})) + where+ negateNode negateFilter@(HeaderFilter _ (Filter {_orEmpty = True})) = [Node [] ([negateFilter] : next) Negate policy method]- negateNode _ = [] - + 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)@@ -151,48 +149,48 @@ negateTagger = newTagger flt nextLevelFilters policy method Negate [] nodeResult node@(Node patterns (levelFilters : nextLevelFilters) nodeType policy method) = (taggers, [action])- where + where action = Action { _actionCode = name node,- _switches = appendIf (policy == Unblock && method == Request) + _switches = appendIf (policy == Unblock && method == Request) (Switch False BlockAction) (Switch True . TaggerAction <$> taggers), _patterns = patterns,- _hasTag = nodeType == Nested } + _hasTag = nodeType == Nested } taggers = filterTaggers <$> levelFilters- filterTaggers flt@(HeaderFilter _ (Filter _ _ orEmpty)) + 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 } + _headerType = headerType } where filter'' | chainType == Negate = Nothing | otherwise = Just filter'- taggerCode = filtersCode ([flt] : nextLevelFilters) chainType policy method "" - nextLevelActionCode = filtersCode nextLevelFilters Nested policy method "" - + 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 "" - + 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 +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 (levelFilters : nextLevelFilters) chainType policy method rest = filtersCode nextLevelFilters Nested policy method $ join [levelCode, if null rest then "" else "-when-", rest]- where + where levelCode = intercalate "-" $ filterCode <$> levelFilters filterCode (HeaderFilter HeaderType {_typeCode = typeCode} (Filter code _ orEmpty)) | chainType == Negate = negateCode- | chainType == Nested && orEmpty = negateCode ++ '-' : mainCode + | chainType == Nested && orEmpty = negateCode ++ '-' : mainCode | otherwise = mainCode- where + where mainCode = typeCode : code negateCode = 'n' : [typeCode] @@ -207,59 +205,41 @@ name = _taggerCode instance Show Tagger where- show (Tagger code forwarding HeaderType {_name = headerName, _taggerType = taggerType }) + show (Tagger code forwarding HeaderType {_name = headerName, _taggerType = taggerType }) = intercalate "\n" (caption : (forward <$> forwarding)) where caption = show taggerType ++ (':' : ' ' : code) forward (Forward (Just filter') tagret) = forwardRegex headerName (_regex filter') ":" "" tagret forward (Forward Nothing tagret) = forwardRegex "" "" "" "" tagret forward (CancelTagger taggerCode) = forwardRegex headerName "" ":" "-" taggerCode forwardRegex header expression value tagPrefix tagret- = let (modifier, lookahead' : additionalLines) + = let (modifier, lookahead' : additionalLines) | '\n' `elem` expression = ("i", split "\n" expression) -- the case for third-party | otherwise = ("Ti", [expression])- in intercalate "\n" $ additionalLines ++ - [join ["s@^", header, lookahead', value, ".*@", tagPrefix, tagret, "@", modifier]] + in intercalate "\n" $ additionalLines +++ [join ["s@^", header, lookahead', value, ".*@", tagPrefix, tagret, "@", modifier]] instance Named Bool where name True = "+"- name False = "-" + 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)) + show (Switch enable (TaggerAction tagger)) = intercalate " \\\n " $ mainText : (_forwarding tagger >>= cancelTaggerText)- where + where mainText = join [name enable, name . _taggerType . _headerType $ tagger, "{", name tagger, "}" ]- cancelTaggerText (CancelTagger cancelTaggerCode) + cancelTaggerText (CancelTagger cancelTaggerCode) = [join [name enable, name . _taggerType . _headerType $ tagger, "{", cancelTaggerCode, "}" ]]- cancelTaggerText _ = [] - + 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 - - - - - - - - - - - - - - - - - - + | otherwise = patterns
src/UrlBlocker.hs-boot view
src/Utils.hs view
@@ -24,7 +24,7 @@ ) where import Control.Applicative hiding (many) import Control.Monad.Writer-import Control.Monad.State +import Control.Monad.State ------------------------------------------------------------------------------------------ ----------------------------- export -----------------------------------------------------@@ -32,13 +32,13 @@ -- at least one list should be finite compareList :: Ord a => [a] -> [a] -> Ordering-compareList = compareList' EQ +compareList = compareList' EQ where compareList' lx [] [] = lx compareList' _ [] _ = LT compareList' _ _ [] = GT- compareList' lx (x:xs) (y:ys) = compareList' (lx <> compare x y) xs ys - + compareList' lx (x:xs) (y:ys) = compareList' (lx <> compare x y) xs ys+ maxList :: Ord a => [a] -> [a] -> [a] maxList a b = if compareList a b == LT then b else a @@ -62,26 +62,26 @@ mappend x y = mappend <$> x <*> y class Struct2 f where- struct2 :: a1 -> a2 -> f a1 a2 + struct2 :: a1 -> a2 -> f a1 a2 square2 :: (Applicative g, Monoid a1, Monoid a2) => g a1 -> g a2 -> [g (f a1 a2)] square2 a1 a2 = makeSquare (pure'' struct2 <%> a1 <%> a2) class Struct3 f where struct3 :: a1 -> a2 -> a3 -> f a1 a2 a3- square3 :: (Applicative g, Monoid a1, Monoid a2, Monoid a3) => + square3 :: (Applicative g, Monoid a1, Monoid a2, Monoid a3) => g a1 -> g a2 -> g a3 -> [g (f a1 a2 a3)] square3 a1 a2 a3 = makeSquare (pure'' struct3 <%> a1 <%> a2 <%> a3)- + class Struct4 f where struct4 :: a1 -> a2 -> a3 -> a4 -> f a1 a2 a3 a4- square4 :: (Applicative g, Monoid a1, Monoid a2, Monoid a3, Monoid a4) => + square4 :: (Applicative g, Monoid a1, Monoid a2, Monoid a3, Monoid a4) => g a1 -> g a2 -> g a3 -> g a4 -> [g (f a1 a2 a3 a4)] square4 a1 a2 a3 a4 = makeSquare (pure'' struct4 <%> a1 <%> a2 <%> a3 <%> a4)- + class Struct5 f where struct5 :: a1 -> a2 -> a3 -> a4 -> a5 -> f a1 a2 a3 a4 a5- square5 :: (Applicative g, Monoid a1, Monoid a2, Monoid a3, Monoid a4, Monoid a5) => + square5 :: (Applicative g, Monoid a1, Monoid a2, Monoid a3, Monoid a4, Monoid a5) => g a1 -> g a2 -> g a3 -> g a4 -> g a5 -> [g (f a1 a2 a3 a4 a5)] square5 a1 a2 a3 a4 a5 = makeSquare (pure'' struct5 <%> a1 <%> a2 <%> a3 <%> a4 <%> a5) @@ -99,7 +99,7 @@ -- [Just ( "a", 0 , False ), -- Just ( "" , 1, False ), -- Just ( "" , 0 , True )]-------------------------- +------------------------- testSquare :: [Maybe (String, Sum Int, Any)] testSquare = square3 (Just "a") (Just (Sum $ length "")) (Just (Any True)) @@ -111,19 +111,19 @@ -- [(V,m), -- (m,V)] -- where V is for value, m is for mempty--- involves 2 applicatives/monads : +-- involves 2 applicatives/monads : -- State Int a - stores column number--- Reader ((->) r) - provides row number from outside +-- Reader ((->) r) - provides row number from outside valueOnDiagonal :: (Applicative f, Monoid a) => f a -> State Int (Int -> f a) valueOnDiagonal val = do col <- get put (col + 1)- return (\row -> if row == col - then val + return (\row -> if row == col+ then val else pure mempty) -- lifts right argument 2 levels up to become s (r (f a)) where s = State and r = Reader--- then applies left arg to right one +-- then applies left arg to right one -- it's used to put items to a line in matrix (<%>) :: (Applicative f, Monoid a) => State Int (Int -> f (a -> b)) -> f a -- becomes State Int (Int -> f a) after lift with valueOnDiagonal@@ -136,7 +136,7 @@ makeSquare line = let start = 0 (line', size) = runState line start in line' <$> [start .. size - 1]- + -- pure level 2 pure' :: (Applicative f, Applicative g) => a -> f (g a) pure' = pure.pure@@ -147,8 +147,8 @@ infixl 4 .*., <<$>, <<<$>, $>, $>>, $>>>, <<*>>, <<<*>>> -(.*.) :: (c -> d) -> - (a -> b -> c) -> +(.*.) :: (c -> d) ->+ (a -> b -> c) -> a -> b -> d (.*.) = (.).(.) @@ -159,13 +159,13 @@ (<<<$>) = fmap.fmap.fmap ($>) :: (Applicative f) => f (a -> b) -> a -> f b-($>) a b = a <*> pure b +($>) a b = a <*> pure b ($>>) :: (Applicative f, Applicative g) => f (g (a -> b)) -> a -> f (g b)-($>>) a b = a <<*>> pure' b +($>>) a b = a <<*>> pure' b ($>>>) :: (Applicative f, Applicative g, Applicative h) => f (g (h (a -> b))) -> a -> f (g (h b))-($>>>) a b = a <<<*>>> pure'' b +($>>>) a b = a <<<*>>> pure'' b (<<*>>) :: (Applicative f, Applicative g) => f (g (a -> b)) -> f (g a) -> f (g b) (<<*>>) = liftA2 (<*>)
+ stack.yaml view
@@ -0,0 +1,32 @@+# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md++# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)+resolver: lts-3.18++# Local packages, usually specified by relative directory name+packages:+- '.'++# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)+extra-deps: [parsec-permutation-0.1.2.0]++# Override default flag values for local packages and extra-deps+flags: {}++# Extra package databases containing global packages+extra-package-dbs: []++# Control whether we use the GHC we find on the path+# system-ghc: true++# Require a specific version of stack, using version ranges+# require-stack-version: -any # Default+# require-stack-version: >= 0.1.10.0++# Override the architecture used by stack, especially useful on Windows+# arch: i386+# arch: x86_64++# Extra directories used by stack for building+# extra-include-dirs: [/path/to/dir]+# extra-lib-dirs: [/path/to/dir]