From 2e1b1a76f4a9c2339fea46539167e8c95ef81104 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Sat, 14 Mar 2020 09:11:46 +1300
Subject: [PATCH] Integrate dispatching to native apps.

---
 rhapsode.cabal |  2 +-
 src/Input.hs   | 41 +++++++++++++++++++++++------------------
 2 files changed, 24 insertions(+), 19 deletions(-)

diff --git a/rhapsode.cabal b/rhapsode.cabal
index 7acb91f..fb655ed 100644
--- a/rhapsode.cabal
+++ b/rhapsode.cabal
@@ -64,7 +64,7 @@ executable rhapsode
         html-conduit, xml-conduit, text, containers, data-default-class,
         network-uri,
         stylist >= 1.1, css-syntax, xml-conduit-stylist, scientific,
-        async, hurl >= 1.1.0.0, filepath
+        async, hurl >= 1.2.0.0, filepath, temporary
   
   -- Directories containing source files.
   hs-source-dirs:      src
diff --git a/src/Input.hs b/src/Input.hs
index 6c12fe1..6245dbd 100644
--- a/src/Input.hs
+++ b/src/Input.hs
@@ -15,6 +15,7 @@ import Control.Concurrent.Async
 import System.IO
 import System.Environment
 import System.Directory
+import System.IO.Temp
 import Data.List
 import Data.Default.Class
 import Data.Maybe (fromMaybe)
@@ -76,14 +77,28 @@ evalInput http ("-x", url) = fetchDocument http ["text/xml", "text/html", "text/
 evalInput http ("-xml", url) = fetchDocument http ["text/xml", "text/html", "text/plain"] url
 evalInput _ (flag, _) = error ("Unsupported input flag " ++ flag)
 
-fetchDocument http mime uri = fetchURL http mime uri >>= parseDocument
-parseDocument ("text/html", Left text) = return $ HTML.parseLT $ fromStrict text
-parseDocument ("text/html", Right bytes) = return $ HTML.parseLBS bytes
-parseDocument ("text/plain", Left text) = return $ docForText text
-parseDocument ("text/plain", Right bytes) = return $ docForText $ decodeUtf8 $ B.toStrict bytes
-parseDocument (_, Left text) | Right doc <- XML.parseText def $ fromStrict text = return doc
-parseDocument (_, Right bytes) | Right doc <- XML.parseLBS def bytes = return doc
-parseDocument (mime, _) = return $ docForText $ Txt.concat ["Unsupported MIMEtype ", Txt.pack mime]
+fetchDocument http mime uri = fetchURL http mime uri >>= parseDocument http
+parseDocument _ ("text/html", Left text) = return $ HTML.parseLT $ fromStrict text
+parseDocument _ ("text/html", Right bytes) = return $ HTML.parseLBS bytes
+parseDocument _ ("text/plain", Left text) = return $ docForText text
+parseDocument _ ("text/plain", Right bytes) = return $ docForText $ decodeUtf8 $ B.toStrict bytes
+parseDocument _ ("application/xhtml+xml", Left text) | Right doc <- XML.parseText def $ fromStrict text = return doc
+  | otherwise = return $ docForText "Unreadable webpage!"
+parseDocument _ ("application/xhtml+xml", Right bytes) | Right doc <- XML.parseLBS def bytes = return doc
+  | otherwise = return $ docForText "Unreadable webpage!"
+parseDocument session (mime, download) = do
+    localURI <- withSystemTempFile "rhapsode-download" $ writeDownloadToFile download
+    result <- dispatchByMIME session mime localURI
+    case result of
+        Just text -> return $ docForText $ Txt.pack text
+        Nothing -> parseDocument session ("application/xhtml+xml", download)
+
+writeDownloadToFile (Left text) file handle = do
+    hPutStr handle $ Txt.unpack text
+    return $ URI "file:" Nothing file "" ""
+writeDownloadToFile (Right bytes) file handle = do
+    B.hPut handle bytes
+    return $ URI "file:" Nothing file "" ""
 
 docForText txt = XML.Document {
         XML.documentPrologue = XML.Prologue [] Nothing [],
@@ -94,13 +109,3 @@ docForText txt = XML.Document {
         },
         XML.documentEpilogue = []
     }
-
-newFilePath filepath count = do
-    let realpath = filepath ++ show count
-    exists <- doesPathExist realpath
-    if exists then newFilePath filepath $ count + 1 else return realpath
-
-downloadsDir = do
-    downloads <- lookupEnv "XDG_DOWNLOAD_DIR"
-    home <- getHomeDirectory
-    return $ fromMaybe (home </> "Downloads") downloads
-- 
2.30.2