From 2d5e8445c3e4d5d88d7eb7910ffee950dbd6b816 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Wed, 15 Apr 2020 19:37:53 +1200
Subject: [PATCH] Add support for about: URIs.

---
 src/Network/URI/Fetch.hs | 20 ++++++++++++++++++--
 1 file changed, 18 insertions(+), 2 deletions(-)

diff --git a/src/Network/URI/Fetch.hs b/src/Network/URI/Fetch.hs
index 51e7420..44749e5 100644
--- a/src/Network/URI/Fetch.hs
+++ b/src/Network/URI/Fetch.hs
@@ -11,6 +11,9 @@ import           Data.ByteString.Lazy (ByteString)
 import qualified Data.ByteString.Lazy as B
 import           Control.Exception
 
+-- for about: URIs, all standard lib
+import Data.Maybe (fromMaybe, listToMaybe)
+
 #ifdef WITH_HTTP_URI
 import qualified Network.HTTP.Client as HTTP
 import qualified Network.HTTP.Client.TLS as TLS
@@ -40,7 +43,9 @@ data Session = Session {
     apps :: XDGConfig,
 #endif
     -- | The languages (RFC2616-encoded) to which responses should be localized.
-    locale :: [String]
+    locale :: [String],
+    -- | Additional files to serve from about: URIs.
+    aboutPages :: [(FilePath, ByteString)]
 }
 
 -- | Initializes a default Session object to support HTTPS & Accept-Language
@@ -62,14 +67,25 @@ newSession = do
 #ifdef WITH_XDG
         apps = apps',
 #endif
-        locale = ietfLocale
+        locale = ietfLocale,
+        aboutPages = []
     }
 
+llookup key fallback map = fallback `fromMaybe` listToMaybe [v | (k, v) <- map, k == key]
+
 -- | Retrieves a URL-identified resource & it's MIMEtype, possibly decoding it's text.
 fetchURL :: Session -- ^ The session of which this request is a part.
     -> [String] -- ^ The expected MIMEtypes in priority order.
     -> URI -- ^ The URL to retrieve
     -> IO (String, Either Text ByteString) -- ^ The MIMEtype & possibly text-decoded response.
+fetchURL session mimes uri@(URI {uriScheme = "about:", uriPath = ""}) =
+    fetchURL session mimes $ uri {uriPath = "version"}
+fetchURL Session {aboutPages = pages} _ URI {uriScheme = "about:", uriPath = path} =
+    return (
+        Txt.unpack $ convertCharset "utf-8" $ B.toStrict $
+            llookup (path ++ ".mime") "text/html" pages,
+        Right $ llookup path "" pages)
+
 #ifdef WITH_HTTP_URI
 fetchURL session accept@(defaultMIME:_) uri | uriScheme uri `elem` ["http:", "https:"] = do
     request <- HTTP.requestFromURI uri
-- 
2.30.2