diff --git a/INSTALL.rst b/INSTALL.rst --- a/INSTALL.rst +++ b/INSTALL.rst @@ -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 `_ (It includes GHC 7.8.3 compiler and Cabal) - * From Linux: Install Haskell platform from your distributive repository or follow `the guide `_ -2. Obtain sources. You can - - * Either download and extract sources from `Hackage `_ - * 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 `_ 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. diff --git a/README.rst b/README.rst --- a/README.rst +++ b/README.rst @@ -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 @@ #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 diff --git a/adblock2privoxy.cabal b/adblock2privoxy.cabal --- a/adblock2privoxy.cabal +++ b/adblock2privoxy.cabal @@ -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 -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 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 diff --git a/distribution/buildWin.bat b/distribution/buildWin.bat --- a/distribution/buildWin.bat +++ b/distribution/buildWin.bat @@ -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 diff --git a/distribution/debbuild/DEBIAN/control b/distribution/debbuild/DEBIAN/control new file mode 100644 --- /dev/null +++ b/distribution/debbuild/DEBIAN/control @@ -0,0 +1,35 @@ +Package: adblock2privoxy +Version: 1.4.0 +Depends: libgmp10 +Architecture: #ARCH# +Maintainer: Alexey Zubritskiy +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 + diff --git a/distribution/makeDeb.sh b/distribution/makeDeb.sh new file mode 100644 --- /dev/null +++ b/distribution/makeDeb.sh @@ -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 diff --git a/distribution/makeFedoraRpm.sh b/distribution/makeFedoraRpm.sh deleted file mode 100644 --- a/distribution/makeFedoraRpm.sh +++ /dev/null @@ -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 diff --git a/distribution/makeRpm.sh b/distribution/makeRpm.sh new file mode 100644 --- /dev/null +++ b/distribution/makeRpm.sh @@ -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 diff --git a/distribution/rpmbuild/SPECS/adblock2privoxy.spec b/distribution/rpmbuild/SPECS/adblock2privoxy.spec --- a/distribution/rpmbuild/SPECS/adblock2privoxy.spec +++ b/distribution/rpmbuild/SPECS/adblock2privoxy.spec @@ -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 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 - 1.3.3 -- Rpm release for new version (generated from cabal file) +* Thu Dec 24 2015 Alexey Zubritskiy - 1.4.0 +- Rpm release for version 1.4.0 (generated from cabal file) diff --git a/man/man1/adblock2privoxy.1 b/man/man1/adblock2privoxy.1 --- a/man/man1/adblock2privoxy.1 +++ b/man/man1/adblock2privoxy.1 @@ -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[] diff --git a/src/ElementBlocker.hs b/src/ElementBlocker.hs --- a/src/ElementBlocker.hs +++ b/src/ElementBlocker.hs @@ -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 - diff --git a/src/InputParser.hs b/src/InputParser.hs --- a/src/InputParser.hs +++ b/src/InputParser.hs @@ -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 - - - - - diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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."] - diff --git a/src/Network.hs b/src/Network.hs new file mode 100644 --- /dev/null +++ b/src/Network.hs @@ -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 diff --git a/src/OptionsConverter.hs b/src/OptionsConverter.hs --- a/src/OptionsConverter.hs +++ b/src/OptionsConverter.hs @@ -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 _ _ = [] diff --git a/src/ParsecExt.hs b/src/ParsecExt.hs --- a/src/ParsecExt.hs +++ b/src/ParsecExt.hs @@ -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 + ------------------------------------------------------------------------------------------------ diff --git a/src/PatternConverter.hs b/src/PatternConverter.hs --- a/src/PatternConverter.hs +++ b/src/PatternConverter.hs @@ -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 diff --git a/src/PolicyTree.hs b/src/PolicyTree.hs --- a/src/PolicyTree.hs +++ b/src/PolicyTree.hs @@ -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) diff --git a/src/PopupBlocker.hs b/src/PopupBlocker.hs --- a/src/PopupBlocker.hs +++ b/src/PopupBlocker.hs @@ -1,2 +1,1 @@ module PopupBlocker where - diff --git a/src/ProgramOptions.hs b/src/ProgramOptions.hs --- a/src/ProgramOptions.hs +++ b/src/ProgramOptions.hs @@ -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' diff --git a/src/SourceInfo.hs b/src/SourceInfo.hs --- a/src/SourceInfo.hs +++ b/src/SourceInfo.hs @@ -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' diff --git a/src/Statistics.hs b/src/Statistics.hs --- a/src/Statistics.hs +++ b/src/Statistics.hs @@ -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" - - - - - diff --git a/src/Task.hs b/src/Task.hs --- a/src/Task.hs +++ b/src/Task.hs @@ -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 - diff --git a/src/Templates.hs b/src/Templates.hs --- a/src/Templates.hs +++ b/src/Templates.hs @@ -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 diff --git a/src/UrlBlocker.hs b/src/UrlBlocker.hs --- a/src/UrlBlocker.hs +++ b/src/UrlBlocker.hs @@ -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 diff --git a/src/UrlBlocker.hs-boot b/src/UrlBlocker.hs-boot --- a/src/UrlBlocker.hs-boot +++ b/src/UrlBlocker.hs-boot diff --git a/src/Utils.hs b/src/Utils.hs --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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 (<*>) diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -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]