From 8d239eb61f8448f5b0158e97a738d87aeed42313 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Sun, 19 Jan 2020 17:29:29 +1300
Subject: [PATCH] Dispatch unsupported URIs to native apps on
 FreeDesktop.Org-compliant desktops

---
 hurl.cabal                          | 13 ++++-
 src/Network/URI/Fetch.hs            | 45 +++++++++++++++---
 src/Network/URI/Messages.hs         |  3 +-
 src/Network/URI/XDG.hs              | 20 ++++++++
 src/Network/URI/XDG/DesktopEntry.hs | 74 +++++++++++++++++++++++++++++
 src/Network/URI/XDG/Ini.hs          |  2 +-
 src/Network/URI/XDG/MimeApps.hs     |  2 +-
 7 files changed, 148 insertions(+), 11 deletions(-)
 create mode 100644 src/Network/URI/XDG.hs
 create mode 100644 src/Network/URI/XDG/DesktopEntry.hs

diff --git a/hurl.cabal b/hurl.cabal
index a511c0b..814fbef 100644
--- a/hurl.cabal
+++ b/hurl.cabal
@@ -10,7 +10,7 @@ name:                hurl
 -- PVP summary:      +-+------- breaking API changes
 --                   | | +----- non-breaking API additions
 --                   | | | +--- code changes with no API change
-version:             1.0.0.0
+version:             1.1.0.0
 
 -- A short (one-line) description of the package.
 synopsis:            Haskell URL resolver
@@ -63,6 +63,11 @@ Flag data
   Default:     True
   Manual:      True
 
+Flag freedesktop
+  Description: Dispatches unsupported URIs to external apps on FreeDesktop.Org-compatible desktops. Works on most non-mainstream/non-proprietary desktops.
+  Default:     True
+  Manual:      True
+
 source-repository head
     type: git
     location: https://git.nzoss.org.nz/alcinnz/hurl.git
@@ -72,7 +77,7 @@ library
   exposed-modules:     Network.URI.Charset, Network.URI.Fetch
   
   -- Modules included in this library but not exported.
-  other-modules:       Network.URI.Locale, Network.URI.Messages, Network.URI.XDG.Ini
+  other-modules:       Network.URI.Locale, Network.URI.Messages
   
   -- LANGUAGE extensions used by modules in this package.
   -- other-extensions:    
@@ -96,3 +101,7 @@ library
   if flag(data)
     CPP-options:   -DWITH_DATA_URI
     build-depends: base64-bytestring >=1.0 && <2.0
+  if flag(freedesktop)
+    CPP-options:   -DWITH_XDG
+    build-depends: filepath, directory, process >= 1.2 && <2.0
+    other-modules: Network.URI.XDG.Ini, Network.URI.XDG.MimeApps, Network.URI.XDG.DesktopEntry
diff --git a/src/Network/URI/Fetch.hs b/src/Network/URI/Fetch.hs
index f8fdde2..214274f 100644
--- a/src/Network/URI/Fetch.hs
+++ b/src/Network/URI/Fetch.hs
@@ -2,7 +2,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 -- | Retrieves documents for a URL, supporting multiple URL schemes that can be
 -- disabled at build-time for reduced dependencies.
-module Network.URI.Fetch(Session, locale, newSession, fetchURL) where
+module Network.URI.Fetch(Session, locale, newSession, fetchURL, dispatchByMIME) where
 
 import qualified Data.Text as Txt
 import           Data.Text (Text)
@@ -26,13 +26,20 @@ import qualified Data.ByteString.Base64 as B64
 import Network.URI.Locale
 import Network.URI.Messages
 
+#ifdef WITH_XDG
+import Network.URI.XDG
+#endif
+
 -- | Data shared accross multiple URI requests.
 data Session = Session {
-    -- | The languages (RFC2616-encoded) to which responses should be localized.
-    locale :: [String],
 #ifdef WITH_HTTP_URI
-    managerHTTP :: HTTP.Manager
+    managerHTTP :: HTTP.Manager,
+#endif
+#ifdef WITH_XDG
+    apps :: HandlersConfig,
 #endif
+    -- | The languages (RFC2616-encoded) to which responses should be localized.
+    locale :: [String]
 }
 
 -- | Initializes a default Session object to support HTTPS & Accept-Language
@@ -43,11 +50,18 @@ newSession = do
 #ifdef WITH_HTTP_URI
     managerHTTP' <- HTTP.newManager TLS.tlsManagerSettings
 #endif
