diff --git a/hurl.cabal b/hurl.cabal --- a/hurl.cabal +++ b/hurl.cabal @@ -10,7 +10,7 @@ -- 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 @@ 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 @@ -96,3 +101,7 @@ 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 --- 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 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 @@ #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,8 +107,27 @@ (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) diff --git a/src/Network/URI/Messages.hs b/src/Network/URI/Messages.hs --- a/src/Network/URI/Messages.hs +++ b/src/Network/URI/Messages.hs @@ -10,9 +10,10 @@ --- 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/DesktopEntry.hs b/src/Network/URI/XDG/DesktopEntry.hs new file mode 100644 --- /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 new file mode 100644 --- /dev/null +++ b/src/Network/URI/XDG/Ini.hs @@ -0,0 +1,45 @@ +module Network.URI.XDG.Ini(INI, parseIni, iniLookup, iniLookupLocalized) where + +import Data.Char (isSpace, toLower) +import Data.List (dropWhile, dropWhileEnd) + +type INI = [(String, [(String, String)])] + +parseIni :: String -> INI +parseIni source = parseIni' $ filter (not . isComment) $ map strip $ lines source + +strip cs = dropWhile isSpace $ dropWhileEnd isSpace $ map toLower cs +strip2 (a, b) = (strip a, strip b) + +isComment ('#':_) = True +isComment "" = True +isComment _ = False + +parseIni' (('[':cs):lines) | ']':header <- reverse cs = + let (keys, rest) = parseKeys lines in (strip $ reverse header, keys) : parseIni' rest +parseIni' _ = [] + +parseKeys :: [String] -> ([(String, String)], [String]) +parseKeys lines@(('[':_):_) = ([], lines) +parseKeys (line:lines) = + let (keys, rest) = parseKeys lines in (strip2 (parseKey line) : keys, rest) +parseKeys [] = ([], []) + +parseKey ('=':as) = ([], as) +parseKey (a:as) = let (x, y) = parseKey as in (a:x, y) +parseKey [] = ([], []) + +--- + +iniLookup :: String -> String -> INI -> Maybe String +iniLookup group key ini = lookup group ini >>= lookup key + +iniLookupLocalized :: [String] -> String -> String -> INI -> Maybe String +iniLookupLocalized (locale:locales) group key ini + | Just ret <- iniLookup group (key ++ "[" ++ locale' ++ "]") ini = Just ret + | otherwise = iniLookupLocalized locales group key ini + where locale' = map dash2under locale +iniLookupLocalized [] group key ini = iniLookup group key ini + +dash2under '-' = '_' +dash2under c = c diff --git a/src/Network/URI/XDG/MimeApps.hs b/src/Network/URI/XDG/MimeApps.hs new file mode 100644 --- /dev/null +++ b/src/Network/URI/XDG/MimeApps.hs @@ -0,0 +1,59 @@ +module Network.URI.XDG.MimeApps(HandlersConfig, loadHandlers, queryHandlers, split, fromMaybe') where + +import System.Environment (lookupEnv) +import Control.Monad (forM) +import System.FilePath +import Data.List (nub, (\\)) +import System.Directory (getHomeDirectory) + +import Network.URI.XDG.Ini + +type HandlersConfig = [INI] + +loadHandlers :: IO HandlersConfig +loadHandlers = do + desktop <- lookupEnv "XDG_CURRENT_DESKTOP" + dir0 <- mimeAppsDirs "XDG_CONFIG" ".config" "/etc/xdg" + dir1 <- mimeAppsDirs "XDG_DATA" ".local/share" "/usr/local/share/:/usr/share/" + let filepaths = mimeAppsFiles (dir0 ++ map ( "applications") dir1) desktop + files <- forM filepaths readFile + return $ map parseIni files + +mimeAppsDirs envPrefix defaultHome defaultDirs = do + home <- lookupEnv (envPrefix ++ "_HOME") + dirs <- lookupEnv (envPrefix ++ "_DIRS") + cwd <- getHomeDirectory + let home' = fromMaybe' (cwd defaultHome) home + let dirs' = fromMaybe' defaultDirs dirs + return (home' : filter (/= "") (split ':' dirs')) + +mimeAppsFiles (dir:dirs) (Just desktop) = (dir desktop ++ "-mimeapps.list") : + (dir "mimeapps.list") : (mimeAppsFiles dirs $ Just desktop) +mimeAppsFiles (dir:dirs) Nothing = (dir "mimeapps.list") : mimeAppsFiles dirs Nothing +mimeAppsFiles [] _ = [] + +--- + +queryHandlers :: HandlersConfig -> String -> [String] +-- TODO Expand MIMEtypes in reference to the local MIMEtypes database. +queryHandlers config mime = nub ( + queryHandlers' "default applications" config mime ++ + (queryHandlers' "added associations" config mime \\ + queryHandlers' "removed associations" config mime) + ) + +queryHandlers' group (config:configs) mime = + queryHandlers'' group config mime ++ queryHandlers' group configs mime +queryHandlers'' group config mime + | Just apps <- iniLookup group mime config = filter (/= "") $ split ';' apps + | otherwise = [] + +--- + +fromMaybe' a (Just "") = a +fromMaybe' _ (Just a) = a +fromMaybe' a Nothing = a + +split b (a:as) | a == b = [] : split b as + | (head':tail') <- split b as = (a:head') : tail' +split _ [] = [[]]