Changeset e2b555c in adblock2privoxy


Ignore:
Timestamp:
Dec 25, 2015 7:46:19 PM (4 years ago)
Author:
Alexey Zubritskiy <a.zubritskiy@…>
Branches:
master
Children:
433b59c
Parents:
f53c7cf
Message:

Adapted to GHC 7.10, introduced stack build

Files:
6 added
3 deleted
34 edited

Legend:

Unmodified
Added
Removed
  • .gitignore

    r6bfb8d3 re2b555c  
    99 
    1010RemoteSystemsTempFiles/ 
     11.stack-work/ 
  • adblock2privoxy-utils/adblock2privoxy-utils.cabal

    rb4685e7 re2b555c  
    11name:                adblock2privoxy-utils 
    2 version:             1.0.0 
     2version:             1.4.0 
    33cabal-version:       >= 1.10 
    44build-type:          Simple 
    5 tested-with:         GHC==7.8.3 
     5tested-with:         GHC==7.10.2 
    66author:              Alexey Zubritsky <adblock2privoxy@zubr.me> 
    77homepage:            https://projects.zubr.me/wiki/adblock2privoxy 
     
    1010license-file:        LICENSE 
    1111synopsis:            Helper utilities and scripts for adblock2privoxy project 
    12 description:          
     12description: 
    1313        * Creates config files for PRM packaging using values from cabal file 
    14         * Creates man help files from README  
     14        * Creates man help files from README 
    1515        . 
    1616        This package is only needed to pubish new releases of adblock2privoxy in hackage 
     
    2626  default-extensions: 
    2727                   FlexibleInstances 
    28   build-depends:    
     28  build-depends: 
    2929                   base >= 4 && < 5, 
    3030                   pandoc, 
     
    3636                   old-locale, 
    3737                   MissingH 
     38  other-modules: 
     39                   CabalTemplate 
     40                   DebControl 
     41                   ManPage 
     42                   RpmSpec 
     43                   RootPath 
    3844 
    39 source-repository head 
     45source-repository this 
    4046  type:      git 
    4147  location:  ​http://projects.zubr.me/adblock2privoxy.git 
    4248  subdir:    adblock2privoxy-utils 
     49  tag:       1.4.0 
  • adblock2privoxy-utils/automation/build_all.sh

    rf53c7cf re2b555c  
    11#!/bin/bash 
    2 echo "prepare rpm build:" 
     2echo "prepare build:" 
    33echo "remove temp files" 
    44rm -rf ../../adblock2privoxy/.dist-buildwrapper 
     5rm -rf ../../adblock2privoxy/.stack-work 
     6rm -rf ../../adblock2privoxy/dist 
    57 
    6 echo "start RPM build (see fedora*/build.log files for details)" 
    7 parallel ::: \ 
    8 './run_aws_build.sh ami-1eb35469 fedora "../../adblock2privoxy" "distribution/makeFedoraRpm" fedora20_64' \ 
    9 './run_aws_build.sh ami-0bac577c fedora "../../adblock2privoxy" "distribution/makeFedoraRpm" fedora20_i386'  
    10  
    11 echo "prepare deb build:" 
    12 echo "copy build script to bin directory" 
    13 cp ../../adblock2privoxy/distribution/makeDebFromRpm.sh fedora20_i386/ 
    14 cp ../../adblock2privoxy/distribution/makeDebFromRpm.sh fedora20_64/ 
    15  
    16 echo "start DEB build (see debian*/build.log files for details)" 
    17 parallel ::: \ 
    18 './run_aws_build.sh ami-e7e66a90 admin "fedora20_64" "makeDebFromRpm" debian7_64' \ 
    19 './run_aws_build.sh ami-1be06c6c admin "fedora20_i386" "makeDebFromRpm" debian7_i386'  
     8echo "start build (see */build.log files for details)" 
     9parallel --max-procs 0 ::: \ 
     10'./run_aws_build.sh ami-e0efab88 admin  "../../adblock2privoxy" "distribution/makeDeb" debian7_64' \ 
     11'./run_aws_build.sh ami-8b9a63e0 admin  "../../adblock2privoxy" "distribution/makeDeb" debian8_64' 
     12#'./run_aws_build.sh ami-032a5566 fedora "../../adblock2privoxy" "distribution/makeRpm" fedora22_64' \ 
     13#'./run_aws_build.sh ami-00443d6a fedora "../../adblock2privoxy" "distribution/makeRpm" fedora23_64' \ 
     14#'./run_aws_build.sh ami-02dc4c6b ec2-user "../../adblock2privoxy" "distribution/makeRpm" centos6_64' \ 
     15#'./run_aws_build.sh ami-61bbf104 centos "../../adblock2privoxy" "distribution/makeRpm" centos7_64' \ 
  • adblock2privoxy-utils/automation/run_aws_build.sh

    rf53c7cf re2b555c  
    1818--count 1 \ 
    1919--key-name ab2p \ 
    20 --security-groups launch-wizard-2 \ 
    21 --instance-type c1.medium \ 
    22 --block-device-mappings '[{"DeviceName": "/dev/sda1","Ebs": {"VolumeSize": 10,"DeleteOnTermination": true,"VolumeType": "standard"}}]' \ 
     20--security-groups ab2p \ 
     21--instance-type c3.large \ 
     22--instance-initiated-shutdown-behavior terminate \ 
    2323| sed -n -r '/InstanceId/ {s/.*:\s"([[:alnum:]-]+)".*/\1/;p}') 
    2424 
     25#--block-device-mappings '[{"DeviceName": "/dev/sda1","Ebs": {"VolumeSize": 30,"DeleteOnTermination": true,"VolumeType": "standard"}}]' \ 
    2526echo "$INSTANCE_ID created" 
    2627 
  • adblock2privoxy-utils/launches/adblock2privoxy (run file).launch

    rfcb4d77 re2b555c  
    11<?xml version="1.0" encoding="UTF-8" standalone="no"?> 
    22<launchConfiguration type="net.sf.eclipsefp.haskell.debug.core.internal.launch.ExecutableHaskellLaunchDelegate"> 
    3 <stringAttribute key="EXTRA_ARGUMENTS" value="-p ../.out/privoxy -w ../.out/web  -d tst.zu ../.data/test.txt"/> 
     3<stringAttribute key="EXTRA_ARGUMENTS" value="-p ../.out/privoxy -w ../.out/web  -d tst.zu /home/alexey/Downloads/easylist.txt"/> 
    44<stringAttribute key="PROJECT_NAME" value="adblock2privoxy"/> 
    55<stringAttribute key="STANZA" value="adblock2privoxy"/> 
  • adblock2privoxy-utils/src/CabalTemplate.hs

    r828fba4 re2b555c  
    44       (##), 
    55       text, 
    6        expandTemplate                 
    7 )  
     6       expandTemplate 
     7) 
    88where 
    99import Distribution.PackageDescription 
    1010import Distribution.Text 
    11 import Control.Applicative 
    1211 
    1312data CabalValue = Constant String | Function (PackageDescription -> String) 
     
    1716class CabalChainable c where 
    1817     append :: [CabalValue] -> c -> [CabalValue] 
    19       
     18 
    2019     (#) :: [[CabalValue]] -> c -> [[CabalValue]] 
    2120     (#) (line:lns) item = append line item : lns 
    2221     (#) [] item = [append [] item] 
    23       
     22 
    2423     (##) :: [[CabalValue]] -> c -> [[CabalValue]] 
    2524     (##) lns item = append [] item : lns 
     
    2726instance CabalChainable String where 
    2827     append line literal = Constant literal : line 
    29       
     28 
    3029instance CabalChainable (PackageDescription -> String) where 
    3130     append line getter = Function getter : line 
    32       
     31 
    3332text :: Text t => t -> String 
    3433text = show.disp 
     
    3635expandTemplate :: [[CabalValue]] -> PackageDescription -> String 
    3736expandTemplate template cabalMeta = (unlines.reverse) $ (concat.reverse) <$> stringified 
    38         where  
     37        where 
    3938        stringified = (fmap.fmap) stringify template 
    40          
     39 
    4140        stringify (Constant s) = s 
    4241        stringify (Function f) = f cabalMeta 
    43  
    44  
    45  
    46  
    47  
    48  
    49  
    50  
    51  
    52  
    53  
    54  
    55  
    56  
    57  
    58  
  • adblock2privoxy-utils/src/DebControl.hs

    rf53c7cf re2b555c  
    22module DebControl ( 
    33        createDebControl 
    4 )  
     4) 
    55where 
    6 import Control.Applicative  
    76import Control.Monad 
    87import Distribution.PackageDescription 
     
    109import CabalTemplate 
    1110import Data.Char 
     11import RootPath 
    1212 
    1313 
     
    1717        writeFile resultFile control 
    1818        when verbose $ putStrLn $ resultFile ++ " file created" 
    19          
     19 
    2020resultFile :: String 
    21 resultFile = "distribution/debbuild/DEBIAN/control" 
     21resultFile = rootPath ++ "distribution/debbuild/DEBIAN/control" 
     22 
     23prependSpace :: String -> String 
     24prependSpace = (' ':) 
     25 
     26emptyToDot :: String -> String 
     27emptyToDot [] = "." 
     28emptyToDot s = s 
     29 
     30description' :: PackageDescription -> String 
     31description' =  unlines.liftM (prependSpace.emptyToDot).lines.description 
    2232 
    2333template :: [[CabalValue]] 
    24 template = []  
     34template = [] 
    2535    ## "Package:         " # text.pkgName.package 
    2636    ## "Version:         " # text.pkgVersion.package 
    2737    ## "Depends:         libgmp10" 
    28     ## "Architecture:    any" 
     38    ## "Architecture:    #ARCH#" 
    2939    ## "Maintainer:      " # maintainer 
    3040    ## "Homepage:        " # homepage 
     
    3242    ## "Priority:        extra" 
    3343    ## "Recommends:      privoxy, nginx" 
    34     ## "Description:     " # synopsis # "\n" # description 
    35  
    36  
    37  
    38  
     44    ## "Description:     " # synopsis # "\n" # description' 
  • adblock2privoxy-utils/src/Main.hs

    rf53c7cf re2b555c  
    88import RpmSpec 
    99import DebControl 
     10import RootPath 
    1011 
    1112-- It is helper executable updating documentation 
    12 -- and distribution packages with  
     13-- and distribution packages with 
    1314-- latest metadata from .cabal file 
    1415 
     
    1617main = do 
    1718    verbose <- liftM (elem "--verbose") getArgs 
    18     cabalMeta <- liftM packageDescription $ readPackageDescription normal "adblock2privoxy.cabal" 
    19     createManPage verbose cabalMeta      
     19    cabalMeta <- liftM packageDescription $ readPackageDescription normal $ rootPath ++ "adblock2privoxy.cabal" 
     20    createManPage verbose cabalMeta 
    2021    createRpmSpec verbose cabalMeta 
    21     createDebControl verbose cabalMeta                                
    22  
     22    createDebControl verbose cabalMeta 
  • adblock2privoxy-utils/src/ManPage.hs

    r828fba4 re2b555c  
    11module ManPage( 
    22        createManPage 
    3 )  
     3) 
    44where 
    55import Text.Pandoc 
     
    1212import Text.Pandoc.Builder 
    1313import Distribution.Package 
    14 import Data.Time.Clock  
     14import Data.Time.Clock 
    1515import Data.Time 
    16 import System.Locale 
    1716import Distribution.Version (versionBranch) 
    1817import Data.List (intercalate) 
     18import RootPath 
    1919 
    2020createManPage:: Bool -> PackageDescription -> IO () 
    21 createManPage verbose cabalMeta = do  
    22     pandoc <- liftM (readRST def) $ UTF8.readFile "README.rst" 
     21createManPage verbose cabalMeta = do 
     22    pandocResult <- liftM (readRST def) $ UTF8.readFile $ rootPath ++ "README.rst" 
    2323    now <- getCurrentTime 
    24     let PackageIdentifier (PackageName name) version = package cabalMeta 
    25     let versionText = intercalate "." $ map show $ versionBranch version  
    26     let pandoc' = setTitle (text $ map toUpper name) .  
    27                   setAuthors [text $ author cabalMeta] .  
    28                   setDate (text $ formatTime defaultTimeLocale (iso8601DateFormat Nothing) now) . 
    29                   setMeta "section" (text "1") . 
    30                   setMeta "header" (text "General Commands Manual") . 
    31                   setMeta "footer" (text $ name ++ " " ++ versionText) 
    32                   $ pandoc  
    33     createDirectoryIfMissing True ("man" </> "man1") 
    34     writeManPage verbose ("man" </> "man1" </> "adblock2privoxy.1") pandoc' 
     24    case pandocResult of 
     25      Left pandocError -> print pandocError 
     26      Right pandoc -> do 
     27        let PackageIdentifier (PackageName name) version = package cabalMeta 
     28        let versionText = intercalate "." $ map show $ versionBranch version 
     29        let pandoc' = setTitle (text $ map toUpper name) . 
     30                      setAuthors [text $ author cabalMeta] . 
     31                      setDate (text $ formatTime defaultTimeLocale (iso8601DateFormat Nothing) now) . 
     32                      setMeta "section" (text "1") . 
     33                      setMeta "header" (text "General Commands Manual") . 
     34                      setMeta "footer" (text $ name ++ " " ++ versionText) 
     35                      $ pandoc 
     36        createDirectoryIfMissing True ("man" </> "man1") 
     37        writeManPage verbose ("man" </> "man1" </> "adblock2privoxy.1") pandoc' 
    3538 
    3639writeManPage :: Bool -> FilePath -> Pandoc -> IO () 
     
    4043        Left ex -> print ex 
    4144        Right template' -> do 
    42           let opts = def{ writerStandalone = True,  
     45          let opts = def{ writerStandalone = True, 
    4346                          writerTemplate = template'} 
    4447          let manPage = writeMan opts $ 
  • adblock2privoxy-utils/src/RpmSpec.hs

    r126bdbc re2b555c  
    22module RpmSpec ( 
    33        createRpmSpec 
    4 )  
     4) 
    55where 
    6 import Control.Applicative  
    7 import Data.String.Utils  
     6import Data.String.Utils 
    87import Control.Monad 
    98import Distribution.PackageDescription 
     
    1211import Data.Time.Clock 
    1312import Data.Time.Format 
    14 import System.Locale 
     13import RootPath 
    1514 
    1615 
     
    2120        writeFile resultFile rpm 
    2221        when verbose $ putStrLn $ resultFile ++ " file created" 
    23          
     22 
    2423resultFile :: String 
    25 resultFile = "distribution/rpmbuild/SPECS/adblock2privoxy.spec" 
     24resultFile = rootPath ++ "distribution/rpmbuild/SPECS/adblock2privoxy.spec" 
    2625 
    2726template :: UTCTime -> [[CabalValue]] 
    28 template now = []  
     27template now = [] 
    2928        ## "Name:    " # text.pkgName.package 
    3029        ## "Version: " # text.pkgVersion.package 
     
    3433        ## "License: " # text.license 
    3534        ## "URL:     " # homepage 
    36         ## "Source0: http://hackage.haskell.org/package/"  
    37                 # text.pkgName.package # "-" # text.pkgVersion.package # "/"  
     35        ## "Source0: http://hackage.haskell.org/package/" 
     36                # text.pkgName.package # "-" # text.pkgVersion.package # "/" 
    3837                # text.pkgName.package # "-" # text.pkgVersion.package # ".tar.gz" 
    3938        ## "Vendor:  " # maintainer 
    4039        ## "Group:   " # category 
    4140        ## "" 
    42         ## "BuildRequires:  ghc-Cabal-devel" 
    43         ## "BuildRequires:  ghc-rpm-macros" 
    44         ## "BuildRequires:  cabal-install" 
     41        ## "BuildRequires:  stack" 
    4542        ## "BuildRequires:  zlib-devel" 
     43        -- "BuildRequires:  ghc-rpm-macros" 
     44        -- ## "BuildRequires:  cabal-install" 
     45        -- ## "BuildRequires:  zlib-devel" 
    4646        ## "" 
    4747        ## "%description" 
    4848        ## description 
    4949        ## "" 
     50        ## "%define debug_package %{nil}" 
    5051        ## "" 
    5152        ## "%prep" 
    5253        ## "%setup -q -T -D -n root" 
    53         ## "cabal update" 
    54         ## "cabal install --user --only-dependencies --enable-optimization=2" 
     54        ## "stack setup" 
     55        ## "stack install cabal-install" 
    5556        ## "" 
    5657        ## "" 
    5758        ## "%build" 
    58         ## "%global cabal_configure_options --user" 
    59         ## "%global ghc_user_conf 1" 
    60         ## "%global ghc_without_dynamic 1" 
    61         ## "%ghc_bin_build" 
     59        ## "stack build --only-dependencies" 
     60        ## "stack exec --no-ghc-package-path runhaskell -- Setup.hs configure --user " # 
     61           "--package-db=clear --package-db=global --package-db=\"$(stack path --snapshot-pkg-db)\" --package-db=\"$(stack path --local-pkg-db)\" " # 
     62           "--prefix=%{_prefix} --libdir=%{_libdir} --docdir=%{?_pkgdocdir}%{!?_pkgdocdir:%{_docdir}/%{name}-%{version}} --libsubdir='$compiler/$pkgid' --datasubdir='$pkgid'" 
     63        ## "stack exec --no-ghc-package-path runhaskell -- Setup.hs build" 
    6264        ## "" 
    6365        ## "" 
    6466        ## "%install" 
    65         ## "%ghc_bin_install" 
    66         ## "cp -r man %{buildroot}%{_mandir}"  
     67        ## "stack exec --no-ghc-package-path runhaskell -- Setup.hs copy --destdir=%{buildroot} -v" 
     68        ## "cp -r man %{buildroot}%{_mandir}" 
    6769        ## "" 
    6870        ## "" 
    6971        ## "%files" 
    7072        ## "%doc %{_mandir}" 
    71         ## "%doc " # (licenseFile) # " "  
    72                    # (unwords <$> filter (not.startswith "man")  
    73                                  .filter (not.startswith "distribution")  
     73        ## "%doc " # (unwords <$> licenseFiles) # " " 
     74                   # (unwords <$> filter (not.startswith "man") 
     75                                 .filter (not.startswith "distribution") 
     76                                 .filter (not.startswith "stack") 
    7477                                 . extraSrcFiles) 
    7578        ## "%{_bindir}/%{name}" 
     
    7780        ## "" 
    7881        ## "" 
    79         ## "%changelog"  
    80         ## "* " # formatTime defaultTimeLocale "%a %b %d %Y" now  
     82        ## "%changelog" 
     83        ## "* " # formatTime defaultTimeLocale "%a %b %d %Y" now 
    8184                # " " # maintainer # " - " # text.pkgVersion.package 
    82         ## "- Rpm release for new version (generated from cabal file)" 
    83  
    84  
    85  
     85        ## "- Rpm release for version " # text.pkgVersion.package #" (generated from cabal file)" 
  • adblock2privoxy/INSTALL.rst

    rf53c7cf re2b555c  
    11============================ 
    2 Adblock2Privoxy installation  
     2Adblock2Privoxy installation 
    33============================ 
    44 
     
    1212From sources 
    1313------------ 
    14 You can install adblock2privoxy from sources if there is no binary package for your system.  
     14You can install adblock2privoxy from sources if there is no binary package for your system. 
    1515 
    16 1. Ensure you have Haskell compiler and Cabal  
     161. Ensure you have Haskell compiler and Cabal 
    1717 
    18         * 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) 
    19         * From Linux: Install Haskell platform from your distributive repository or follow `the guide <http://www.stackage.org/install>`_ 
    20 2. Obtain sources. You can  
     18        * Install `Stack <http://docs.haskellstack.org/en/stable/install_and_upgrade.html>`_ for your platform 
     192. Run:: 
    2120 
    22         * Either download and extract sources from `Hackage <http://hackage.haskell.org/package/adblock2privoxy>`_ 
    23         * Or clone git repository with `git clone http://projects.zubr.me/adblock2privoxy.git` 
    24  
    25 3. Open console and go to the sources folder   
    26 4. Run::  
    27  
    28         cabal update 
    29         cabal install --user --only-dependencies --enable-optimization=2 
    30         runhaskell Setup.hs configure --user --enable-optimization=2  
    31         runhaskell Setup.hs build 
    32         runhaskell Setup.hs install 
     21        stack setup 
     22        stack install adblock2privoxy 
    3323 
    3424Packaging 
    3525--------- 
    36 You can create your own binary package for adblock2privoxy. There are two ways:  
     26You can create your own binary package for adblock2privoxy. 
    3727 
    38         * Use scripts from `distribution` folder 
    39         * 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.  
    40  
     28        * Use scripts from `distribution` folder for your platform. 
  • adblock2privoxy/README.rst

    rff7ee56 re2b555c  
    11=============== 
    2 Adblock2Privoxy  
     2Adblock2Privoxy 
    33=============== 
    44 
     
    1616but it is client software and cannot work on a server as a proxy. 
    1717 
    18 Privoxy proxy has good potential to block ads at server side,  
     18Privoxy proxy has good potential to block ads at server side, 
    1919but it experiences acute shortage of updated block lists. 
    2020 
    21 This software converts adblock lists to privoxy config files format.    
     21This software converts adblock lists to privoxy config files format. 
    2222 
    2323Almost all adblock features are supported including 
     
    3535  * Supported: script, image, stylesheet, object, xmlhttprequest, object-subrequest, subdocument,document, elemhide, other, popup, third-party, domain=..., match-case, donottrack 
    3636  * Unsupported: collapse, background, xbl, ping and dtd 
    37    
     37 
    3838Tested with privoxy version 3.0.21. 
    3939Element hiding feature requires a webserver to serve CSS files. See Nginx and Apache config examples provided. 
     
    4242----------- 
    4343 
    44 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.  
     44Adblock 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. 
    4545 
    46 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.  
     46If 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. 
    4747 
    4848Options 
    4949------- 
    50    
    51   -v         --version            
     50 
     51  -v         --version 
    5252      Show version number 
    53   -p PATH    --privoxyDir=PATH     
     53  -p PATH    --privoxyDir=PATH 
    5454      Privoxy config output path 
    55   -w PATH    --webDir=PATH        
     55  -w PATH    --webDir=PATH 
    5656      Css files output path 
    57   -d DOMAIN  --domainCSS=DOMAIN    
     57  -d DOMAIN  --domainCSS=DOMAIN 
    5858      Domain of CSS web server (required for Element Hide functionality) 
    59   -t PATH    --taskFile=PATH      
     59  -t PATH    --taskFile=PATH 
    6060      Path to task file containing urls to process and options. 
    61   -f         --forced             
     61  -f         --forced 
    6262      Run even if no sources are expired 
    6363 
     
    6868If webDir is not specified (and cannot be taken from task file), privoxyDir value is used for webDir. 
    6969 
    70 If domainCSS is not specified (and cannot be taken from task file), Element Hide functionality become disabled (and no webserver is needed).  
     70If domainCSS is not specified (and cannot be taken from task file), Element Hide functionality become disabled (and no webserver is needed). 
    7171 
    72 domainCSS can contain just IP address if no CSS web server has no associated domain.   
     72domainCSS can contain just IP address if no CSS web server has no associated domain. 
    7373 
    7474Usage 
     
    8585The app generates following files 
    8686 
    87         * privoxyDir:  
     87        * privoxyDir: 
    8888 
    8989                * ab2p.system.action 
     
    9292                * ab2p.filter 
    9393 
    94         * webDir:  
     94        * webDir: 
    9595 
    9696                * ab2p.common.css 
    9797                * ab2p.css 
    98                 * [lot of directories for all levels of domain names]  
     98                * [lot of directories for all levels of domain names] 
    9999 
    100100        * taskFile: 
    101101 
    102     * special file containing execution details. It can be reused to update privoxy config from same sources with same options.  
     102    * special file containing execution details. It can be reused to update privoxy config from same sources with same options. 
    103103 
    104104How to apply results 
     
    123123            server_name www.example.com; 
    124124 
    125             #root = webDir parameter value  
    126             root /var/www/privoxy;  
     125            #root = webDir parameter value 
     126            root /var/www/privoxy; 
    127127 
    128128            location ~ ^/[^/.]+\..+/ab2p.css$ { 
     
    135135                # if it is unavailable - get CSS for parent domain 
    136136                try_files $uri $1ab2p.css; 
    137             }  
     137            } 
    138138    } 
    139139 
     
    143143    <VirtualHost *:80> 
    144144            #ab2p css domain name (optional, should be equal to domainCSS parameter) 
    145             ServerName www.example.com  
     145            ServerName www.example.com 
    146146 
    147             #root = webDir parameter value  
     147            #root = webDir parameter value 
    148148            DocumentRoot /var/www/privoxy 
    149149 
  • adblock2privoxy/adblock2privoxy.cabal

    rfcb4d77 re2b555c  
    11name:                adblock2privoxy 
    2 version:             1.3.3 
     2version:             1.4.0 
    33cabal-version:       >= 1.10 
    44build-type:          Simple 
    5 tested-with:          
    6                      GHC==7.8.3, 
    7                      GHC==7.6.3 
     5tested-with: 
     6                     GHC==7.10.2 
    87author:              Alexey Zubritsky <adblock2privoxy@zubr.me> 
    9 data-files:           
     8data-files: 
    109                templates/ab2p.system.action, 
    1110                templates/ab2p.system.filter 
    12 extra-source-files:   
     11extra-source-files: 
     12                stack.yaml 
    1313                README.rst 
    1414                INSTALL.rst 
     
    1717                distribution/rpmbuild/SPECS/adblock2privoxy.spec 
    1818                distribution/buildWin.bat 
    19                 distribution/makeFedoraRpm.sh 
     19                distribution/makeRpm.sh 
     20                distribution/debbuild/DEBIAN/control 
     21                distribution/makeDeb.sh 
    2022license:             GPL-3 
    2123maintainer:          Alexey Zubritskiy <adblock2privoxy@zubr.me> 
     
    2527category:            Web 
    2628synopsis:            Convert adblock config files to privoxy format 
    27 description:          
     29description: 
    2830                       AdBlock Plus browser plugin has great block list files provided by big community, 
    2931                       but it is client software and cannot work on a server as proxy. 
     
    5759  default-language: Haskell2010 
    5860  default-extensions: 
    59                    RankNTypes,  
    60                    ScopedTypeVariables,  
     61                   RankNTypes, 
     62                   ScopedTypeVariables, 
    6163                   FlexibleInstances, 
    62                    GeneralizedNewtypeDeriving 
    63   build-depends:    
     64                   GeneralizedNewtypeDeriving, 
     65                   FlexibleContexts 
     66  build-depends: 
    6467                   base >= 4 && < 5, 
    6568                   parsec, 
     
    6972                   directory, 
    7073                   MissingH, 
    71                    parsec-permutation, 
     74                   parsec-permutation >= 0.1.2.0, 
    7275                   time >=1.4, 
    7376                   old-locale >=1.0, 
     
    7679                   http-conduit, 
    7780                   text >=0.11, 
    78                    network-uri  
     81                   network-uri, 
     82                   case-insensitive 
    7983  ghc-options:     -Wall 
    80   other-modules:    
     84  other-modules: 
    8185                   ElementBlocker, 
    8286                   InputParser, 
     87                   Network, 
    8388                   OptionsConverter, 
    8489                   ParsecExt, 
     
    99104  location:  ​http://projects.zubr.me/adblock2privoxy.git 
    100105  subdir:    adblock2privoxy 
    101   tag:       1.3.3 
     106  tag:       1.4.0 
  • adblock2privoxy/distribution/buildWin.bat

    r18729f8 re2b555c  
    22ECHO   This script compiles adblock2privoxy to windows binary. 
    33 
    4 ECHO   Make sure you have Haskell comiler and Cabal installed before run of this script. 
    5 ECHO   You can download MinGHC installer (including GHC 7.8.3 compiler and Cabal)  
    6 ECHO   from https://s3.amazonaws.com/download.fpcomplete.com/minghc/minghc-7.8.3.exe. 
     4ECHO   Make sure you have Haskell Stack installed before running this script. 
     5ECHO   See http://docs.haskellstack.org/en/stable/install_and_upgrade.html#windows 
     6ECHO   for installation details. 
    77 
    8 MKDIR binary\adblock2privoxy 
    9 CD .. 
    10 cabal update 
    11 runhaskell Setup.hs configure --user --prefix=%cd%\distribution\binary\adblock2privoxy 
    12 runhaskell Setup.hs build 
    13 runhaskell Setup.hs install 
    14 CD distribution\binary 
     8SET "startpath=%~dp0\.." 
     9SET "prefix=%~dp0\binary\adblock2privoxy" 
     10SET "stack=%appdata%\local\bin\stack" 
     11ECHO Install GHC and Cabal 
     12CD %USERPROFILE% 
     13"%stack%" setup 
     14"%stack%" build cabal-install 
     15 
     16ECHO Build package dependencies with stack first 
     17CD "%startpath%" 
     18 
     19"%stack%" build --only-dependencies 
     20 
     21FOR /F "tokens=* USEBACKQ" %%F IN (`"%stack%" path --snapshot-pkg-db`) DO ( 
     22SET snapshotdb=%%F 
     23) 
     24 
     25FOR /F "tokens=* USEBACKQ" %%F IN (`"%stack%" path --local-pkg-db`) DO ( 
     26SET localdb=%%F 
     27) 
     28 
     29ECHO snapshots package DB = %snapshotdb% 
     30ECHO local package DB = %localdb% 
     31 
     32MKDIR "%prefix%" 
     33"%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%"  
     34"%stack%" exec --no-ghc-package-path runhaskell -- Setup.hs build 
     35"%stack%" exec --no-ghc-package-path runhaskell -- Setup.hs install 
     36CD "%prefix%" 
    1537 
    1638ECHO Build is done. The result is in current folder 
  • adblock2privoxy/distribution/debbuild/DEBIAN/control

    rf53c7cf re2b555c  
    11Package:         adblock2privoxy 
    2 Version:         1.3.3 
     2Version:         1.4.0 
    33Depends:         libgmp10 
    4 Architecture:    any 
     4Architecture:    #ARCH# 
    55Maintainer:      Alexey Zubritskiy <adblock2privoxy@zubr.me> 
    66Homepage:        https://projects.zubr.me/wiki/adblock2privoxy 
     
    99Recommends:      privoxy, nginx 
    1010Description:     Convert adblock config files to privoxy format 
    11 AdBlock Plus browser plugin has great block list files provided by big community, 
    12 but it is client software and cannot work on a server as proxy. 
     11 AdBlock Plus browser plugin has great block list files provided by big community, 
     12 but it is client software and cannot work on a server as proxy. 
     13 . 
     14 Privoxy proxy has good potential to block ads at server side, 
     15 but it experiences acute shortage of updated block lists. 
     16 . 
     17 This software converts adblock lists to privoxy config files format. 
     18 . 
     19 Almost all adblock features are supported including 
     20 . 
     21 * block/unblock requests (on privoxy) 
     22 . 
     23 all syntax features are supported except for regex templates matching host name 
     24 . 
     25 * hide/unhide page elements (via CSS) 
     26 . 
     27 all syntax features are supported 
     28 . 
     29 * all block request options except for outdated ones: 
     30 . 
     31 Supported: script, image, stylesheet, object, xmlhttprequest, object-subrequest, subdocument, 
     32 document, elemhide, other, popup, third-party, domain=..., match-case, donottrack 
     33 . 
     34 Unsupported: collapse, background, xbl, ping and dtd 
    1335 
    14 Privoxy proxy has good potential to block ads at server side, 
    15 but it experiences acute shortage of updated block lists. 
    16  
    17 This software converts adblock lists to privoxy config files format. 
    18  
    19 Almost all adblock features are supported including 
    20  
    21 * block/unblock requests (on privoxy) 
    22  
    23 all syntax features are supported except for regex templates matching host name 
    24  
    25 * hide/unhide page elements (via CSS) 
    26  
    27 all syntax features are supported 
    28  
    29 * all block request options except for outdated ones: 
    30  
    31 Supported: script, image, stylesheet, object, xmlhttprequest, object-subrequest, subdocument, 
    32 document, elemhide, other, popup, third-party, domain=..., match-case, donottrack 
    33  
    34 Unsupported: collapse, background, xbl, ping and dtd 
  • adblock2privoxy/distribution/makeDeb.sh

    rf53c7cf re2b555c  
    11#!/bin/bash 
    22set -e 
    3 echo "This script builds adblock2privoxy to binary DEB on Debian 7." 
     3echo "This script builds adblock2privoxy to binary DEB on Debian 7-8 x64" 
    44echo "It can be easilly adapted to any other linux system with replacing pathes and apt-get calls to corresponding package manager" 
    55 
     6echo "remember dirs" 
    67initialDir=$PWD 
     8script="$(readlink -f ${BASH_SOURCE[0]})" 
     9scriptDir="$(dirname $script)" 
     10codename="$(lsb_release -c | sed -r 's/.+:\s+(\w+)/\1/')" 
    711 
    812echo "install tools" 
    9 sudo apt-get -y install libgmp10-dev libz-dev checkinstall 
     13echo "deb http://download.fpcomplete.com/debian $codename main" | sudo tee /etc/apt/sources.list.d/fpco.list 
    1014 
    11 echo "install ghc" 
    12 cd $initialDir 
    13 wget https://www.haskell.org/ghc/dist/7.8.4/ghc-7.8.4-x86_64-unknown-linux-deb7.tar.bz2 
    14 tar xvjf ghc-7.8.4-x86_64-unknown-linux-deb7.tar.bz2  
    15 cd ghc-7.8.4 
     15sudo apt-get update 
     16sudo apt-get -y --force-yes install stack 
    1617 
    17 ./configure --prefix=/home/admin/ghc 
    18 make install 
     18echo "install ghc and cabal" 
     19cd ~ 
     20stack setup 
     21stack install cabal-install 
    1922 
    20 export PATH=$PATH:/home/admin/.cabal/bin:/home/admin/ghc/bin 
    21  
    22 echo "install cabal" 
    23 cd $initialDir 
    24 wget http://hackage.haskell.org/package/cabal-install-1.20.0.3/cabal-install-1.20.0.3.tar.gz 
    25 tar -zxvf cabal-install-1.20.0.3.tar.gz 
    26 cd cabal-install-1.20.0.3 
    27 sh bootstrap.sh 
    28  
    29 echo "change dir" 
    30 script="$(readlink -f ${BASH_SOURCE[0]})" 
    31 scriptDir="$(dirname $script)" 
     23echo "change dir to $scriptDir" 
    3224cd $scriptDir 
    3325echo "working dir is $PWD" 
     
    3527echo "build adblock2privoxy" 
    3628cd .. 
    37 cabal update 
    38 cabal install --user --only-dependencies --enable-optimization=2 
    39 runhaskell Setup.hs configure --user --enable-optimization=2 --prefix=/usr 
    40 runhaskell Setup.hs build 
    41 runhaskell Setup.hs copy --destdir=distribution/debbuild 
    42 cp man distribution/debbuild/usr/share/ 
     29stack build --only-dependencies 
     30 
     31stack 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)" 
     32stack exec --no-ghc-package-path runhaskell -- Setup.hs build 
     33stack exec --no-ghc-package-path runhaskell -- Setup.hs copy --destdir=distribution/debbuild 
     34cp -r man distribution/debbuild/usr/share/ 
     35echo "set architecture" 
     36sed -i -e "s/#ARCH#/$(dpkg --print-architecture)/" distribution/debbuild/DEBIAN/control 
    4337 
    4438echo "create DEB" 
     
    4640dpkg-deb -b distribution/debbuild $initialDir/result 
    4741cd  $initialDir/result 
     42echo "rename result" 
     43version=${cat /etc/debian_version} 
     44find . -name '*.deb' -exec sh -c 'mv "$0" "${0%.deb}.debian$version.deb"' {} \; 
    4845 
    49 echo "Build is done. The result is in current folder" 
     46echo "Build is done." 
     47 
     48read -t 15 -n 1 -p "Press any key to cancel shutdown" 
     49if [ $? == 0 ]; then 
     50    echo "The result is in current folder" 
     51else 
     52    sudo shutdown -h +10 
     53fi 
  • adblock2privoxy/distribution/rpmbuild/SPECS/adblock2privoxy.spec

    rf53c7cf re2b555c  
    11Name:    adblock2privoxy 
    2 Version: 1.3.3 
     2Version: 1.4.0 
    33Release: 1%{?dist} 
    44Summary: Convert adblock config files to privoxy format 
     
    66License: GPL-3 
    77URL:     https://projects.zubr.me/wiki/adblock2privoxy 
    8 Source0: http://hackage.haskell.org/package/adblock2privoxy-1.3.3/adblock2privoxy-1.3.3.tar.gz 
     8Source0: http://hackage.haskell.org/package/adblock2privoxy-1.4.0/adblock2privoxy-1.4.0.tar.gz 
    99Vendor:  Alexey Zubritskiy <adblock2privoxy@zubr.me> 
    1010Group:   Web 
    1111 
    12 BuildRequires:  ghc-Cabal-devel 
    13 BuildRequires:  ghc-rpm-macros 
    14 BuildRequires:  cabal-install 
     12BuildRequires:  stack 
    1513BuildRequires:  zlib-devel 
    1614 
     
    4139Unsupported: collapse, background, xbl, ping and dtd 
    4240 
     41%define debug_package %{nil} 
    4342 
    4443%prep 
    4544%setup -q -T -D -n root 
    46 cabal update 
    47 cabal install --user --only-dependencies --enable-optimization=2 
     45stack setup 
     46stack install cabal-install 
    4847 
    4948 
    5049%build 
    51 %global cabal_configure_options --user 
    52 %global ghc_user_conf 1 
    53 %global ghc_without_dynamic 1 
    54 %ghc_bin_build 
     50stack build --only-dependencies 
     51stack 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' 
     52stack exec --no-ghc-package-path runhaskell -- Setup.hs build 
    5553 
    5654 
    5755%install 
    58 %ghc_bin_install 
     56stack exec --no-ghc-package-path runhaskell -- Setup.hs copy --destdir=%{buildroot} -v 
    5957cp -r man %{buildroot}%{_mandir} 
    6058 
     
    6866 
    6967%changelog 
    70 * Fri Feb 20 2015 Alexey Zubritskiy <adblock2privoxy@zubr.me> - 1.3.3 
    71 - Rpm release for new version (generated from cabal file) 
     68* Thu Dec 24 2015 Alexey Zubritskiy <adblock2privoxy@zubr.me> - 1.4.0 
     69- Rpm release for version 1.4.0 (generated from cabal file) 
  • adblock2privoxy/man/man1/adblock2privoxy.1

    rf53c7cf re2b555c  
    1 .TH "ADBLOCK2PRIVOXY" "1" "2015\-02\-20" "adblock2privoxy 1.3.3" "General Commands Manual" 
     1.TH "ADBLOCK2PRIVOXY" "1" "2015\-02\-21" "adblock2privoxy 1.3.4" "General Commands Manual" 
    22.SH ADBLOCK2PRIVOXY 
    33.PP 
  • adblock2privoxy/src/ElementBlocker.hs

    r126bdbc re2b555c  
    33) where 
    44import InputParser hiding (Policy(..)) 
    5 import qualified InputParser  
     5import qualified InputParser 
    66import PolicyTree 
    7 import Control.Applicative 
    87import qualified Data.Map as Map 
    98import Data.Maybe 
     
    1110import System.IO 
    1211import System.FilePath 
    13 import Data.List  
     12import Data.List 
    1413import System.Directory 
    15 import qualified Templates  
    16 import Control.Monad  
     14import qualified Templates 
     15import Control.Monad 
    1716import Data.String.Utils (startswith) 
    18    
    1917 
    20 type BlockedRulesTree = DomainTree [Pattern]  
     18 
     19type BlockedRulesTree = DomainTree [Pattern] 
    2120data ElemBlockData = ElemBlockData [Pattern] BlockedRulesTree deriving Show 
    2221 
     
    2524    where 
    2625    writeElemBlock :: ElemBlockData -> IO () 
    27     writeElemBlock (ElemBlockData flatPatterns rulesTree) =  
     26    writeElemBlock (ElemBlockData flatPatterns rulesTree) = 
    2827        do 
    2928           let debugPath = path </> "debug" 
     
    3130           createDirectoryIfMissing True path 
    3231           cont <- getDirectoryContents path 
    33            _ <- sequence $ removeOld <$> cont  
     32           _ <- sequence $ removeOld <$> cont 
    3433           createDirectoryIfMissing True debugPath 
    35            writeBlockTree path debugPath rulesTree  
    36            writePatterns filteredInfo (path </> "ab2p.common.css") (debugPath </> "ab2p.common.css") flatPatterns       
    37     removeOld entry' =  
     34           writeBlockTree path debugPath rulesTree 
     35           writePatterns filteredInfo (path </> "ab2p.common.css") (debugPath </> "ab2p.common.css") flatPatterns 
     36    removeOld entry' = 
    3837        let entry = path </> entry' 
    39         in do  
     38        in do 
    4039           isDir <- doesDirectoryExist entry 
    41            if isDir then when (head entry' /= '.') $ removeDirectoryRecursive entry     
    42                     else when (takeExtension entry == ".css") $ removeFile entry              
     40           if isDir then when (head entry' /= '.') $ removeDirectoryRecursive entry 
     41                    else when (takeExtension entry == ".css") $ removeFile entry 
    4342    writeBlockTree :: String -> String -> BlockedRulesTree -> IO () 
    4443    writeBlockTree normalNodePath debugNodePath (Node name patterns children) = 
     
    4746            createDirectoryIfMissing True debugPath 
    4847            _ <- sequence (writeBlockTree normalPath debugPath <$> children) 
    49             writePatterns ["See ab2p.common.css for sources info"] normalFilename debugFilename patterns         
     48            writePatterns ["See ab2p.common.css for sources info"] normalFilename debugFilename patterns 
    5049        where 
    51             normalPath  
     50            normalPath 
    5251                | null name = normalNodePath 
    5352                | otherwise = normalNodePath </> name 
    54             debugPath  
     53            debugPath 
    5554                | null name = debugNodePath 
    5655                | otherwise = debugNodePath </> name 
    5756            normalFilename = normalPath </> "ab2p.css" 
    58             debugFilename = debugPath </> "ab2p.css"       
     57            debugFilename = debugPath </> "ab2p.css" 
    5958    writePatterns :: [String] -> String -> String -> [Pattern] -> IO () 
    6059    writePatterns _ _ _ [] = return () 
    61     writePatterns info' normalFilename debugFilename patterns =  
    62          do  
     60    writePatterns info' normalFilename debugFilename patterns = 
     61         do 
    6362            writeCssFile debugFilename $ intercalate "\n" $ (++ Templates.blockCss) <$> patterns 
    64             writeCssFile normalFilename $ intercalate "\n" $ (++ Templates.blockCss) <$> intercalate "," <$>  
    65                                                                             splitEvery 4000 patterns 
    66          where  
     63            writeCssFile normalFilename $ intercalate "\n" ((++ Templates.blockCss) . intercalate "," <$> 
     64                                                                            splitEvery 4000 patterns) 
     65         where 
    6766         splitEvery n = takeWhile (not . null) . unfoldr (Just . splitAt n) 
    68          writeCssFile filename content =  
     67         writeCssFile filename content = 
    6968                do outFile <- openFile filename WriteMode 
    7069                   hSetEncoding outFile utf8 
     
    7372                   hPutStrLn outFile "*/" 
    7473                   hPutStrLn outFile content 
    75                    hClose outFile  
    76           
    77 elemBlockData :: [Line] -> ElemBlockData  
    78 elemBlockData input = ElemBlockData  
     74                   hClose outFile 
     75 
     76elemBlockData :: [Line] -> ElemBlockData 
     77elemBlockData input = ElemBlockData 
    7978                        (Map.foldrWithKey appendFlatPattern []              policyTreeMap) 
    80                         (Map.foldrWithKey appendTreePattern (Node "" [] []) policyTreeMap)  
    81     where  
    82     policyTreeMap :: Map.Map String PolicyTree  
    83     policyTreeMap =  Map.unionWith (trimTree Block .*. mergePolicyTrees Unblock)  
    84                             blockLinesMap  
     79                        (Map.foldrWithKey appendTreePattern (Node "" [] []) policyTreeMap) 
     80    where 
     81    policyTreeMap :: Map.Map String PolicyTree 
     82    policyTreeMap =  Map.unionWith (trimTree Block .*. mergePolicyTrees Unblock) 
     83                            blockLinesMap 
    8584                            (erasePolicy Block <$> unblockLinesMap) 
    86         where  
     85        where 
    8786        blockLinesMap = Map.fromListWith (mergeAndTrim Block) (mapMaybe blockLine input) 
    8887        unblockLinesMap = Map.fromListWith (mergeAndTrim Unblock) (mapMaybe unblockLine input) 
    8988        unblockLine (Line _ (ElementHide domains InputParser.Unblock pattern)) = (,) pattern <$> restrictionsTree Unblock domains 
    90         unblockLine _ = Nothing   
     89        unblockLine _ = Nothing 
    9190        blockLine (Line _ (ElementHide domains InputParser.Block pattern)) = (,) pattern <$> restrictionsTree Block domains 
    92         blockLine _ = Nothing   
    93          
     91        blockLine _ = Nothing 
     92 
    9493    appendTreePattern ::  Pattern -> PolicyTree -> BlockedRulesTree -> BlockedRulesTree 
    9594    appendTreePattern pattern policyTree 
     
    101100 
    102101    appendFlatPattern ::  Pattern -> PolicyTree -> [Pattern] -> [Pattern] 
    103     appendFlatPattern pattern policyTree patterns  
     102    appendFlatPattern pattern policyTree patterns 
    104103          | null (_children policyTree) && _value policyTree == Block  = pattern:patterns 
    105104          | otherwise                                                  = patterns 
    106  
  • adblock2privoxy/src/InputParser.hs

    rff7ee56 re2b555c  
    1 module InputParser (  
     1module InputParser ( 
    22Line (..), 
    33Restrictions (..), 
     
    2222import Text.Parsec.Permutation 
    2323import System.FilePath 
    24   
     24 
    2525-------------------------------------------------------------------------- 
    2626---------------------------- data model  --------------------------------- 
    2727-------------------------------------------------------------------------- 
    2828 
    29 -- composite 
     29-- composite  
    3030data Line = Line RecordSource Record 
    3131        deriving (Show,Eq) 
    3232 
    33 data RecordSource = RecordSource { _position :: SourcePos, _rawRecord :: String } deriving (Show,Eq)   
    34 data Policy = Block | Unblock deriving (Show, Eq, Read, Ord)         
     33data RecordSource = RecordSource { _position :: SourcePos, _rawRecord :: String } deriving (Show,Eq) 
     34data Policy = Block | Unblock deriving (Show, Eq, Read, Ord) 
    3535data Record =   Error String | 
    36                 Comment String |  
    37                 ElementHide (Restrictions Domain) Policy Pattern |  
     36                Comment String | 
     37                ElementHide (Restrictions Domain) Policy Pattern | 
    3838                RequestBlock Policy Pattern RequestOptions 
    3939        deriving (Read,Show,Eq) 
    40                     
     40 
    4141data RequestType =  Script | Image | Stylesheet | Object | Xmlhttprequest | Popup | 
    4242                    ObjectSubrequest | Subdocument | Document | Other 
     
    4444 
    4545data RequestOptions = RequestOptions { 
    46                             _requestType :: Restrictions RequestType,  
    47                             _thirdParty  :: Maybe Bool,  
    48                             _domain      :: Restrictions Domain,  
     46                            _requestType :: Restrictions RequestType, 
     47                            _thirdParty  :: Maybe Bool, 
     48                            _domain      :: Restrictions Domain, 
    4949                            _matchCase   :: Bool, 
    5050                            _collapse    :: Maybe Bool, 
     
    5555        deriving (Read,Show,Eq) 
    5656 
    57 -- primitive  
     57-- primitive 
    5858type Pattern = String 
    5959type Domain = String 
     
    6868recordSourceText (RecordSource position rawRecord) 
    6969   = concat [rawRecord, " (", takeFileName $ sourceName position, ": ", show $ sourceLine position, ")"] 
    70     
     70 
    7171-------------------------------------------------------------------------- 
    7272---------------------------- parsers  ------------------------------------ 
    7373-------------------------------------------------------------------------- 
    7474 
    75 adblockFile :: Parser [Line]         
     75adblockFile :: Parser [Line] 
    7676adblockFile = header *> sepEndBy line (oneOf eol) 
    77     where  
     77    where 
    7878        header = string "[Adblock Plus " <* version <* string "]"  <* lineEnd 
    7979        version = join <$> sepBy (many1 digit) (char '.') 
    8080 
    8181 
    82 line :: Parser Line  
     82line :: Parser Line 
    8383line = do 
    84     position <- getPosition  
     84    position <- getPosition 
    8585    let text = lookAhead (manyTill anyChar lineEnd) 
    8686        sourcePosition = RecordSource position <$> text 
    87     Line <$> sourcePosition <*> choice (try <$> [comment, elementHide, match, unknown]) <?> "filtering rule"   
    88      
    89          
     87    Line <$> sourcePosition <*> choice (try <$> [comment, elementHide, match, unknown]) <?> "filtering rule" 
     88 
     89 
    9090 
    9191elementHide :: Parser Record 
     
    112112 
    113113requestOptions :: Parser RequestOptions 
    114 requestOptions = runPermParser $ RequestOptions  
    115                                     <$> (fixRestrictions <$> requestTypes)  
    116                                     <*> (getMaybeAll <$> requestOptionNorm "ThirdParty")  
     114requestOptions = runPermParser $ RequestOptions 
     115                                    <$> (fixRestrictions <$> requestTypes) 
     116                                    <*> (getMaybeAll <$> requestOptionNorm "ThirdParty") 
    117117                                    <*> (fixRestrictions <$> optionalDomain) 
    118118                                    <*> (getAllOrFalse <$> requestOptionNorm  "MatchCase") 
     
    120120                                    <*> (getAllOrFalse <$> requestOptionNorm "Donottrack") 
    121121                                    <*> (getAllOrFalse <$> requestOptionNorm "Elemhide") 
    122                                     <* manyPerm separator  
     122                                    <* manyPerm separator 
    123123                                    <*> unknownOption 
    124     where  
     124    where 
    125125        optionalDomain = optionPerm noRestrictions $ try domainOption 
    126126        requestTypes = Restrictions <$> (Just <$> manyPerm  (try requestTypeOption)) <*> manyPerm (try notRequestTypeOption) 
     
    129129        separator = try (lineSpaces *> char ',' <* lineSpaces) 
    130130        unknownOption = manyPerm $ try optionName 
    131          
     131 
    132132requestOption :: String -> Parser All 
    133133requestOption name = All <$> option True (char '~' *> return False) <* checkOptionName name 
    134                               
     134 
    135135 
    136136 
    137137requestTypeOption :: Parser RequestType 
    138 requestTypeOption =  do  t <- optionName  
     138requestTypeOption =  do  t <- optionName 
    139139                         case reads t of 
    140140                            [(result, "")] -> return result 
    141                             _ -> pzero <?> "request type"     
    142  
    143        
    144                      
     141                            _ -> pzero <?> "request type" 
     142 
     143 
     144 
    145145domainOption :: Parser (Restrictions Domain) 
    146146domainOption =  checkOptionName "Domain" *> lineSpaces *> char '=' *> lineSpaces *> domains '|' 
     
    157157checkOptionName name =  do t <- optionName 
    158158                           when (name /= t) (pzero <?> "option type") 
    159                      
     159 
    160160domain :: Parser Domain 
    161161domain = join <$> intersperse "." <$> parts 
    162             where  
    163             parts = sepBy1 domainPart (char '.')  
     162            where 
     163            parts = sepBy1 domainPart (char '.') 
    164164            domainPart = many1 (alphaNum <|> char '-') 
    165165 
    166166domains :: Char -> Parser (Restrictions Domain) 
    167167domains sep = fixRestrictions <$> runPermParser restrictions 
    168     where  
     168    where 
    169169        restrictions = Restrictions <$> (Just <$> manyPerm  (try domain)) <*> manyPerm  (try notDomain) <* manyPerm (try separator) 
    170170        separator = lineSpaces *> char sep <* lineSpaces 
    171171        notDomain = char '~' *> domain 
    172                                          
     172 
    173173--helpers 
    174174eol :: String 
     
    199199fixRestrictions :: (Eq a) => Restrictions a -> Restrictions a 
    200200fixRestrictions = deduplicate.allowAll 
    201         where  
     201        where 
    202202        allowAll (Restrictions (Just []) n) = Restrictions Nothing n 
    203203        allowAll a = a 
    204204        deduplicate (Restrictions (Just p) n) = Restrictions (Just $ nub p) (nub n) 
    205205        deduplicate a = a 
    206  
    207          
    208          
    209          
    210          
  • adblock2privoxy/src/Main.hs

    rf53c7cf re2b555c  
    55import Text.ParserCombinators.Parsec hiding (Line, many, optional) 
    66import Task 
    7 import Control.Applicative hiding (many) 
    87import SourceInfo as Source 
    98import ProgramOptions as Options 
    109import System.Environment 
    1110import Templates 
    12 import Data.Time.Clock  
     11import Data.Time.Clock 
    1312import Network.HTTP.Conduit 
    1413import Network.URI 
    15 import Data.Text.Lazy.Encoding 
    16 import Data.Text.Lazy (unpack) 
    17 import Network.Socket 
    1814import System.Directory 
    1915import System.IO 
    20 import Control.Monad  
     16import Network 
    2117 
    22  
    23    
    24 getResponse :: String -> IO String 
    25 getResponse url = do 
    26         putStrLn $ "load " ++ url ++ "..." 
    27         withSocketsDo $ unpack . decodeUtf8 <$> simpleHttp url 
    28          
    2918getFileContent :: String -> IO String 
    3019getFileContent url = do 
    31     handle <- openFile url ReadMode  
     20    handle <- openFile url ReadMode 
    3221    hSetEncoding handle utf8 
    3322    hGetContents handle 
    3423 
    3524processSources :: Options -> String -> [SourceInfo]-> IO () 
    36 processSources options taskFile sources = do  
    37         (parsed, sourceInfo) <- unzip <$> mapM parseSource sources    
    38         let parsed' = concat parsed  
     25processSources options taskFile sources = do 
     26        manager <- newManager tlsManagerSettings 
     27        (parsed, sourceInfo) <- unzip <$> mapM (parseSource manager) sources 
     28        let parsed' = concat parsed 
    3929            sourceInfoText = showInfo sourceInfo 
    4030            optionsText = logOptions options 
    41         createDirectoryIfMissing True $ _privoxyDir options                
     31        createDirectoryIfMissing True $ _privoxyDir options 
    4232        writeTask taskFile (sourceInfoText ++ optionsText) parsed' 
    4333        if null._cssDomain $ options 
     
    4737        writeTemplateFiles (_privoxyDir options) (_cssDomain options) 
    4838        putStrLn $ "Run 'adblock2privoxy -t " ++ taskFile ++ "' every 1-2 days to process data updates." 
    49         where  
    50         parseSource sourceInfo = do 
    51             let  
     39        where 
     40        parseSource manager sourceInfo = do 
     41            let 
    5242                url = _url sourceInfo 
    53                 loader = if isURI url then getResponse else getFileContent 
     43                loader = if isURI url then downloadHttp manager 5 else getFileContent 
    5444            putStrLn $ "process " ++ url 
    5545            text <- loader url 
     
    5747            let strictParse = text `seq` parse adblockFile url text 
    5848            case strictParse of 
    59                 Right parsed ->  
    60                         let sourceInfo' = updateInfo now parsed sourceInfo  
     49                Right parsed -> 
     50                        let sourceInfo' = updateInfo now parsed sourceInfo 
    6151                            url' = _url sourceInfo' 
    62                         in if url == url'      
     52                        in if url == url' 
    6353                           then return (parsed, sourceInfo') 
    64                            else parseSource sourceInfo' 
     54                           else parseSource manager sourceInfo' 
    6555                Left msg -> return ([], sourceInfo) <$ putStrLn $ show msg 
    6656 
    6757main::IO() 
    68 main =  do  
     58main =  do 
    6959        now <- getCurrentTime 
    7060        args <- getArgs 
     
    7363                fileExists <- doesFileExist taskFile 
    7464                if fileExists 
    75                         then do task <- readTask taskFile  
     65                        then do task <- readTask taskFile 
    7666                                return (fillFromLog options task, Just task) 
    77                         else return (options, Nothing)                         
    78         let  
     67                        else return (options, Nothing) 
     68        let 
    7969            action 
    8070                | printVersion = putStrLn versionText 
    81                 | not . null $ urls  
     71                | not . null $ urls 
    8272                   = processSources options' taskFile (makeInfo <$> urls) 
    8373                | otherwise = case task of 
    84                         Nothing -> writeError "no input specified"   
     74                        Nothing -> writeError "no input specified" 
    8575                        (Just task') -> do 
    8676                                let sources = Source.readLogInfos task' 
    87                                 if forced || or (infoExpired now <$> sources)                                 
     77                                if forced || or (infoExpired now <$> sources) 
    8878                                        then processSources options' taskFile sources 
    8979                                        else putStrLn "all sources are up to date" 
    90                              
     80 
    9181        action 
    9282        now' <- getCurrentTime 
    9383        putStrLn $ concat ["Execution done in ", show $ diffUTCTime now' now, " seconds."] 
    94  
  • adblock2privoxy/src/OptionsConverter.hs

    r6bfb8d3 re2b555c  
    77) where 
    88import InputParser 
    9 import Control.Applicative 
    109import Control.Monad 
    1110import Data.List 
    12 import Data.Monoid hiding (Any) 
    1311import Data.Maybe 
    1412import Data.String.Utils (replace) 
    15 import {-# SOURCE #-}  UrlBlocker  
     13import {-# SOURCE #-}  UrlBlocker 
    1614 
    1715type FilterFabrique = Policy -> RequestOptions -> HeaderPolicy 
    1816data HeaderType = HeaderType {_name :: String, _taggerType :: TaggerType, _level :: Int, 
    1917                              _typeCode :: Char, _fabrique :: FilterFabrique} 
    20 data Filter = Filter { _code :: String, _regex :: String, _orEmpty :: Bool } deriving Eq   
    21 data HeaderPolicy = Specific Filter | Any | None deriving Eq   
    22 data HeaderFilter = HeaderFilter HeaderType Filter            
     18data Filter = Filter { _code :: String, _regex :: String, _orEmpty :: Bool } deriving Eq 
     19data HeaderPolicy = Specific Filter | Any | None deriving Eq 
     20data HeaderFilter = HeaderFilter HeaderType Filter 
    2321type HeaderFilters = [[HeaderFilter]] 
    2422 
     
    3634headerFilters _ 0 _ = Just [] 
    3735headerFilters policy level requestOptions@RequestOptions{_requestType = requestType} 
    38     = let requestOptions' = requestOptions{_requestType = convertPopup $ convertOther requestType}  
    39       in do  
     36    = let requestOptions' = requestOptions{_requestType = convertPopup $ convertOther requestType} 
     37      in do 
    4038         nextLevel <- headerFilters policy (level - 1) requestOptions' 
    4139         let 
    42             passthrough = checkPassthrough requestOptions'   
     40            passthrough = checkPassthrough requestOptions' 
    4341            filters = do 
    4442                       headerType <- allTypes 
    4543                       guard (_level headerType == level) 
    46                        case (_fabrique headerType) policy requestOptions' of 
     44                       case _fabrique headerType policy requestOptions' of 
    4745                          Specific filter' -> return $ Just $ HeaderFilter headerType filter' 
    4846                          None -> return Nothing 
     
    5553convertPopup :: Restrictions RequestType -> Restrictions RequestType 
    5654convertPopup (Restrictions positive negative)= Restrictions positive' negative 
    57     where  
     55    where 
    5856    positiveContentTypes = fromMaybe [] positive >>= contentTypes True 
    5957    positive' | Popup `elem` negative && null positiveContentTypes = Nothing 
    60               | otherwise                                          = positive  
     58              | otherwise                                          = positive 
    6159 
    6260convertOther :: Restrictions RequestType -> Restrictions RequestType 
    6361convertOther (Restrictions positive negative)= Restrictions positive' negative' 
    64     where  
     62    where 
    6563    allContentOptions = [Script, Image, Stylesheet, Object, ObjectSubrequest, Document] 
    6664    positiveList = fromMaybe [] positive 
    6765    negative' | Other `elem` positiveList = allContentOptions \\ positiveList 
    6866              | otherwise                 = negative 
    69     positive' | Other `elem` negative     = Just $ allContentOptions \\ negative'  
     67    positive' | Other `elem` negative     = Just $ allContentOptions \\ negative' 
    7068              | positive == Just [Other]  = Nothing 
    7169              | otherwise                 = positive 
    72      
     70 
    7371checkPassthrough :: RequestOptions -> Bool 
    7472checkPassthrough RequestOptions {_requestType = (Restrictions positive _) } 
    75     = fromMaybe False $ (not . null . intersect [Subdocument, Popup]) <$> positive  
    76   
     73    = fromMaybe False $ (not . null . intersect [Subdocument, Popup]) <$> positive 
     74 
    7775acceptFilter, contentTypeFilter, requestedWithFilter, refererFilter :: FilterFabrique 
    7876 
    7977contentTypeFilter  policy (RequestOptions (Restrictions positive negative) thirdParty _ _ _ _ _ _) 
    80     | fromMaybe True emptyPositive && (not $ isNothing positive) = None 
    81     | result == mempty = Any  
     78    | fromMaybe True emptyPositive && isJust positive = None 
     79    | result == mempty = Any 
    8280    | otherwise = Specific $ Filter code regex orEmpty 
    83     where  
     81    where 
    8482    negative' | isNothing positive && fromMaybe False thirdParty = Document : negative 
    85               | otherwise                  = negative    
     83              | otherwise                  = negative 
    8684    negativePart = mappend ("n", "") <$> convert False negative' 
    8785    positivePart = positive >>= convert True 
    8886    result@(code, regex) = mconcat $ catMaybes [positivePart, negativePart] 
    8987    orEmpty = (policy == Unblock) && isNothing positive 
    90     emptyPositive = null . filter (`notElem` (fromMaybe "" $ fst <$> negativePart)) . fst <$> positivePart 
    91     
     88    emptyPositive = not . any (`notElem` (fromMaybe "" $ fst <$> negativePart)) . fst <$> positivePart 
     89 
    9290    convert  _      []                        = Nothing 
    9391    convert include requestTypes | null code' = Nothing 
     
    9694                code' = sort $ (head . dropWhile (`elem` "/(?:x-)")) <$> contentTypes' 
    9795                regex' = lookahead contentTypes' "[\\s\\w]*" include 
    98      
     96 
    9997acceptFilter excludePattern options = case contentTypeFilter excludePattern options of 
    10098                                            Specific res -> Specific res {_orEmpty = False} 
    10199                                            other      -> other 
    102                               
    103                                          
     100 
     101 
    104102requestedWithFilter _ RequestOptions{ _requestType = Restrictions positive negative } = 
    105103        case result of 
     
    111109    result | Xmlhttprequest `elem` negative                                  = Just False 
    112110           | Xmlhttprequest `elem` fromMaybe [] positive                     = Just True 
    113            |                           (hasContentTypes False    negative)  
    114              && (fromMaybe True $ not . hasContentTypes True <$> positive)   = Just True 
     111           | hasContentTypes False negative 
     112             && fromMaybe True (not . hasContentTypes True <$> positive)   = Just True 
    115113           | otherwise                                                       = Nothing 
    116114    hasContentTypes include = not . all null . fmap (contentTypes include) 
     
    119117refererFilter policy RequestOptions{ _thirdParty = thirdParty, _domain = Restrictions positive negative } 
    120118    | fromMaybe False emptyPositive  = None 
    121     | result == mempty = Any  
     119    | result == mempty = Any 
    122120    | otherwise = Specific $ Filter code regex orEmpty 
    123121    where 
    124122    negativePart = mappend ("n", "") <$> convert False negative 
    125123    positivePart = positive >>= convert True 
    126     thirdPartyPart tp = (if tp then "t" else "nt",  
    127                          concat ["(?", lookAheadPolicy $ not tp,  
     124    thirdPartyPart tp = (if tp then "t" else "nt", 
     125                         concat ["(?", lookAheadPolicy $ not tp, 
    128126                                 ":\\s*(?:https?:\\/\\/)?(?:[\\w.-]*\\.)?([\\w-]+\\.[\\w-]+)[^\\w.-].*\\1$)", 
    129127                                 "\ns@^referer:.*@$&\\t$host@Di"]) 
    130     result@(code, regex) = mconcat $ catMaybes [positivePart, negativePart, thirdPartyPart <$> thirdParty]     
    131     emptyPositive = null . filter (`notElem` negative) <$> positive 
    132     orEmpty =  (policy == Unblock) && (isNothing positive || (not $ fromMaybe True thirdParty)) 
     128    result@(code, regex) = mconcat $ catMaybes [positivePart, negativePart, thirdPartyPart <$> thirdParty] 
     129    emptyPositive = not . any (`notElem` negative) <$> positive 
     130    orEmpty =  (policy == Unblock) && (isNothing positive || not (fromMaybe True thirdParty)) 
    133131    convert _ [] = Nothing 
    134132    convert include domains = let 
     
    137135        in Just ("[" ++ code' ++ "]", regex') 
    138136 
    139 lookAheadPolicy :: Bool -> [Char] 
    140 lookAheadPolicy True = "="     
    141 lookAheadPolicy False = "!"            
    142      
    143 lookahead :: [String] -> String -> Bool -> String     
    144 lookahead list prefix include = join ["(?", lookAheadPolicy include,  
     137lookAheadPolicy :: Bool -> String 
     138lookAheadPolicy True = "=" 
     139lookAheadPolicy False = "!" 
     140 
     141lookahead :: [String] -> String -> Bool -> String 
     142lookahead list prefix include = join ["(?", lookAheadPolicy include, 
    145143                  ":", prefix ,"(?:", intercalate "|" $ excapeRx <$> list, "))"] 
    146144                  where 
    147                   excapeRx = replace "/" "\\/" . replace "." "\\."                           
    148                                          
     145                  excapeRx = replace "/" "\\/" . replace "." "\\." 
     146 
    149147contentTypes :: Bool -> RequestType -> [String] 
    150148contentTypes _ Script = ["/(?:x-)?javascript"] 
     
    155153contentTypes _ Document = ["/html", "/xml"] 
    156154contentTypes False Subdocument = ["/html", "/xml"] 
    157 contentTypes _ _ = []   
    158                    
     155contentTypes _ _ = [] 
  • adblock2privoxy/src/ParsecExt.hs

    rff7ee56 re2b555c  
    1212import Control.Applicative hiding (many) 
    1313import Text.ParserCombinators.Parsec hiding ((<|>),State) 
    14 import Control.Monad.Trans  
     14import Control.Monad.Trans 
    1515import Control.Monad.RWS 
    1616import Control.Monad.State 
    1717import Data.Maybe 
    18          
    19 -- parser should consume some input to prevent infinite loop  
     18 
     19-- parser should consume some input to prevent infinite loop 
    2020manyCases :: (Monoid a, Monoid st) => Parser a -> StateParser st a 
    2121manyCases p = do    acc <- get 
    2222                    put  $ Just mempty 
    23                     lift $ if isNothing acc  
    24                               then return mempty  
     23                    lift $ if isNothing acc 
     24                              then return mempty 
    2525                              else p 
    26                          
     26 
    2727oneCase :: (Monoid a, Monoid st) => Parser a -> StateParser st a 
    2828oneCase p = do  acc <- get 
    2929                put  $ Just mempty 
    30                 lift $ if isNothing acc  
     30                lift $ if isNothing acc 
    3131                          then p 
    3232                          else pzero 
     
    4747                    input <- lift getInput 
    4848                    let boxedParser = (mapRWST.mapStateT) lookAhead $ casesParser mempty parsers 
    49                     (input', res) <- execRWST boxedParser () input   
     49                    (input', res) <- execRWST boxedParser () input 
    5050                    lift (setInput input') 
    5151                    return res 
    52                   
    53                                          
     52 
     53 
    5454casesParser :: forall r st.(Monoid r) => r -> [StateParser st r] -> CasesParser st r () 
    5555casesParser _ []                         = error "Empty parser list is not accepted" 
    5656casesParser acc parsers@(parser:next) = do 
    5757        maybeRes <- lift (optionMaybeTry parser) 
    58         case maybeRes of  
     58        case maybeRes of 
    5959            Nothing -> return () 
    6060            Just res -> do 
    6161                input <- lift.lift $ getInput 
    6262                let acc' = acc <> res 
    63                 if null input || null next  
     63                if null input || null next 
    6464                        then do 
    6565                            modify (minList input) -- TODO: somehow use processed length to select min input 
    6666                            tell [acc'] 
    67                         else do  
     67                        else do 
    6868                            st <- lift get 
    6969                            lift (put Nothing) 
    7070                            (mapRWST.mapStateT) lookAhead $ casesParser acc' next 
    7171                            lift (put st) 
    72                 unless (null input) $ casesParser acc' parsers                                       
    73                                          
     72                unless (null input) $ casesParser acc' parsers 
     73 
    7474------------------------------------------------------------------------------------------------ 
  • adblock2privoxy/src/ParserExtTests.hs

    r6bfb8d3 re2b555c  
    2424            prefix = manyCases ((:[]) <$> (string "ab" <|> string "zz")) 
    2525            mid =    many1Cases $ (:[]) <$> letter            -- list of letters 
    26             suffix = many1Cases $ try $ many1 alphaNum   
    27              
     26            suffix = many1Cases $ try $ many1 alphaNum 
     27 
    2828 
    2929testParsecExt :: Either ParseError [([String], String, String)] 
     
    3838 
    3939morseChars :: [(String, Char)] 
    40 morseChars = [  (".-", 'A'),  
     40morseChars = [  (".-", 'A'), 
    4141                ("-...", 'B'), 
    42                 ("-.-.", 'C'),  
     42                ("-.-.", 'C'), 
    4343                ("-..", 'D'), 
    44                 (".", 'E'),    
     44                (".", 'E'), 
    4545                ("..-.", 'F'), 
    46                 ("--.", 'G'),  
     46                ("--.", 'G'), 
    4747                ("....", 'H'), 
    48                 ("..", 'I'),   
     48                ("..", 'I'), 
    4949                (".---", 'J'), 
    50                 ("-.-", 'K'),  
     50                ("-.-", 'K'), 
    5151                (".-..", 'L'), 
    52                 ("--", 'M'),   
     52                ("--", 'M'), 
    5353                ("-.", 'N'), 
    54                 ("---", 'O'),  
     54                ("---", 'O'), 
    5555                (".--.", 'P'), 
    56                 ("--.-", 'Q'),     
     56                ("--.-", 'Q'), 
    5757                (".-.", 'R'), 
    58                 ("...", 'S'),  
     58                ("...", 'S'), 
    5959                ("-", 'T'), 
    60                 ("..-", 'U'),  
     60                ("..-", 'U'), 
    6161                ("...-", 'V'), 
    62                 (".--", 'W'),  
     62                (".--", 'W'), 
    6363                ("-..-", 'X'), 
    64                 ("-.--", 'Y'),     
     64                ("-.--", 'Y'), 
    6565                ("--..", 'Z'), 
    66                 ("-----", '0'),    
     66                ("-----", '0'), 
    6767                (".----", '1'), 
    68                 ("..---", '2'),    
     68                ("..---", '2'), 
    6969                ("...--", '3'), 
    70                 ("....-", '4'),    
     70                ("....-", '4'), 
    7171                (".....", '5'), 
    72                 ("-....", '6'),    
     72                ("-....", '6'), 
    7373                ("--...", '7'), 
    74                 ("---..", '8'),    
     74                ("---..", '8'), 
    7575                ("----.", '9')] 
    7676 
     
    8282encodeMorse s = join $ fst <$> catMaybes (code <$> s) 
    8383        where code c = find (\pair -> snd pair == c) morseChars 
    84          
     84 
    8585decodeMorse :: [String] -> String 
    8686decodeMorse ss = snd <$> catMaybes (code <$> ss) 
    87         where code s = find (\pair -> fst pair == s) morseChars  
     87        where code s = find (\pair -> fst pair == s) morseChars 
    8888 
    8989 
     
    9191findMorseSteps :: String -> [String] -> [String] 
    9292findMorseSteps prefix codes = case find (== prefix) codes of 
    93                             Nothing -> case filter (isPrefixOf prefix) codes of  
     93                            Nothing -> case filter (isPrefixOf prefix) codes of 
    9494                                            [] -> [] 
    9595                                            filtered ->    findMorseSteps (prefix ++ ".") filtered 
     
    107107                             candidates = filter (\x -> isPrefixOf acc x && acc /= x) morseCharCodes 
    108108                             steps = drop (length acc) <$> findMorseSteps acc candidates 
    109                              parser = morseStepParser steps     
     109                             parser = morseStepParser steps 
    110110                         res <- lift parser 
    111111                         put (Just $ acc ++ res) 
    112112                         return (zipListM $ replicate pos "" ++ (res : repeat "")) 
    113                    
     113 
    114114 
    115115morseParsers :: [StringStateParser (ZipListM String)] 
     
    118118parseMorse :: String -> Either ParseError [String] 
    119119parseMorse s = (fmap.fmap) postProcess $ parseMorseRaw "x" s 
    120             where  
    121             parseMorseRaw =  parse (cases morseParsers)  
    122             postProcess = decodeMorse.toLists  
    123             toLists = takeWhile (not . null) . getZipListM  
    124              
     120            where 
     121            parseMorseRaw =  parse (cases morseParsers) 
     122            postProcess = decodeMorse.toLists 
     123            toLists = takeWhile (not . null) . getZipListM 
  • adblock2privoxy/src/PatternConverter.hs

    rff7ee56 re2b555c  
    1414import Utils 
    1515 
    16 data SideBind = Hard | Soft | None deriving (Show, Eq)  
     16data SideBind = Hard | Soft | None deriving (Show, Eq) 
    1717 
    18 data UrlPattern = UrlPattern {  
     18data UrlPattern = UrlPattern { 
    1919                   _bindStart :: SideBind, 
    2020                   _proto :: String, 
     
    2626 
    2727makePattern :: Bool -> UrlPattern -> Pattern 
    28 makePattern matchCase (UrlPattern bindStart proto host query bindEnd isRegex)  
    29             | query' == "" = host'  
    30             | otherwise    = host' ++ separator' ++ query'  
    31     where  
    32         separator'  
     28makePattern matchCase (UrlPattern bindStart proto host query bindEnd isRegex) 
     29            | query' == "" = host' 
     30            | otherwise    = host' ++ separator' ++ query' 
     31    where 
     32        separator' 
    3333            | matchCase = "/(?-i)" 
    3434            | otherwise = "/" 
     
    3838                    where 
    3939                    changeLast []     = [] 
    40                     changeLast [lst]   
    41                         | lst == '|' || lst `elem` hostSeparators   =  []       
     40                    changeLast [lst] 
     41                        | lst == '|' || lst `elem` hostSeparators   =  [] 
    4242                        | lst == '*' || lst == '\0'                 =  "*." 
    4343                        | otherwise                                 =  lst : "*." 
    4444                    changeLast (c:cs) = c : changeLast cs 
    45   
     45 
    4646                    changeFirst []    = [] 
    47                     changeFirst (first:cs)  
     47                    changeFirst (first:cs) 
    4848                        | first == '*'                       =       '.' :  '*'  : cs 
    4949                        | bindStart == Hard || proto /= ""   =             first : cs 
    50                         | bindStart == Soft                  =       '.' : first : cs       
     50                        | bindStart == Soft                  =       '.' : first : cs 
    5151                        | otherwise                          = '.' : '*' : first : cs 
    52                                      
     52 
    5353        query' = case query of 
    5454                    ""     -> "" 
    55                     (start:other) ->  
     55                    (start:other) -> 
    5656                              if isRegex then query 
    5757                              else case query of 
    5858                                '*' : '/' : other' -> replaceQuery '/' other' True 
    59                                 '*' : '^' : other' -> replaceQuery '^' other' True   
    60                                 _                  -> replaceQuery start other (bindStart == None && host == "")    
     59                                '*' : '^' : other' -> replaceQuery '^' other' True 
     60                                _                  -> replaceQuery start other (bindStart == None && host == "") 
    6161                              where 
    62                                 replaceQuery c cs openStart = replaceFirst c openStart ++ (join . map replaceWildcard $ cs) ++ queryEnd                   
     62                                replaceQuery c cs openStart = replaceFirst c openStart ++ (join . map replaceWildcard $ cs) ++ queryEnd 
    6363                                replaceFirst '*' _ = ".*" 
    6464                                replaceFirst c openStart 
     
    6666                                                             then "(.*" ++ replaceWildcard c ++ ")?" 
    6767                                                             else "" 
    68                                     | otherwise            = if openStart  
     68                                    | otherwise            = if openStart 
    6969                                                             then ".*" ++ replaceWildcard c 
    7070                                                             else replaceWildcard c 
    71                                  
     71 
    7272                                queryEnd = if bindEnd == None then "" else "$" 
    73                                                                    
     73 
    7474                                replaceWildcard c 
    7575                                    | c == '^'         = "[^\\w%.-]" 
     
    7878                                    | otherwise        = [c] 
    7979                                    where special = "?$.+[]{}()\\|" -- also ^ and * are special 
    80                       
     80 
    8181 
    8282hostSeparators :: String 
     
    8484 
    8585parseUrl :: Pattern -> Either ParseError [UrlPattern] 
    86 parseUrl =   
     86parseUrl = 
    8787    let  raw = makeUrls <$> bindStart <*> cases urlParts <*> bindEnd 
    8888    in   parse (join <$> (fmap.fmap) postfilter raw) "url" 
     
    9090        makeUrls start mid end = makeUrl <$> pure start <*> mid <*> pure end 
    9191        makeUrl start (proto, host, query) end = UrlPattern start proto host query end False 
    92          
    93         bindStart = (try (Soft <$ string "||") <|> try (Hard <$ string "|") <|> return None) <?> "query start"  
     92 
     93        bindStart = (try (Soft <$ string "||") <|> try (Hard <$ string "|") <|> return None) <?> "query start" 
    9494        queryEnd = (char '|' <* eof) <|> ('\0' <$ eof) <|> char '\0' <?> "query end" 
    9595        bindEnd = (\c -> if c == '|' then Hard else None) <$> queryEnd 
    9696        port = option False $ many1 (noneOf ":") *> char ':' *> many1 (digit <|> char '*') *> optionMaybe (oneOf "/^") *> (True <$ queryEnd) 
    97          
     97 
    9898        hostChar :: Parser Char 
    9999        hostChar = alphaNum <|> oneOf ".-:" 
    100          
     100 
    101101        protocols :: [String] 
    102102        protocols = ["https://", "http://"] 
    103          
     103 
    104104        protocolsSeparator :: String 
    105105        protocolsSeparator = ";" 
    106          
     106 
    107107        protocolChar :: Parser Char 
    108108        protocolChar = oneOf (delete '/' $ nub $ join protocols) 
    109          
     109 
    110110        postfilter :: UrlPattern -> [UrlPattern] 
    111111        postfilter url@(UrlPattern bs proto host query be _) = regular ++ regex -- ++ www 
    112             where  
    113                 regex = if     proto == ""  
    114                             && host == ""  
    115                             && "/" `isPrefixOf` query  
     112            where 
     113                regex = if     proto == "" 
     114                            && host == "" 
     115                            && "/" `isPrefixOf` query 
    116116                            && length query > 2 
    117                             && "/" `isSuffixOf` query  
    118                             then  
     117                            && "/" `isSuffixOf` query 
     118                            then 
    119119                                let query' = take (length query - 2) . drop 1 $ query 
    120                                 in [UrlPattern bs "" "" query' be True]  
     120                                in [UrlPattern bs "" "" query' be True] 
    121121                            else [] 
    122                 regular = let  
     122                regular = let 
    123123                             leftBound = bs /= None || proto /= "" 
    124124                             rightBound = be /= None || query /= "" 
     
    126126                             duplicateHostStar = host == "*" 
    127127                             hostHasDot = isJust $ find (\c -> c == '.' || c == '*') host 
    128                              firstLevelHost = host /= "" && not hostHasDot && leftBound && rightBound  
     128                             firstLevelHost = host /= "" && not hostHasDot && leftBound && rightBound 
    129129                             hasLegalPort = case parse port "host" host of 
    130130                                                Right val -> val 
    131                                                 _ -> False   
     131                                                _ -> False 
    132132                             hasIllegalPort = not hasLegalPort && ":" `isInfixOf` host 
    133                           in if not (orphanQuery || duplicateHostStar || firstLevelHost || hasIllegalPort)  
     133                          in if not (orphanQuery || duplicateHostStar || firstLevelHost || hasIllegalPort) 
    134134                             then 
    135135                                let 
    136                                     query' = if "*" `isSuffixOf` host && query /= "" then '*' : query else query  
    137                                 in [url {_query = query'}]  
     136                                    query' = if "*" `isSuffixOf` host && query /= "" then '*' : query else query 
     137                                in [url {_query = query'}] 
    138138                             else [] 
    139139 
    140         -- TODO: process port as an url part  
     140        -- TODO: process port as an url part 
    141141        urlParts :: [StringStateParser (String,String,String)] 
    142142        urlParts = square3 proto (manyCases host) (oneCase query) 
    143             where           
     143            where 
    144144                append xs x = xs ++ [x] 
    145145                proto :: StringStateParser String 
    146146                proto = do 
    147147                        masksString <- get 
    148                         case masksString of  
    149                             Nothing ->  
     148                        case masksString of 
     149                            Nothing -> 
    150150                                do 
    151151                                put $ Just $ intercalate protocolsSeparator protocols 
    152152                                return "" --allow to skip proto 
    153                             Just masksString' ->  
     153                            Just masksString' -> 
    154154                                do 
    155155                                let masks = split protocolsSeparator masksString' 
    156                                 if null masks  
     156                                if null masks 
    157157                                    then lift pzero -- no continuations available (parser have finished on previous iteration) 
    158                                     else  
     158                                    else 
    159159                                        do 
    160160                                        lift $ skipMany $ char '*' --skip leading * if presented 
     
    170170                                                put $ Just $ if isJust (find null masks')  -- if empty continuation found (i.e. parser finished) 
    171171                                                                then "" -- make no continuations available next time 
    172                                                                 else intercalate protocolsSeparator masks'   
     172                                                                else intercalate protocolsSeparator masks' 
    173173                                                return $ if nextChar == '*' then chars ++ "*" else chars 
    174174                host = try (append <$> many hostChar <*> char '*') <|> 
     
    176176                separator = (oneOf hostSeparators <|> queryEnd) <?> "separator" 
    177177                query = notFollowedBy (try $ string "//") *> manyTill anyChar (lookAhead (try queryEnd)) <?> "query" 
    178                  
     178 
    179179                filterProtoMasks :: [String] -> String -> Char -> [String] 
    180180                filterProtoMasks masks chars nextChar = mapMaybe filterProtoMask masks 
    181                     where filterProtoMask mask = if nextChar /= '*'  
     181                    where filterProtoMask mask = if nextChar /= '*' 
    182182                                    then if chars `isSuffixOf` mask 
    183183                                         then Just "" 
    184                                          else Nothing  
     184                                         else Nothing 
    185185                                    else let tailFound = find (chars `isPrefixOf`) (tails mask) 
    186                                          in drop (length chars) <$> tailFound  
    187                  
     186                                         in drop (length chars) <$> tailFound 
  • adblock2privoxy/src/PolicyTree.hs

    rff7ee56 re2b555c  
    1212,domainTree 
    1313) where 
    14 import Control.Applicative 
     14--import Control.Applicative 
    1515import InputParser hiding (Policy(..)) 
    1616import Data.String.Utils (split) 
     
    2222 
    2323showTree :: Show a => Int -> DomainTree a -> String 
    24 showTree lvl (Node name value children)  
    25     = concat $   
     24showTree lvl (Node name value children) 
     25    = concat $ 
    2626        [replicate (lvl * 2) ' ', "\"", name, "\" - ", show value] 
    27         ++ (('\n':) <$> showTree (lvl + 1) <$> children) 
     27        ++ (('\n':) . showTree (lvl + 1) <$> children) 
    2828 
    2929instance Show a => Show (DomainTree a) where 
     
    3535    negativePolicy = case positivePolicy of 
    3636                        Block -> Unblock 
    37                         _     -> Block   
     37                        _     -> Block 
    3838    positiveTree = case p of 
    3939                        Nothing -> Just $ Node "" positivePolicy [] 
     
    6060mergeAndTrim :: NodePolicy -> PolicyTree -> PolicyTree -> PolicyTree 
    6161mergeAndTrim trump = trimTree trump .*. mergePolicyTrees trump 
    62   
     62 
    6363concatTrees :: NodePolicy -> [PolicyTree] -> Maybe PolicyTree 
    6464concatTrees _ [] = Nothing 
     
    6767 
    6868mergePolicyTrees :: NodePolicy -> PolicyTree -> PolicyTree -> PolicyTree 
    69 mergePolicyTrees trump = mergeTrees mergePolicy  
     69mergePolicyTrees trump = mergeTrees mergePolicy 
    7070    where 
    7171    mergePolicy policy1 policy2 
     
    8080        where 
    8181        -- names expected to be equal and/or empty 
    82         mergeName  
     82        mergeName 
    8383            | name1 == ""     = name2 
    8484            | otherwise       = name1 
    85          
    86         t1Default = t1{_name = "", _children = []}     
    87         t2Default = t2{_name = "", _children = []}     
    88          
     85 
     86        t1Default = t1{_name = "", _children = []} 
     87        t2Default = t2{_name = "", _children = []} 
     88 
    8989        mergeChildren [] [] = [] 
    9090        mergeChildren (t1Child:t1Children') [] = mergeTrees mergeValue t1Child   t2Default : mergeChildren t1Children' [] 
    9191        mergeChildren [] (t2Child:t2Children') = mergeTrees mergeValue t1Default t2Child   : mergeChildren []          t2Children' 
    92         mergeChildren t1Children@(t1Child:t1Children') t2Children@(t2Child:t2Children')  
     92        mergeChildren t1Children@(t1Child:t1Children') t2Children@(t2Child:t2Children') 
    9393            | _name t1Child == _name t2Child   = mergeTrees mergeValue t1Child   t2Child   : mergeChildren t1Children' t2Children' 
    9494            | _name t1Child >  _name t2Child   = mergeTrees mergeValue t1Child   t2Default : mergeChildren t1Children' t2Children 
    9595            | otherwise                        = mergeTrees mergeValue t1Default t2Child   : mergeChildren t1Children  t2Children' 
    96      
     96 
    9797 
    9898trimTree :: NodePolicy -> PolicyTree -> PolicyTree 
    9999trimTree trump (Node name policy children) = Node name policy childrenFiltered 
    100     where   
     100    where 
    101101    childrenFiltered = filter (not.redundantChild) childrenTrimmed 
    102102    childrenTrimmed = trimTree trump <$> children 
    103103    redundantChild (Node _ childPolicy childChildren) = samePolicy childPolicy && null childChildren 
    104     samePolicy childPolicy = childPolicy == policy || (policy == None && childPolicy /= trump)   
    105      
    106      
    107  
    108  
    109  
    110  
    111  
     104    samePolicy childPolicy = childPolicy == policy || (policy == None && childPolicy /= trump) 
  • adblock2privoxy/src/PopupBlocker.hs

    r6bfb8d3 re2b555c  
    11module PopupBlocker where 
    2  
  • adblock2privoxy/src/ProgramOptions.hs

    rff7ee56 re2b555c  
    2222     , _webDir      :: FilePath 
    2323     , _taskFile    :: FilePath 
    24      , _cssDomain   :: String  
     24     , _cssDomain   :: String 
    2525     , _forced      :: Bool 
    2626     } 
     
    5353 
    5454parseOptions :: [String] -> IO (Options, [String]) 
    55 parseOptions argv =  
     55parseOptions argv = 
    5656   case getOpt Permute options argv of 
    57       (opts,nonOpts,[]  ) ->  
     57      (opts,nonOpts,[]  ) -> 
    5858                case foldl (flip id) emptyOptions opts of 
    5959                        Options False "" _ "" _ _ -> writeError "Privoxy dir or task file should be specified.\n" 
     
    6464        setDefaults opts@(Options _ (privoxyDir@(_:_)) "" _ _ _) = setDefaults opts{ _webDir = privoxyDir } 
    6565        setDefaults opts@(Options _ privoxyDir _ "" _ _) = setDefaults opts{ _taskFile = privoxyDir </> "ab2p.task" } 
    66         setDefaults opts = opts   
     66        setDefaults opts = opts 
    6767 
    68 versionText :: String  
     68versionText :: String 
    6969versionText = "adblock2privoxy version " ++ showVersion version 
    7070 
    7171writeError :: String -> IO a 
    7272writeError msg = ioError $ userError $ msg ++ "\n" ++ usageInfo header options 
    73         where          
     73        where 
    7474        header = versionText ++ 
    7575                "\nSee home page for more details and updates: http://projects.zubr.me/wiki/adblock2privoxy\n" ++ 
     
    7777 
    7878 
    79 logOptions :: Options -> [String]  
     79logOptions :: Options -> [String] 
    8080logOptions options' = [ 
    8181        startMark, 
     
    9595emptyOptions = Options False "" "" "" "" False 
    9696 
    97          
     97 
    9898fillFromLog :: Options -> [String] -> Options 
    9999fillFromLog existing lns = execState (sequence $ parseLogOptions <$> lns') existing 
    100    where  
     100   where 
    101101   lns' = filter (not.null) $ takeWhile (/= endMark).dropWhile (/= startMark) $ lns 
    102102 
     
    104104parseLogOptions text = do 
    105105    info <- get 
    106     let  
    107         ifEmpty getter x =  
     106    let 
     107        ifEmpty getter x = 
    108108                let oldValue = getter info in 
    109                 if null oldValue then x else oldValue  
     109                if null oldValue then x else oldValue 
    110110        privoxyPathParser = (\x -> info{_privoxyDir = ifEmpty _privoxyDir x}) <$> (string "Privoxy path: " *> many1 anyChar) 
    111111        webPathParser = (\x -> info{_webDir = ifEmpty _webDir x}) <$> (string "Web path: " *> many1 anyChar) 
    112112        cssDomainParser = (\x -> info{_cssDomain = ifEmpty _cssDomain x}) <$> (string "CSS web server domain: " *> many1 anyChar) 
    113         stringParser = skipMany (char ' ') *>  
     113        stringParser = skipMany (char ' ') *> 
    114114            (try privoxyPathParser <|> try webPathParser <|> cssDomainParser) 
    115115    case parse stringParser "" text of 
    116116        Left _ -> return () 
    117         Right info' -> put info'  
    118     
     117        Right info' -> put info' 
  • adblock2privoxy/src/SourceInfo.hs

    rff7ee56 re2b555c  
    1313import Text.ParserCombinators.Parsec hiding ((<|>),State,Line) 
    1414import Data.Time.Clock 
    15 import Data.Time.Calendar  
    16 import System.Locale 
     15import Data.Time.Calendar 
     16--import System.Locale 
    1717import Data.Time.Format 
    1818import Data.Maybe (catMaybes) 
     
    2020 
    2121 
    22 data SourceInfo = SourceInfo { _title, _url, _license, _homepage :: String,  
     22data SourceInfo = SourceInfo { _title, _url, _license, _homepage :: String, 
    2323                               _lastUpdated :: UTCTime, _expires, _version :: Integer, _expired :: Bool } 
    2424 
     
    3232endMark = "------- end ------" 
    3333 
    34 showInfo :: [SourceInfo] -> [String]  
     34showInfo :: [SourceInfo] -> [String] 
    3535showInfo sourceInfos = (sourceInfos >>= showInfoItem) ++ [endMark ++ "\n"] 
    3636 
    37 showInfoItem :: SourceInfo -> [String]  
    38 showInfoItem sourceInfo@(SourceInfo _ url _ _ lastUpdated expires _ expired) =  
     37showInfoItem :: SourceInfo -> [String] 
     38showInfoItem sourceInfo@(SourceInfo _ url _ _ lastUpdated expires _ expired) = 
    3939        catMaybes [ Just separator, 
    4040                    optionalLine "Title: " _title, 
    4141                    Just $ "Url: " ++ url, 
    4242                    Just $ "Last modified: " ++ formatTime defaultTimeLocale "%d %b %Y %H:%M %Z" lastUpdated, 
    43                     Just $ concat ["Expires: ", show expires, " hours", expiredMark],  
     43                    Just $ concat ["Expires: ", show expires, " hours", expiredMark], 
    4444                    optionalLine "Version: " $ show . _version, 
    4545                    optionalLine "License: " _license, 
    4646                    optionalLine "Homepage: " _homepage ] 
    47     where  
     47    where 
    4848    expiredMark | expired = " (expired)" 
    4949                | otherwise = "" 
    5050    optionalLine caption getter | getter sourceInfo == getter emptySourceInfo = Nothing 
    51                                 | otherwise = Just $ caption ++ getter sourceInfo  
     51                                | otherwise = Just $ caption ++ getter sourceInfo 
    5252 
    5353updateInfo :: UTCTime -> [Line] -> SourceInfo -> SourceInfo 
    5454updateInfo now lns old 
    55     = updated { _expired = infoExpired now updated }  
    56     where  
    57     initial = old { _lastUpdated = now }  
     55    = updated { _expired = infoExpired now updated } 
     56    where 
     57    initial = old { _lastUpdated = now } 
    5858    updated = execState (sequence $ parseInfo . lineComment <$> take 50 lns) initial 
    59      
     59 
    6060makeInfo :: String -> SourceInfo 
    6161makeInfo url = emptySourceInfo { _url = url } 
     
    6363readLogInfos :: [String] -> [SourceInfo] 
    6464readLogInfos lns = chunkInfo <$> chunks 
    65    where  
     65   where 
    6666   chunks = filter (not.null) . split [separator] . takeWhile (/= endMark) $ lns 
    6767   chunkInfo chunk = execState (sequence $ parseInfo <$> chunk) emptySourceInfo 
    6868 
    6969infoExpired :: UTCTime -> SourceInfo -> Bool 
    70 infoExpired now (SourceInfo _ _ _ _ lastUpdated expires _ _ ) =  
     70infoExpired now (SourceInfo _ _ _ _ lastUpdated expires _ _ ) = 
    7171        diffUTCTime now lastUpdated > fromInteger (expires * 60 * 60) 
    7272 
    7373lineComment :: Line -> String 
    7474lineComment (Line _ (Comment text)) = text 
    75 lineComment _ = ""  
     75lineComment _ = "" 
    7676 
    7777parseInfo :: String -> State SourceInfo () 
     
    8181        titleParser = (\x -> info{_title = x}) <$> (string "Title: " *> many1 anyChar) 
    8282        homepageParser = (\x -> info{_homepage = x}) <$> (string "Homepage: " *> many1 anyChar) 
    83         lastUpdatedParser = (\x -> case x of  
     83        lastUpdatedParser = (\x -> case x of 
    8484                                        Just time -> info{_lastUpdated = time} 
    85                                         Nothing   -> info)  
    86             <$> parseTime defaultTimeLocale "%d %b %Y %H:%M %Z"  
     85                                        Nothing   -> info) 
     86            . parseTimeM True defaultTimeLocale "%d %b %Y %H:%M %Z" 
    8787            <$> (string "Last modified: " *> many1 anyChar) 
    88         licenseParser = (\x -> info{_license = x})  
    89             <$> ((string "Licen" <|> string "Лицензия") *> manyTill anyChar (char ':')  
     88        licenseParser = (\x -> info{_license = x}) 
     89            <$> ((string "Licen" <|> string "Лицензия") *> manyTill anyChar (char ':') 
    9090                *> skipMany (char ' ') *> many1 anyChar) 
    91         expiresParser = (\n unit -> info{_expires = unit * read n})  
    92             <$> (string "Expires: " *> many1 digit) <*> (24 <$ string " days" <|> 1 <$ string " hours")  
     91        expiresParser = (\n unit -> info{_expires = unit * read n}) 
     92            <$> (string "Expires: " *> many1 digit) <*> (24 <$ string " days" <|> 1 <$ string " hours") 
    9393        versionParser = (\x -> info{_version = read x}) <$> (string "Version: " *> many1 digit) 
    94         stringParser = skipMany (char ' ') *>  
    95             (try urlParser <|> try titleParser <|> try expiresParser <|> try versionParser  
     94        stringParser = skipMany (char ' ') *> 
     95            (try urlParser <|> try titleParser <|> try expiresParser <|> try versionParser 
    9696              <|> try licenseParser <|> try homepageParser <|> try lastUpdatedParser) 
    9797    case parse stringParser "" text of 
    9898        Left _ -> return () 
    99         Right info' -> put info'  
     99        Right info' -> put info' 
  • adblock2privoxy/src/Statistics.hs

    rff7ee56 re2b555c  
    44import qualified Data.Map as Map 
    55import InputParser 
    6 import Data.Maybe  
    7 import Control.Applicative  
     6import Data.Maybe 
     7import Control.Applicative 
    88import Control.Monad.State 
    99 
    10 type Stat = Map.Map String Int  
     10type Stat = Map.Map String Int 
    1111 
    1212collectStat :: [Line] -> [String] 
     
    2323 
    2424 
    25 getStat :: Line -> Stat-> Stat  
     25getStat :: Line -> Stat-> Stat 
    2626getStat  (Line _ Comment {} ) = increment "Comments" 
    2727getStat  (Line _ Error {}) = increment "Errors" 
    2828getStat  (Line _ ElementHide {}) = increment "Elements hiding rules" 
    2929getStat  (Line _ (RequestBlock policy _ (RequestOptions _ thirdParty domains _ _ _ _ _))) = execState stateState 
    30     where  
     30    where 
    3131    incrementState = modify . increment 
    3232    stateState = do 
     
    3636        when ((not.null._negative $ domains) || (isJustFilled . _positive $ domains)) $ incrementState "Request block rules with domain option" 
    3737        when ((not.null._negative $ domains) || (isJustFilled . _positive $ domains)) $ incrementState "Request block rules with request type options" 
    38          
    39  
    40         
    41         
    42         
  • adblock2privoxy/src/Task.hs

    rff7ee56 re2b555c  
    77import InputParser 
    88import Statistics 
    9 import Control.Applicative ((<$>)) 
    109 
    1110writeTask :: String -> [String] -> [Line] -> IO () 
    12 writeTask filename info lns =  
    13     let  
     11writeTask filename info lns = 
     12    let 
    1413        statistics = collectStat lns 
    15         errorLine (Line position (Error text))  
     14        errorLine (Line position (Error text)) 
    1615            = [concat ["ERROR: ", recordSourceText position, " - ", text]] 
    1716        errorLine _ = [] 
    18     in do    
     17    in do 
    1918        outFile <- openFile filename WriteMode 
    2019        _ <- mapM (hPutStrLn outFile) info 
    21         _ <- sequence $ hPutStrLn outFile <$> statistics  
     20        _ <- sequence $ hPutStrLn outFile <$> statistics 
    2221        _ <- sequence $ hPutStrLn outFile <$> (lns >>= errorLine) 
    2322        hClose outFile 
    2423 
    25 readTask :: String -> IO [String]        
    26 readTask path = do  
     24readTask :: String -> IO [String] 
     25readTask path = do 
    2726        result <- lines <$> Strict.readFile path 
    2827        return $ length result `seq` result --read whole file to allow its overwriting 
    29  
  • adblock2privoxy/src/Templates.hs

    rb4685e7 re2b555c  
    44import System.FilePath ((</>)) 
    55import Data.String.Utils (replace, startswith) 
    6 import Control.Applicative 
    76 
    87blockCss, ab2pPrefix, actionsFilePrefix, filtersFilePrefix :: String 
     
    1312 
    1413terminalActionSwitch :: Bool -> BlockMethod -> String 
    15 terminalActionSwitch True Request =  
     14terminalActionSwitch True Request = 
    1615 "+block{ adblock rules } \\\n\ 
    1716 \+server-header-tagger{ab2p-block-s}" 
    18 terminalActionSwitch False Request =  
     17terminalActionSwitch False Request = 
    1918 "-block \\\n\ 
    2019 \-server-header-tagger{ab2p-block-s} \\\n\ 
     
    2221 \+server-header-tagger{ab2p-unblock-s} \\\n\ 
    2322 \+client-header-tagger{ab2b-unblock-u}" 
    24 terminalActionSwitch True Xframe = "+server-header-filter{ab2p-xframe-filter}"  
    25 terminalActionSwitch False Xframe = "-server-header-filter{ab2p-xframe-filter}"  
    26 terminalActionSwitch False Elem = "-filter{ab2p-elemhide-filter}"  
    27 terminalActionSwitch True Xpopup = "+filter{ab2p-popup-filter}"  
    28 terminalActionSwitch False Xpopup = "-filter{ab2p-popup-filter}"  
     23terminalActionSwitch True Xframe = "+server-header-filter{ab2p-xframe-filter}" 
     24terminalActionSwitch False Xframe = "-server-header-filter{ab2p-xframe-filter}" 
     25terminalActionSwitch False Elem = "-filter{ab2p-elemhide-filter}" 
     26terminalActionSwitch True Xpopup = "+filter{ab2p-popup-filter}" 
     27terminalActionSwitch False Xpopup = "-filter{ab2p-popup-filter}" 
    2928terminalActionSwitch True Dnt = "+add-header{DNT: 1}" 
    30 terminalActionSwitch _ _ = ""  
     29terminalActionSwitch _ _ = "" 
    3130 
    3231writeTemplateFiles :: String -> String -> IO () 
     
    4039                replace' line (from, to) = replace from to line 
    4140                filterLine line 
    42                         | null cssDomain && startswith "[?CSS_DOMAIN]" line = ""  
    43                         | otherwise = foldl replace' line [("[?CSS_DOMAIN]", ""), ("[CSS_DOMAIN]", cssDomain)]  
    44                                    
     41                        | null cssDomain && startswith "[?CSS_DOMAIN]" line = "" 
     42                        | otherwise = foldl replace' line [("[?CSS_DOMAIN]", ""), ("[CSS_DOMAIN]", cssDomain)] 
     43 
    4544        copySystem file = do 
    4645                dataDir <- getDataDir 
  • adblock2privoxy/src/UrlBlocker.hs

    rff7ee56 re2b555c  
    55) where 
    66import InputParser 
    7 import Control.Applicative 
    87import Control.Monad 
    98import Data.List 
    109import Data.Char (toLower) 
    11 import Data.Monoid 
    1210import OptionsConverter 
    13 import Utils  
     11import Utils 
    1412import Control.Monad.State 
    15 import qualified Templates  
     13import qualified Templates 
    1614import qualified Data.Map as Map 
    1715import Data.String.Utils (split) 
    18 import Data.Maybe     
    19 import System.IO   
     16import Data.Maybe 
     17import System.IO 
    2018import System.FilePath 
    21 import PatternConverter           
     19import PatternConverter 
    2220 
    2321data TaggerType = Client | Server 
     
    3230type UrlBlockData = ([Tagger], [Action]) 
    3331data BlockMethod = Request | Xframe | Elem | Dnt | Xpopup deriving (Show, Eq) 
    34 data FilteringNode = Node { _pattern :: [Pattern], _filters :: HeaderFilters, _nodeType :: ChainType,  
     32data FilteringNode = Node { _pattern :: [Pattern], _filters :: HeaderFilters, _nodeType :: ChainType, 
    3533    _policy :: Policy, _method :: BlockMethod } 
    3634 
     
    4038 
    4139urlBlock :: String -> [String] -> [Line] -> IO() 
    42 urlBlock path info = writeBlockData . urlBlockData  
    43     where     
     40urlBlock path info = writeBlockData . urlBlockData 
     41    where 
    4442    writeBlockData :: UrlBlockData -> IO() 
    45     writeBlockData (taggers, actions) =  
     43    writeBlockData (taggers, actions) = 
    4644        do writeContent (path </> "ab2p.filter") Templates.filtersFilePrefix taggers 
    4745           writeContent (path </> "ab2p.action") Templates.actionsFilePrefix actions 
    48     writeContent filename header content =  
     46    writeContent filename header content = 
    4947         do outFile <- openFile filename WriteMode 
    5048            hSetEncoding outFile utf8 
    51             hPutStrLn outFile header  
     49            hPutStrLn outFile header 
    5250            _ <- mapM (hPutStrLn outFile) $ ('#':) <$> info 
    5351            hPutStrLn outFile $ intercalate "\n\n" $ show <$> content 
    5452            hClose outFile 
    5553 
    56 urlBlockData :: [Line] -> UrlBlockData  
     54urlBlockData :: [Line] -> UrlBlockData 
    5755urlBlockData lns = filterBlockData result 
    5856    where 
     
    6058    cmpPolicy node1 node2 = compare (_policy node1) (_policy node2) 
    6159    blockLines = lns >>= blockLine 
    62         where  
    63         blockLine (Line position (RequestBlock policy pattern options))  
     60        where 
     61        blockLine (Line position (RequestBlock policy pattern options)) 
    6462            = filteringNodes policy (errorToPattern expandedPatterns) options 
    65             where  
     63            where 
    6664            expandedPatterns = makePattern (_matchCase options) <<$> parseUrl pattern 
    67             sourceText = recordSourceText position  
     65            sourceText = recordSourceText position 
    6866            errorToPattern (Left parseError) = ["# ERROR: " ++ sourceText  ++ " - " ++ show parseError] 
    6967            errorToPattern (Right patterns') = ("# " ++ sourceText) : patterns' 
    7068        blockLine _ = [] 
    71      
     69 
    7270filterNodesList :: [FilteringNode] -> [FilteringNode] 
    7371filterNodesList nodes = Map.foldr (:) [] $ Map.fromListWith joinNodes list 
    7472    where 
    7573    list = [(name node, node) | node <- nodes] 
    76     joinNodes (Node patterns1 filters1 type1 policy1 method1)  
    77               (Node patterns2 _ type2 _ _)  
     74    joinNodes (Node patterns1 filters1 type1 policy1 method1) 
     75              (Node patterns2 _ type2 _ _) 
    7876        = Node (patterns1 ++ patterns2) filters1 (max type1 type2) policy1 method1 
    7977 
     
    8684    joinTaggers tagger1 tagger2 | metric tagger1 >= metric tagger2 = tagger1 
    8785                                | otherwise                        = tagger2 
    88           
    89 shortenNodes :: [FilteringNode] -> [FilteringNode]       
     86 
     87shortenNodes :: [FilteringNode] -> [FilteringNode] 
    9088shortenNodes nodes = evalState (mapM shortenNode nodes) initialState 
    91     where  
     89    where 
    9290    initialState = Map.empty :: Map.Map String String 
    93     shortenNode node = (\f -> node {_filters = f}) <$> (mapM.mapM) shortenFilter (_filters node)        
    94     shortenFilter headerFilter@(HeaderFilter headerType flt)  
    95         = let filterCode = _code flt  
    96           in do  
    97              dictionary <- get  
    98              case Map.lookup filterCode dictionary of  
     91    shortenNode node = (\f -> node {_filters = f}) <$> (mapM.mapM) shortenFilter (_filters node) 
     92    shortenFilter headerFilter@(HeaderFilter headerType flt) 
     93        = let filterCode = _code flt 
     94          in do 
     95             dictionary <- get 
     96             case Map.lookup filterCode dictionary of 
    9997                 Just shortenCode -> return $ HeaderFilter headerType flt { _code = shortenCode } 
    10098                 Nothing -> case break (=='[') filterCode of 
    10199                    (_,[]) -> return headerFilter 
    102                     (start, rest) ->  
    103                         let end = last $ split "]" rest  
    104                             shortenCode' = start ++ show (Map.size dictionary + 1) ++  end  
     100                    (start, rest) -> 
     101                        let end = last $ split "]" rest 
     102                            shortenCode' = start ++ show (Map.size dictionary + 1) ++  end 
    105103                        in do put $ Map.insert filterCode shortenCode' dictionary 
    106104                              return $ HeaderFilter headerType flt { _code = shortenCode' } 
    107                              
     105 
    108106 
    109107filteringNodes :: Policy -> [Pattern] -> RequestOptions -> [FilteringNode] 
    110 filteringNodes policy patterns requestOptions  
     108filteringNodes policy patterns requestOptions 
    111109    = join.join $  [mainResult, subdocumentResult, elemhideResult, dntResult, popupResult] 
    112     where  
     110    where 
    113111    mainResult = optionsToNodes mainOptions $> Request 
    114112    subdocumentResult = maybeToList (optionsToNodes (singleTypeOptions Subdocument) $> Xframe) 
     
    122120        then Nothing 
    123121        else Just requestOptions {_requestType = Restrictions Nothing [], _thirdParty = Nothing} 
    124     singleTypeOptions singleType =  
     122    singleTypeOptions singleType = 
    125123        do 
    126124        foundTypes <- filter (== singleType) <$> _positive requestType 
     
    131129    nestedOrRegular False = Regular 
    132130    collectNodes :: [Pattern] -> Maybe HeaderFilters -> BlockMethod -> [FilteringNode] 
    133     collectNodes _ Nothing _ = []  
     131    collectNodes _ Nothing _ = [] 
    134132    collectNodes patterns' (Just []) method = [Node patterns' [] (nestedOrRegular $ null patterns') policy method] 
    135133    collectNodes patterns' (Just filters@(levelFilters: next)) method 
    136             = Node patterns' filters (nestedOrRegular $ null patterns') policy method  
    137               : (levelFilters >>= negateNode)  
     134            = Node patterns' filters (nestedOrRegular $ null patterns') policy method 
     135              : (levelFilters >>= negateNode) 
    138136              ++ collectNodes [] (Just next) method 
    139         where  
    140         negateNode negateFilter@(HeaderFilter _ (Filter {_orEmpty = True}))  
     137        where 
     138        negateNode negateFilter@(HeaderFilter _ (Filter {_orEmpty = True})) 
    141139                = [Node [] ([negateFilter] : next) Negate policy method] 
    142         negateNode _ = []  
    143            
     140        negateNode _ = [] 
     141 
    144142nodeResult :: FilteringNode -> UrlBlockData 
    145143nodeResult node@(Node patterns [] nodeType policy method) = ([], [baseAction]) 
     
    152150nodeResult node@(Node patterns (levelFilters : nextLevelFilters) nodeType policy method) 
    153151    = (taggers, [action]) 
    154     where  
     152    where 
    155153    action = Action { _actionCode = name node, 
    156                       _switches   = appendIf (policy == Unblock && method == Request)  
     154                      _switches   = appendIf (policy == Unblock && method == Request) 
    157155                                        (Switch False BlockAction) 
    158156                                        (Switch True . TaggerAction <$> taggers), 
    159157                      _patterns   = patterns, 
    160                       _hasTag     = nodeType == Nested }   
     158                      _hasTag     = nodeType == Nested } 
    161159    taggers = filterTaggers <$> levelFilters 
    162     filterTaggers flt@(HeaderFilter _ (Filter _ _ orEmpty))   
     160    filterTaggers flt@(HeaderFilter _ (Filter _ _ orEmpty)) 
    163161        = newTagger flt nextLevelFilters policy method Regular moreForwarding 
    164162        where 
     
    166164        moreForwarding  | orEmpty = [CancelTagger orEmptyTaggerCode] 
    167165                        | otherwise = [] 
    168              
     166 
    169167newTagger :: HeaderFilter -> HeaderFilters -> Policy -> BlockMethod -> ChainType -> [TaggerForwarder] -> Tagger 
    170168newTagger flt@(HeaderFilter headerType filter') nextLevelFilters policy method chainType moreForwarding 
    171169   = Tagger { _taggerCode = taggerCode, 
    172170              _forwarding = Forward filter'' nextLevelActionCode : moreForwarding, 
    173               _headerType = headerType }      
     171              _headerType = headerType } 
    174172   where 
    175173   filter'' | chainType == Negate = Nothing 
    176174            | otherwise           = Just filter' 
    177    taggerCode          = filtersCode ([flt] : nextLevelFilters) chainType policy method ""         
    178    nextLevelActionCode = filtersCode nextLevelFilters  Nested policy method ""    
    179             
     175   taggerCode          = filtersCode ([flt] : nextLevelFilters) chainType policy method "" 
     176   nextLevelActionCode = filtersCode nextLevelFilters  Nested policy method "" 
     177 
    180178instance Named FilteringNode where 
    181     name (Node _ filters Negate policy method)  = '-' : filtersCode filters Negate policy method ""  
    182     name (Node _ filters _ policy method)  = filtersCode filters Nested policy method ""  
    183      
     179    name (Node _ filters Negate policy method)  = '-' : filtersCode filters Negate policy method "" 
     180    name (Node _ filters _ policy method)  = filtersCode filters Nested policy method "" 
     181 
    184182filtersCode :: HeaderFilters -> ChainType -> Policy -> BlockMethod -> String -> String 
    185 filtersCode [] _ policy method rest  
     183filtersCode [] _ policy method rest 
    186184    = join [Templates.ab2pPrefix, toLower <$> show policy, "-" ,toLower <$> show method, if null rest then "" else "-", rest] 
    187 filtersCode (levelFilters : nextLevelFilters) chainType policy method rest  
     185filtersCode (levelFilters : nextLevelFilters) chainType policy method rest 
    188186    = filtersCode nextLevelFilters Nested policy method $ join [levelCode, if null rest then "" else "-when-", rest] 
    189     where  
     187    where 
    190188    levelCode = intercalate "-" $ filterCode <$> levelFilters 
    191189    filterCode (HeaderFilter HeaderType {_typeCode = typeCode} (Filter code _ orEmpty)) 
    192190        | chainType == Negate            = negateCode 
    193         | chainType == Nested && orEmpty = negateCode ++ '-' : mainCode   
     191        | chainType == Nested && orEmpty = negateCode ++ '-' : mainCode 
    194192        | otherwise                      = mainCode 
    195         where  
     193        where 
    196194        mainCode = typeCode : code 
    197195        negateCode = 'n' : [typeCode] 
     
    208206 
    209207instance Show Tagger where 
    210     show (Tagger code forwarding HeaderType {_name = headerName, _taggerType =  taggerType })  
     208    show (Tagger code forwarding HeaderType {_name = headerName, _taggerType =  taggerType }) 
    211209        = intercalate "\n" (caption : (forward <$> forwarding)) 
    212210        where caption = show taggerType ++ (':' : ' ' : code) 
     
    215213              forward (CancelTagger taggerCode) = forwardRegex headerName "" ":" "-" taggerCode 
    216214              forwardRegex header expression value tagPrefix tagret 
    217                 = let  (modifier, lookahead' : additionalLines)  
     215                = let  (modifier, lookahead' : additionalLines) 
    218216                            | '\n' `elem` expression = ("i", split "\n" expression) -- the case for third-party 
    219217                            | otherwise              = ("Ti", [expression]) 
    220                   in intercalate "\n" $ additionalLines ++  
    221                         [join ["s@^", header, lookahead', value, ".*@", tagPrefix, tagret, "@", modifier]]  
     218                  in intercalate "\n" $ additionalLines ++ 
     219                        [join ["s@^", header, lookahead', value, ".*@", tagPrefix, tagret, "@", modifier]] 
    222220 
    223221instance Named Bool where 
    224222    name True = "+" 
    225     name False = "-"                   
     223    name False = "-" 
    226224 
    227225instance Show ActionSwitch where 
    228226    show (Switch enable (TerminalAction method)) = Templates.terminalActionSwitch enable method 
    229227    show (Switch enable BlockAction) = name enable ++ "block" 
    230     show (Switch enable (TaggerAction tagger))  
     228    show (Switch enable (TaggerAction tagger)) 
    231229        = intercalate " \\\n " $ mainText : (_forwarding tagger >>= cancelTaggerText) 
    232         where  
     230        where 
    233231        mainText = join [name enable, name . _taggerType . _headerType $ tagger, "{", name tagger,  "}" ] 
    234         cancelTaggerText (CancelTagger cancelTaggerCode)  
     232        cancelTaggerText (CancelTagger cancelTaggerCode) 
    235233            = [join [name enable, name . _taggerType . _headerType $ tagger, "{", cancelTaggerCode,  "}" ]] 
    236         cancelTaggerText _ = []                 
    237      
     234        cancelTaggerText _ = [] 
     235 
    238236instance Named Action where 
    239237    name = _actionCode 
    240      
     238 
    241239instance Show Action where 
    242240    show (Action code switches patterns hasTag) 
     
    245243              switches' = join ["{", intercalate " \\\n " (show <$> switches), " \\\n}"] 
    246244              patterns' | hasTag    = join ["TAG:^", code, "$"] : patterns 
    247                         | otherwise = patterns   
    248                  
    249                  
    250               
    251                                          
    252                                          
    253                                          
    254                                          
    255                                          
    256                                          
    257                                          
    258                                          
    259                                          
    260                                          
    261                                          
    262                                          
    263                                          
    264      
    265      
     245                        | otherwise = patterns 
  • adblock2privoxy/src/Utils.hs

    rb4685e7 re2b555c  
    2525import Control.Applicative hiding (many) 
    2626import Control.Monad.Writer 
    27 import Control.Monad.State  
     27import Control.Monad.State 
    2828 
    2929------------------------------------------------------------------------------------------ 
     
    3333-- at least one list should be finite 
    3434compareList :: Ord a => [a] -> [a] -> Ordering 
    35 compareList = compareList' EQ    
     35compareList = compareList' EQ 
    3636    where 
    3737        compareList' lx [] [] = lx 
    3838        compareList' _ [] _ = LT 
    3939        compareList' _ _ [] = GT 
    40         compareList' lx (x:xs) (y:ys) = compareList' (lx <> compare x y) xs ys  
    41      
     40        compareList' lx (x:xs) (y:ys) = compareList' (lx <> compare x y) xs ys 
     41 
    4242maxList :: Ord a => [a] -> [a] -> [a] 
    4343maxList a b = if compareList a b == LT then b else a 
     
    6363 
    6464class Struct2 f where 
    65         struct2 :: a1 -> a2 -> f a1 a2       
     65        struct2 :: a1 -> a2 -> f a1 a2 
    6666        square2 :: (Applicative g, Monoid a1, Monoid a2) => g a1 -> g a2 -> [g (f a1 a2)] 
    6767        square2 a1 a2  = makeSquare (pure'' struct2 <%> a1 <%> a2) 
     
    7070class Struct3 f where 
    7171        struct3 :: a1 -> a2 -> a3 -> f a1 a2 a3 
    72         square3 :: (Applicative g, Monoid a1, Monoid a2, Monoid a3) =>  
     72        square3 :: (Applicative g, Monoid a1, Monoid a2, Monoid a3) => 
    7373                    g a1 -> g a2 -> g a3 -> [g (f a1 a2 a3)] 
    7474        square3 a1 a2 a3  = makeSquare (pure'' struct3 <%> a1 <%> a2 <%> a3) 
    75          
     75 
    7676class Struct4 f where 
    7777        struct4 :: a1 -> a2 -> a3 -> a4 -> f a1 a2 a3 a4 
    78         square4 :: (Applicative g, Monoid a1, Monoid a2, Monoid a3, Monoid a4) =>  
     78        square4 :: (Applicative g, Monoid a1, Monoid a2, Monoid a3, Monoid a4) => 
    7979                    g a1 -> g a2 -> g a3 -> g a4 -> [g (f a1 a2 a3 a4)] 
    8080        square4 a1 a2 a3 a4  = makeSquare (pure'' struct4 <%> a1 <%> a2 <%> a3 <%> a4) 
    81          
     81 
    8282class Struct5 f where 
    8383        struct5 :: a1 -> a2 -> a3 -> a4 -> a5 -> f a1 a2 a3 a4 a5 
    84         square5 :: (Applicative g, Monoid a1, Monoid a2, Monoid a3, Monoid a4, Monoid a5) =>  
     84        square5 :: (Applicative g, Monoid a1, Monoid a2, Monoid a3, Monoid a4, Monoid a5) => 
    8585                    g a1 -> g a2 -> g a3 -> g a4 -> g a5 -> [g (f a1 a2 a3 a4 a5)] 
    8686        square5 a1 a2 a3 a4 a5 = makeSquare (pure'' struct5 <%> a1 <%> a2 <%> a3 <%> a4 <%> a5) 
     
    100100--  Just ( "" ,  1,  False ), 
    101101--  Just ( "" ,  0 , True  )] 
    102 -------------------------  
     102------------------------- 
    103103testSquare :: [Maybe (String, Sum Int, Any)] 
    104104testSquare = square3 (Just "a") (Just (Sum $ length "")) (Just (Any True)) 
     
    112112--  (m,V)] 
    113113-- where V is for value, m is for mempty 
    114 -- involves 2 applicatives/monads :  
     114-- involves 2 applicatives/monads : 
    115115-- State Int a - stores column number 
    116 -- Reader ((->) r) - provides row number from outside  
     116-- Reader ((->) r) - provides row number from outside 
    117117valueOnDiagonal :: (Applicative f, Monoid a) =>  f a -> State Int (Int -> f a) 
    118118valueOnDiagonal val = do 
    119119        col <- get 
    120120        put (col + 1) 
    121         return (\row -> if row == col  
    122                                 then val  
     121        return (\row -> if row == col 
     122                                then val 
    123123                                else pure mempty) 
    124124 
    125125-- lifts right argument 2 levels up to become s (r (f a)) where s = State and r = Reader 
    126 -- then applies left arg to right one  
     126-- then applies left arg to right one 
    127127-- it's used to put items to a line in matrix 
    128128(<%>) :: (Applicative f, Monoid a) => State Int (Int -> f (a -> b)) 
     
    137137                        (line', size) = runState line start 
    138138                  in    line' <$> [start .. size - 1] 
    139                    
     139 
    140140-- pure level 2 
    141141pure' :: (Applicative f, Applicative g) => a -> f (g a) 
     
    148148infixl 4 .*., <<$>, <<<$>, $>, $>>, $>>>, <<*>>, <<<*>>> 
    149149 
    150 (.*.) :: (c -> d) ->  
    151          (a -> b -> c) ->  
     150(.*.) :: (c -> d) -> 
     151         (a -> b -> c) -> 
    152152          a -> b -> d 
    153153(.*.) = (.).(.) 
     
    160160 
    161161($>) :: (Applicative f) => f (a -> b) -> a -> f b 
    162 ($>) a b = a <*> pure b  
     162($>) a b = a <*> pure b 
    163163 
    164164($>>) :: (Applicative f, Applicative g) => f (g (a -> b)) -> a -> f (g b) 
    165 ($>>) a b = a <<*>> pure' b  
     165($>>) a b = a <<*>> pure' b 
    166166 
    167167($>>>) :: (Applicative f, Applicative g, Applicative h) => f (g (h (a -> b))) -> a -> f (g (h b)) 
    168 ($>>>) a b = a <<<*>>> pure'' b  
     168($>>>) a b = a <<<*>>> pure'' b 
    169169 
    170170(<<*>>) :: (Applicative f, Applicative g) => f (g (a -> b)) -> f (g a) -> f (g b) 
Note: See TracChangeset for help on using the changeset viewer.