summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAdrian Cochrane <adrian@openwork.nz>2020-10-03 20:39:31 +1300
committerAdrian Cochrane <adrian@openwork.nz>2020-10-03 20:39:31 +1300
commit4371e0f3daceee0cd7d132f8587389f937636dcc (patch)
treefd2c5525453773668b9ff83434e93219d4501fd2
parent5afbc2d65d98588e076c232c9b5f26dabc744239 (diff)
downloadhurl-4371e0f3daceee0cd7d132f8587389f937636dcc.tar.gz
hurl-4371e0f3daceee0cd7d132f8587389f937636dcc.tar.bz2
hurl-4371e0f3daceee0cd7d132f8587389f937636dcc.zip
Add support for URI rewriting plugins
-rw-r--r--hurl.cabal9
-rw-r--r--src/Network/URI/Fetch.hs24
-rw-r--r--src/Network/URI/PlugIns/Rewriters.hs49
3 files changed, 81 insertions, 1 deletions
diff --git a/hurl.cabal b/hurl.cabal
index 18ab494..26c330c 100644
--- a/hurl.cabal
+++ b/hurl.cabal
@@ -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
diff --git a/src/Network/URI/Fetch.hs b/src/Network/URI/Fetch.hs
index c5e1898..0d86fb1 100644
--- a/src/Network/URI/Fetch.hs
+++ b/src/Network/URI/Fetch.hs
@@ -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} =
diff --git a/src/Network/URI/PlugIns/Rewriters.hs b/src/Network/URI/PlugIns/Rewriters.hs
new file mode 100644
index 0000000..8e5b46f
--- /dev/null
+++ b/src/Network/URI/PlugIns/Rewriters.hs
@@ -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 "")