+#ifdef WITH_XDG
+    apps' <- loadHandlers
+#endif
+
     return Session {
-        locale = locale',
 #ifdef WITH_HTTP_URI
-        managerHTTP = managerHTTP'
+        managerHTTP = managerHTTP',
 #endif
+#ifdef WITH_XDG
+        apps = apps',
+#endif
+        locale = locale'
     }
 
 -- | Retrieves a URL-identified resource & it's MIMEtype, possibly decoding it's text.
@@ -93,9 +107,28 @@ fetchURL _ (defaultMIME:_) uri@URI {uriScheme = "data:"} =
         (mime, response) -> return (mime, Left $ Txt.pack response)
 #endif
 
+#ifdef WITH_XDG
+fetchURL Session {locale = l, apps = a} _ uri@(URI {uriScheme = s})
+    | canDispatchMIME a ("x-scheme-handler/" ++ init s) = do
+        app <- dispatchURIByMIME l a uri ("x-scheme-handler/" ++ init s)
+        return (
+            "text/plain",
+            Left $ Txt.pack $ trans l $ case app of
+                Just name -> OpenedWith name
+                Nothing -> UnsupportedScheme s)
+#endif
+
 fetchURL Session {locale = l} _ URI {uriScheme = scheme} =
     return ("text/plain", Left $ Txt.pack $ trans l $ UnsupportedScheme scheme)
 
+dispatchByMIME :: Session -> String -> URI -> IO (Maybe String)
+#if WITH_XDG
+dispatchByMIME Session {locale = l, apps = a} mime uri
+    | canDispatchMIME a mime = dispatchURIByMIME l a uri mime
+#endif
+
+dispatchByMIME _ _ _ = return Nothing
+
 #ifdef WITH_DATA_URI
 breakOn c (a:as) | c == a = ([], as)
     | otherwise = let (x, y) = breakOn c as in (a:x, y)
diff --git a/src/Network/URI/Messages.hs b/src/Network/URI/Messages.hs
index 3fbdcf1..f46605a 100644
--- a/src/Network/URI/Messages.hs
+++ b/src/Network/URI/Messages.hs
@@ -10,9 +10,10 @@ module Network.URI.Messages (trans, Errors(..)) where
 
 --- BEGIN LOCALIZATION
 trans ("en":_) (UnsupportedScheme scheme) = "Unsupported protocol " ++ scheme
+trans ("en":_) (OpenedWith app) = "Opened in " ++ app
 --- END LOCALIZATION
 
 trans (_:locales) err = trans locales err
 trans [] err = trans ["en"] err
 
