3 files changed, 81 insertions(+), 1 deletions(-)

M hurl.cabal
M src/Network/URI/Fetch.hs
A src/Network/URI/PlugIns/Rewriters.hs

@@ 78,6 78,11 @@ Flag appstream
   Default:      True
   Manual:       True
 
+Flag rewriters
+  Description: Support regexp-based URI rewriting/blocking plugins
+  Default:		True
+  Manual: 		True
+
 source-repository head
     type: git
     location: https://git.adrian.geek.nz/hurl.git


@@ 123,6 128,10 @@ library
     CPP-options:   -DWITH_APPSTREAM
     build-depends: xml-conduit >=1.8 && < 1.9, zlib >= 0.6 && < 0.7, containers
     other-modules: Network.URI.XDG.AppStream, Network.URI.XDG.AppStreamOutput
+  if flag(rewriters)
+    CPP-options:   -DWITH_PLUGIN_REWRITES
+    build-depends: regex >= 1.1 && < 1.2, regex-tdfa >= 1.2 && < 1.4
+    other-modules: Network.URI.PlugIns.Rewriters
 
 executable hurl
   -- .hs file containing the Main module

@@ 48,6 48,10 @@ import Network.URI.Messages
 import Network.URI.XDG
 #endif
 
+#ifdef WITH_PLUGIN_REWRITES
+import Network.URI.PlugIns.Rewriters
+#endif
+
 -- | Data shared accross multiple URI requests.
 data Session = Session {
 #ifdef WITH_HTTP_URI


@@ 59,6 63,9 @@ data Session = Session {
 #ifdef WITH_XDG
     apps :: XDGConfig,
 #endif
+#ifdef WITH_PLUGIN_REWRITES
+    rewriter :: Rewriter,
+#endif
     -- | The languages (RFC2616-encoded) to which responses should be localized.
     locale :: [String],
     -- | Additional files to serve from about: URIs.


@@ 68,7 75,11 @@ data Session = Session {
 -- | Initializes a default Session object to support HTTPS & Accept-Language
 -- if HTTP is enabled.
 newSession :: IO Session
-newSession = do
+newSession = newSession' ""
+
+-- | Variant of `newSession` which loads plugins for the named app.
+newSession' :: String -> IO Session
+newSession' appname = do
     (ietfLocale, unixLocale) <- rfc2616Locale
 #ifdef WITH_HTTP_URI
     managerHTTP' <- HTTP.newManager TLS.tlsManagerSettings


@@ 79,6 90,9 @@ newSession = do
 #ifdef WITH_XDG
     apps' <- loadXDGConfig unixLocale
 #endif
+#ifdef WITH_PLUGIN_REWRITES
+    rewriters <- parseRewriters appname
+#endif
 
     return Session {
 #ifdef WITH_HTTP_URI


@@ 90,6 104,9 @@ newSession = do
 #ifdef WITH_XDG
         apps = apps',
 #endif
+#ifdef WITH_PLUGIN_REWRITES
+        rewriter = rewriters,
+#endif
         locale = ietfLocale,
         aboutPages = []
     }


@@ 119,6 136,11 @@ htmlERR = "html/x-error\t"
 
 -- | As per `fetchURL`, but also returns the redirected URI.
 fetchURL' :: Session -> [String] -> URI -> IO (URI, String, Either Text ByteString)
+#ifdef WITH_PLUGIN_REWRITES
+fetchURL' session mimes uri
+    | Just uri' <- applyRewriter (rewriter session) uri = fetchURL' session mimes uri'
+#endif
+
 fetchURL' session mimes uri@(URI {uriScheme = "about:", uriPath = ""}) =
     fetchURL' session mimes $ uri {uriPath = "version"}
 fetchURL' Session {aboutPages = pages} _ url@URI {uriScheme = "about:", uriPath = path} =

@@ 0,0 1,49 @@
+{-# LANGUAGE FlexibleContexts #-}
+module Network.URI.PlugIns.Rewriters(parseRewriter, parseRewriters, Rewriter, applyRewriter) where
+
+import Text.RE.Tools.Edit
+import Text.RE.TDFA.String
+import Network.URI (URI, uriToString, parseAbsoluteURI)
+import Data.Maybe (catMaybes, fromMaybe)
+
+import System.Directory as Dir
+import System.FilePath ((</>))
+import Control.Concurrent.Async (forConcurrently)
+
+type Rewriter = Edits Maybe RE String
+parseRewriter :: FilePath -> IO Rewriter
+parseRewriter filepath = do
+    source <- readFile filepath
+    let parseLine line | [pattern, template] <- words line = compileSearchReplace pattern template
+                | [pattern] <- words line = compileSearchReplace pattern "about:blank"
+                | otherwise = Nothing
+    let edits = catMaybes $ map parseLine $ lines source
+    return $ Select $ map Template edits
+
+parseRewriters :: String -> IO Rewriter
+parseRewriters app = do
+    dir <- Dir.getXdgDirectory Dir.XdgConfig "nz.geek.adrian.hurl"
+    exists <- Dir.doesDirectoryExist dir
+    if exists then do
+        rewriters <- loadRewriters dir
+
+        let inner = dir </> app
+        innerExists <- Dir.doesDirectoryExist dir
+        if innerExists then do
+            appRewriters <- loadRewriters inner
+            return $ Select (appRewriters ++ rewriters)
+        else return $ Select rewriters
+    else return $ Select []
+  where
+    loadRewriters dir = do
+        files <- Dir.listDirectory dir
+        raw <- forConcurrently files $ \file -> do
+            rewriter <- parseRewriter file
+            return $ case rewriter of
+                Select x -> x
+                Pipe x -> x
+        return $ concat raw
+
+applyRewriter :: Rewriter -> URI -> Maybe URI
+applyRewriter rewriter uri = parseAbsoluteURI =<<
+        applyEdits firstLine rewriter (uriToString id uri "")