From 484199606127617ae2b26e4e55cf94137571ddec Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Thu, 24 Dec 2020 21:35:58 +1300
Subject: [PATCH] Extract data for 'pseudolinks', exposing more features.

---
 src/Input.hs | 20 ++++++++++++++++----
 src/Types.hs | 14 ++++++++++++--
 2 files changed, 28 insertions(+), 6 deletions(-)

diff --git a/src/Input.hs b/src/Input.hs
index d8fc4d2..1a3380c 100644
--- a/src/Input.hs
+++ b/src/Input.hs
@@ -38,7 +38,17 @@ import Foreign.C.String
 
 utf8' bytes = convertCharset "utf-8" $ B.toStrict bytes
 
-fetchDocument http referer mime uri = fetchURL' http mime uri >>= parseDocument referer http >>= logHistory
+fetchDocument http referer mime uri = fetchURL' http mime uri >>= parseDocument' referer http
+parseDocument' ref sess resp@(_, mime, _) = parseDocument ref sess resp >>= logHistory >>= return . annotate
+    where
+        annotate x@Page { Types.url = uri'} | Types.url x == uri' = x { pageMIME = mime }
+            | ((_, back):backs) <- backStack ref, back == uri' =
+                x { pageMIME = mime, backStack = backs, forwardStack = entry x:forwardStack ref }
+            | ((_, next):nexts) <- forwardStack ref, next == uri' =
+                x { pageMIME = mime, forwardStack = nexts, backStack = entry x:backStack ref }
+            | otherwise =
+                x { pageMIME = mime, forwardStack = entry x:forwardStack ref, backStack = backStack ref }
+        entry x = (pageTitle x, Types.url x)
 parseDocument ref sess (uri, "html/x-error\t", resp) = parseDocument ref sess (uri, "text/html", resp)
 parseDocument _ _ (uri, "text/html", Left text) = pageForDoc uri $ HTML.parseLT $ fromStrict text
 parseDocument _ _ (uri, "text/html", Right bytes) = pageForDoc uri $ HTML.parseLBS bytes
@@ -84,16 +94,18 @@ pageForText uri txt = pageForDoc uri XML.Document {
         XML.documentEpilogue = []
     }
 
-pageForDoc uri doc = return Page {Types.url = uri, html = doc, css = html2css doc uri}
+pageForDoc uri doc = return Page {Types.url = uri, html = doc, css = html2css doc uri,
+    pageTitle = "", pageMIME = "", backStack = [], forwardStack = []}
 
 logHistory ret@Page {Types.url = url', html = doc} = do
     dir <- getXdgDirectory XdgData "rhapsode"
     createDirectoryIfMissing True dir
     now <- getCurrentTime
+    let title = Txt.unpack $ getTitle $ XML.documentRoot doc
     appendFile (dir </> "history.gmni") $ intercalate " " [
-        "=>", uriToString id url' "", show now, Txt.unpack $ getTitle $ XML.documentRoot doc
+        "=>", uriToString id url' "", show now, title
       ]
-    return ret
+    return ret { pageTitle = title }
   where
     getTitle (XML.Element "title" _ childs) = Txt.concat [txt | XML.NodeContent txt <- childs]
     getTitle (XML.Element "h1" _ childs) = Txt.concat [txt | XML.NodeContent txt <- childs]
diff --git a/src/Types.hs b/src/Types.hs
index 825ad8f..aa2d893 100644
--- a/src/Types.hs
+++ b/src/Types.hs
@@ -14,7 +14,15 @@ import Foreign.StablePtr
 
 type CArray a = Ptr a
 
-data Page = Page {url :: URI, css :: ConditionalStyles (TextStyle SpeechStyle), html :: Document}
+data Page = Page {
+    url :: URI,
+    css :: ConditionalStyles (TextStyle SpeechStyle),
+    html :: Document,
+    pageTitle :: String,
+    pageMIME :: String,
+    backStack :: [(String, URI)],
+    forwardStack :: [(String, URI)]
+}
 
 foreign export ccall c_initialReferer :: IO (StablePtr Page)
 
@@ -30,7 +38,9 @@ c_initialReferer = do
             documentPrologue = Prologue [] Nothing [],
             documentRoot = Element "temp" M.empty [],
             documentEpilogue = []
-        }
+        },
+        pageTitle = "", pageMIME = "",
+        backStack = [], forwardStack = []
     }
 
 foreign export ccall c_freePage :: StablePtr Page -> IO ()
-- 
2.30.2