Add new action: URI, don't refetch page upon local anchor links.

1 files changed, 45 insertions, 14 deletions

diff --git a/hurl-xml/src/Network/MIME/XML.hs b/hurl-xml/src/Network/MIME/XML.hs
index d3c397b..f260580 100644
--- a/hurl-xml/src/Network/MIME/XML.hs
+++ b/hurl-xml/src/Network/MIME/XML.hs
@@ -34,6 +34,7 @@ import System.Directory
 import System.FilePath ((</>))
 import Data.FileEmbed
 import Data.Maybe (fromMaybe)
+import Text.Read (readMaybe)
 
 import Network.MIME.XML.Table -- Apply table sorting here...
 import Data.HTML2CSS (html2css)
@@ -68,33 +69,63 @@ readStrict path = do s <- Prelude.readFile path; length s `seq` return s
 
 utf8' bytes = convertCharset "utf-8" $ B.toStrict bytes
 
-fetchDocument http referer mime uri@URI { uriScheme = 'n':'o':'c':'a':'c':'h':'e':'+':scheme } =
-    fetchDocument http { cachingEnabled = False } referer mime uri { uriScheme = scheme }
+fetchDocument http referer mime URI { uriScheme = "action:", uriPath = "nocache" } =
+    fetchDocument http { cachingEnabled = False } referer mime $ pageURL referer
+fetchDocument http referer mime URI { uriScheme = "action:", uriPath = "novalidate" } =
+    fetchDocument http { validateCertificates = False } referer mime $ pageURL referer
+fetchDocument http referer mime URI { uriScheme = "action:", uriPath = "history/back" } =
+        fetchURL' http mime (pageURL referer') >>= parseDocument' referer' http False
+    where referer' = shiftHistory referer (-1)
+fetchDocument http referer mime URI { uriScheme = "action:", uriPath = "history/forward" } =
+        fetchURL' http mime (pageURL referer') >>= parseDocument' referer' http False
+    where referer' = shiftHistory referer 1
+fetchDocument http referer mime URI {
+        uriScheme = "action:", uriPath = 'h':'i':'s':'t':'o':'r':'y':'/':x
+    } | Just x' <- readMaybe x, referer' <- shiftHistory referer x' =
+        fetchURL' http mime (pageURL referer') >>= parseDocument' referer http False
 fetchDocument http referer mime URI { uriScheme = "app:", uriPath = appID } = do
     dispatchByApp http Application {
         name = "", icon = nullURI, description = "",
         appId = appID
       } (pageMIME referer) $ pageURL referer
     return referer -- TODO play an error or success sound
-fetchDocument http referer mime uri = fetchURL' http mime uri >>= parseDocument' referer http
+fetchDocument http referer@Page { pageURL = uri0 } mime uri@URI { uriFragment = anchor }
+    | uri { uriFragment = "" } == uri0 { uriFragment = "" } = return referer {
+        html = applySortDoc anchor $ html referer,
+        pageURL = uri
+    }
+fetchDocument http referer mime uri = fetchURL' http mime uri >>= parseDocument' referer http True
+
+shiftHistory :: Page style -> Integer -> Page style
+shiftHistory self 0 = self
+shiftHistory self@Page { backStack = (title, url):bs } delta | delta < 0 =
+    shiftHistory self {
+        backStack = bs,
+        forwardStack = (pageTitle self, pageURL self):forwardStack self,
+        pageTitle = title,
+        pageURL = url
+    } $ succ delta
+shiftHistory self@Page { forwardStack = (title, url):fs } delta | delta > 0 =
+    shiftHistory self {
+        forwardStack = fs,
+        backStack = (pageTitle self, pageURL self):backStack self,
+        pageTitle = title,
+        pageURL = url
+    } $ pred delta
+shiftHistory self _ = self -- Error case.
 
-parseDocument' ref@Page {visitedURLs = hist} sess resp@(URI {uriFragment = anchor}, mime, _) = do
+parseDocument' ref@Page {visitedURLs = hist} sess saveHist resp@(URI {uriFragment = anch}, mime, _) = do
     page <- parseDocument ref sess resp >>= logHistory hist
     apps' <- appsForMIME sess mime
-    return $ attachHistory $ page {
+    return $ attachHistory page {
         pageMIME = mime,
         apps = apps',
-        html = applySortDoc anchor $ html page
+        html = applySortDoc anch $ html page
     }
   where
-    attachHistory x@Page { pageURL = uri'} | pageURL x == uri' = x
-        | ((_, back):backs) <- backStack ref, back == uri' =
-            x { backStack = backs, forwardStack = entry x:forwardStack ref }
-        | ((_, next):nexts) <- forwardStack ref, next == uri' =
-            x { forwardStack = nexts, backStack = entry x:backStack ref }
-        | otherwise =
-            x { forwardStack = entry x:forwardStack ref, backStack = backStack ref }
-    entry x = (pageTitle x, pageURL x)
+    attachHistory x@Page { pageTitle = title, pageURL = url }
+        | saveHist = x { backStack = (title, url):backStack ref, forwardStack = forwardStack ref }
+        | otherwise = x
 parseDocument :: StyleSheet s => Page s -> Session -> (URI, String, Either Text B.ByteString)
         -> IO (Page s)
 parseDocument ref sess (uri, "html/x-error\t", resp) = parseDocument ref sess (uri, "text/html", resp)