-data Errors = UnsupportedScheme String
+data Errors = UnsupportedScheme String | OpenedWith String
diff --git a/src/Network/URI/XDG.hs b/src/Network/URI/XDG.hs
new file mode 100644
index 0000000..ffe8656
--- /dev/null
+++ b/src/Network/URI/XDG.hs
@@ -0,0 +1,20 @@
+module Network.URI.XDG(HandlersConfig, loadHandlers, canDispatchMIME, dispatchURIByMIME) where
+
+import Network.URI (URI(..))
+import Network.URI.XDG.DesktopEntry
+import Network.URI.XDG.MimeApps
+
+canDispatchMIME :: HandlersConfig -> String -> Bool
+canDispatchMIME config mime = not $ null $ queryHandlers config mime
+
+dispatchURIByMIME :: [String] -> HandlersConfig -> URI -> String -> IO (Maybe String)
+dispatchURIByMIME locales config uri mime =
+    queryHandlers config mime `mapFirstM` launchApp locales uri
+
+mapFirstM :: [a] -> (a -> IO (Maybe b)) -> IO (Maybe b)
+mapFirstM (x:xs) cb = do
+    item <- cb x
+    case item of
+        Just _ -> return item
+        Nothing -> mapFirstM xs cb
+mapFirstM [] _ = return Nothing
diff --git a/src/Network/URI/XDG/DesktopEntry.hs b/src/Network/URI/XDG/DesktopEntry.hs
new file mode 100644
index 0000000..5217395
--- /dev/null
+++ b/src/Network/URI/XDG/DesktopEntry.hs
@@ -0,0 +1,74 @@
+module Network.URI.XDG.DesktopEntry(launchApp) where
+
+import Data.Maybe (fromMaybe, catMaybes)
+import Control.Exception (catch)
+import System.Environment (lookupEnv)
+import Control.Monad (forM)
+import System.Directory (doesFileExist)
+import System.FilePath
+
+import Network.URI
+import System.Process (spawnCommand)
+
+import Network.URI.XDG.Ini
+import Network.URI.XDG.MimeApps (split, fromMaybe')
+
+launchApp :: [String] -- ^ The locale to use
+             -> URI -- ^ The URI to have it open.
+             -> String -- ^ The .desktop ID
+             -> IO (Maybe String) -- ^ The localized name of the application
+launchApp locales uri desktopID = do
+    app <- readDesktopID desktopID
+    let grp = "desktop entry"
+    let name = fromMaybe desktopID $ iniLookupLocalized locales grp "name" app
+    case (iniLookup grp "type" app, iniLookup grp "exec" app) of
+        (Just "Application", Just exec) ->
+            catch (execApp uri exec name app) execFailed
+        _ -> return Nothing
+
+readDesktopID desktopID = do
+    dirs <- lookupEnv "XDG_DATA_DIRS"
+    let dirs' = split ':' $ fromMaybe' "/usr/local/share/:/usr/share/" dirs
+    filepaths <- forM (filter (/= "") dirs') $ \dir -> do
+        exists <- doesFileExist (dir </> "applications" </> desktopID)
+        if exists then
+            return $ Just (dir </> "applications" </> desktopID)
+        else
+            return Nothing -- TODO? Handle cases where - = subdirectory path?
+    case catMaybes filepaths of
+        (filepath:_) -> do
+            source <- readFile filepath
+            let metadata = (" ", ["filename", filepath]) -- Used by %k macro
+            return (parseIni source)
+        [] -> return []
+
+-- Capitals usually means supports multiple arguments,
+-- but HURL doesn't support making use of that.
+macros uri@URI {uriScheme="file:", uriPath=f} ('%':'f':cmd) x = esc f ++ macros uri cmd x
+macros uri@URI {uriScheme="file:", uriPath=f} ('%':'F':cmd) x = esc f ++ macros uri cmd x
+macros uri ('%':'u':cmd) x = esc uri ++ macros uri cmd x
+macros uri ('%':'U':cmd) x = esc uri ++ macros uri cmd x
+macros uri ('%':'i':cmd) (app, name)
+    | Just icon <- iniLookup "desktop entry" "icon" app =
+        "--icon " ++ esc icon ++ macros uri cmd (app, name)
+    | otherwise = macros uri cmd (app, name)
+macros uri ('%':'c':cmd) (app, name) = esc name ++ macros uri cmd (app, name)
+macros uri ('%':'k':cmd) (app, name)
+    | Just file <- iniLookup " " "filename" app = esc file ++ macros uri cmd (app, name)
+    | otherwise = macros uri cmd (app, name)
+macros uri ('%':'%':cmd) x = '%' : macros uri cmd x
+macros uri (c:cmd) x = c : macros uri cmd x
+macros _ [] _ = []
+
+esc txt = '\'' : esc' (show txt)
+esc' ('\'':cs) = '\\' : '\'' : esc' cs
+esc' (c:cs) = c : esc' cs
+esc' [] = "'"
+
+execApp :: URI -> String -> String -> INI -> IO (Maybe String)
+execApp uri exec name app = do
+    spawnCommand $ macros uri exec (app, name)
+    return $ Just name
+
+execFailed :: IOError -> IO (Maybe String)
+execFailed _ = return Nothing
diff --git a/src/Network/URI/XDG/Ini.hs b/src/Network/URI/XDG/Ini.hs
index 7e72f5c..476c807 100644
--- a/src/Network/URI/XDG/Ini.hs
+++ b/src/Network/URI/XDG/Ini.hs
@@ -16,7 +16,7 @@ isComment "" = True
 isComment _ = False
 
 parseIni' (('[':cs):lines) | ']':header <- reverse cs =
-    let (keys, rest) = parseKeys lines in (reverse header, keys) : parseIni' rest
+    let (keys, rest) = parseKeys lines in (strip $ reverse header, keys) : parseIni' rest
 parseIni' _ = []
 
 parseKeys :: [String] -> ([(String, String)], [String])
diff --git a/src/Network/URI/XDG/MimeApps.hs b/src/Network/URI/XDG/MimeApps.hs
index 168babf..7fbad34 100644
--- a/src/Network/URI/XDG/MimeApps.hs
+++ b/src/Network/URI/XDG/MimeApps.hs
@@ -1,4 +1,4 @@
-module Network.URI.XDG.MimeApps(HandlersConfig, loadHandlers, queryHandlers) where
+module Network.URI.XDG.MimeApps(HandlersConfig, loadHandlers, queryHandlers, split, fromMaybe') where
 
 import System.Environment (lookupEnv)
 import Control.Monad (forM)
-- 
2.30.2