packages feed

hurl 1.0.0.0 → 1.1.0.0

raw patch · 6 files changed

+229/−8 lines, 6 filesdep +directorydep +filepathdep +process

Dependencies added: directory, filepath, process

Files

hurl.cabal view
@@ -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
src/Network/URI/Fetch.hs view
@@ -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)
src/Network/URI/Messages.hs view
@@ -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
+ src/Network/URI/XDG/DesktopEntry.hs view
@@ -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
+ src/Network/URI/XDG/Ini.hs view
@@ -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
+ src/Network/URI/XDG/MimeApps.hs view
@@ -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 _ [] = [[]]