7 files changed, 153 insertions(+), 36 deletions(-)

M hurl.cabal
M src/Network/URI/Fetch.hs
M src/Network/URI/Locale.hs
M src/Network/URI/Messages.hs
M src/Network/URI/XDG.hs
M src/Network/URI/XDG/AppStream.hs
A src/Network/URI/XDG/AppStreamOutput.hs

@@ 10,7 10,7 @@ name:                hurl
 -- PVP summary:      +-+------- breaking API changes
 --                   | | +----- non-breaking API additions
 --                   | | | +--- code changes with no API change
-version:             1.2.0.0
+version:             1.3.0.0
 
 -- A short (one-line) description of the package.
 synopsis:            Haskell URL resolver


@@ 112,5 112,5 @@ library
     other-modules: Network.URI.XDG.Ini, Network.URI.XDG.MimeApps, Network.URI.XDG.DesktopEntry, Network.URI.XDG
   if flag(freedesktop) && flag(appstream)
     CPP-options:   -DWITH_APPSTREAM
-    build-depends: xml-conduit >=1.8 && < 1.9, zlib >= 0.6 && < 0.7, async >= 2.1.0 && < 2.3.0, containers
-    other-modules: Network.URI.XDG.AppStream
+    build-depends: xml-conduit >=1.8 && < 1.9, zlib >= 0.6 && < 0.7, containers
+    other-modules: Network.URI.XDG.AppStream, Network.URI.XDG.AppStreamOutput

@@ 37,7 37,7 @@ data Session = Session {
     managerHTTP :: HTTP.Manager,
 #endif
 #ifdef WITH_XDG
-    apps :: HandlersConfig,
+    apps :: XDGConfig,
 #endif
     -- | The languages (RFC2616-encoded) to which responses should be localized.
     locale :: [String]


@@ 47,12 47,12 @@ data Session = Session {
 -- if HTTP is enabled.
 newSession :: IO Session
 newSession = do
-    locale' <- rfc2616Locale
+    (ietfLocale, unixLocale) <- rfc2616Locale
 #ifdef WITH_HTTP_URI
     managerHTTP' <- HTTP.newManager TLS.tlsManagerSettings
 #endif
 #ifdef WITH_XDG
-    apps' <- loadHandlers
+    apps' <- loadXDGConfig unixLocale
 #endif
 
     return Session {


@@ 62,7 62,7 @@ newSession = do
 #ifdef WITH_XDG
         apps = apps',
 #endif
-        locale = locale'
+        locale = ietfLocale
     }
 
 -- | Retrieves a URL-identified resource & it's MIMEtype, possibly decoding it's text.


@@ 117,22 117,21 @@ fetchURL _ (defaultMIME:_) uri@URI {uriScheme = "data:"} =
 #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, apps = a} _ uri@(URI {uriScheme = s}) = do
+        app <- dispatchURIByMIME a uri ("x-scheme-handler/" ++ init s)
+        return ("text/html", Left $ Txt.pack $ trans l $ app)
+#else
 fetchURL Session {locale = l} _ URI {uriScheme = scheme} =
     return ("text/plain", Left $ Txt.pack $ trans l $ UnsupportedScheme scheme)
+#endif
 
 dispatchByMIME :: Session -> String -> URI -> IO (Maybe String)
 #if WITH_XDG
-dispatchByMIME Session {locale = l, apps = a} mime uri = dispatchURIByMIME l a uri mime
+dispatchByMIME Session {locale = l, apps = a} mime uri = do
+    err <- dispatchURIByMIME a uri mime
+    return $ case err of
+        UnsupportedMIME _ -> Nothing
+        _ -> Just $ trans l err
 #else
 dispatchByMIME _ _ _ = return Nothing
 #endif

@@ 11,11 11,12 @@ import Data.Char (toLower)
 -- | Returns the languages to which responses should be localized.
 -- Retrieved from Gettext configuration & reformatted for use in the
 -- HTTP Accept-Language request header.
-rfc2616Locale :: IO [String]
+rfc2616Locale :: IO ([String], [String])
 rfc2616Locale = do
     locales <- forM ["LANGUAGE", "LC_ALL", "LC_MESSAGES", "LANG"] lookupEnv
-    let locales' = mapMaybe toRFC2616Lang $ split ':' $ firstJust locales "en_US"
-    return (locales' ++ [l | l <- extractLangs locales', l `notElem` locales'])
+    let posix = split ":" $ firstJust locales "en_US"
+    let ietf = mapMaybe toRFC2616Lang posix
+    return (explode ietf, explode posix)
 
 toRFC2616Lang "C" = Nothing
 toRFC2616Lang ('C':'.':_) = Nothing


@@ 31,14 32,16 @@ toRFC2616Lang' (c:cs) = toLower c : toRFC2616Lang' cs
 toRFC2616Lang' [] = []
 
 -- Makes sure to include the raw languages, and not just localized variants.
-extractLangs (locale:locales) | (lang:_) <- split '-' locale = lang : extractLangs locales
+extractLangs (locale:locales) | (lang:_) <- split "-_.@" locale = lang : extractLangs locales
 extractLangs (_:locales) = extractLangs locales
 extractLangs [] = []
 
+explode locales = locales ++ [l | l <- extractLangs locales, l `notElem` locales]
+
 firstJust (Just a:_) _ | a /= "" = a
 firstJust (_:maybes) fallback = firstJust maybes fallback
 firstJust [] fallback = fallback
 
-split b (a:as) | a == b = [] : split b as
+split b (a:as) | a `elem` b = [] : split b as
         | (head':tail') <- split b as = (a:head') : tail'
 split _ [] = [[]]

@@ 11,13 11,21 @@
 -- Translations between #if WITH_HTTP_URI & #endif are specific to HTTP error handling.
 module Network.URI.Messages (trans, Errors(..)) where
 
+import Data.List (stripPrefix)
+import Data.Maybe (fromMaybe)
+
 #if WITH_HTTP_URI
 import Network.HTTP.Client (HttpException(..), HttpExceptionContent(..))
 import Control.Exception (displayException)
 #endif
 
+trans _ (RawXML markup) = markup
 --- BEGIN LOCALIZATION
 trans ("en":_) (UnsupportedScheme scheme) = "Unsupported protocol " ++ scheme
+trans ("en":_) (UnsupportedMIME mime) = "Unsupported filetype " ++ mime
+trans ("en":_) (RequiresInstall mime appsMarkup) =
+    "<h1>Please install a compatible app to open <code>" ++ linkType ++ "</code> links</h1>\n" ++ appsMarkup
+  where linkType = fromMaybe mime $ stripPrefix "x-scheme-handler/" mime
 trans ("en":_) (OpenedWith app) = "Opened in " ++ app
 trans ("en":_) (ReadFailed msg) = "Failed to read file: " ++ msg
 #if WITH_HTTP_URI


@@ 33,7 41,8 @@ trans ("en":_) (Http (HttpExceptionRequest _ _)) = "The site doesn't appear to s
 trans (_:locales) err = trans locales err
 trans [] err = trans ["en"] err
 
-data Errors = UnsupportedScheme String | OpenedWith String | ReadFailed String
+data Errors = UnsupportedScheme String | UnsupportedMIME String | RequiresInstall String String
+    | OpenedWith String | ReadFailed String | RawXML String
 #if WITH_HTTP_URI
     | Http HttpException
 #endif

@@ 1,15 1,70 @@
-module Network.URI.XDG(HandlersConfig, loadHandlers, canDispatchMIME, dispatchURIByMIME) where
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Network.URI.XDG(XDGConfig, loadXDGConfig, dispatchURIByMIME) where
 
 import Network.URI (URI(..))
+import Network.URI.Messages (Errors(..))
 import Network.URI.XDG.DesktopEntry
 import Network.URI.XDG.MimeApps
+import Data.List (stripPrefix)
 
-canDispatchMIME :: HandlersConfig -> String -> Bool
-canDispatchMIME config mime = not $ null $ queryHandlers config mime
+#if WITH_APPSTREAM
+import qualified Text.XML as XML
+import qualified Data.Map as M
+import Data.Text (Text)
+import qualified Data.Text as Txt
+import Network.URI.XDG.AppStream
+import Network.URI.XDG.AppStreamOutput
+import Control.Monad (forM)
+import Network.URI
+#endif
 
-dispatchURIByMIME :: [String] -> HandlersConfig -> URI -> String -> IO (Maybe String)
-dispatchURIByMIME locales config uri mime =
-    queryHandlers config mime `mapFirstM` launchApp locales uri
+data XDGConfig = XDGConfig {
+#if WITH_APPSTREAM
+    components :: M.Map Text Component,
+    componentsByMIME :: M.Map Text [Component],
+    iconCache :: IconCache,
+#endif
+    handlers :: HandlersConfig,
+    locales :: [String]
+}
+
+loadXDGConfig :: [String] -> IO XDGConfig
+loadXDGConfig locales = do
+    handlers <- loadHandlers
+#if WITH_APPSTREAM
+    components <- loadDatabase locales
+    icons <- scanIconCache
+    return $ XDGConfig components (buildMIMEIndex components) icons handlers locales
+#else
+    return $ XDGConfig handlers locales
+#endif
+
+dispatchURIByMIME :: XDGConfig -> URI -> String -> IO Errors
+dispatchURIByMIME config uri mime = do
+    app <- queryHandlers (handlers config) mime `mapFirstM` launchApp (locales config) uri
+    case app of
+        Just app -> return $ OpenedWith app
+        Nothing -> reportUnsupported config mime uri
+
+reportUnsupported :: XDGConfig -> String -> URI -> IO Errors
+#if WITH_APPSTREAM
+reportUnsupported XDGConfig { components = comps } "x-scheme-handler/appstream" URI {
+        uriAuthority = Just (URIAuth { uriRegName = ident })
+    } | Just el <- xmlForID comps $ Txt.pack ident = return $ RawXML $ serializeXML el
+    | otherwise = return $ UnsupportedScheme "appstream:" -- Could also do a 404...
+reportUnsupported XDGConfig { iconCache = icondirs, componentsByMIME = index } mime _  = do
+    let apps = appsForMIME icondirs index $ Txt.pack mime
+    apps' <- forM apps $ \app -> do
+        icons' <- testLocalIcons $ icons app
+        return $ app {icons = icons'}
+    return $ RequiresInstall mime $ outputApps apps'
+#else
+reportUnsupported _ mime _
+    | Just scheme <- "x-scheme-handler/" `stripPrefix` mime =
+        return $ UnsupportedScheme (scheme ++ ":")
+    | otherwise = return $ UnsupportedMIME mime
+#endif
 
 mapFirstM :: [a] -> (a -> IO (Maybe b)) -> IO (Maybe b)
 mapFirstM (x:xs) cb = do

@@ 1,7 1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Network.URI.XDG.AppStream(
-    loadDatabase, xmlForID, buildMIMEIndex,
-    App(..), Icon(..), appsForMIME
+    Component, loadDatabase, xmlForID, buildMIMEIndex,
+    App(..), Icon(..), IconCache, scanIconCache, appsForMIME
 ) where
 
 import qualified Data.Map as M


@@ 11,7 11,7 @@ import qualified Data.ByteString.Lazy as LBS
 import System.Directory
 import System.FilePath ((</>), takeBaseName)
 import Control.Exception (catch)
-import Control.Concurrent.Async (forConcurrently)
+import Control.Monad (forM)
 import Data.List (isSuffixOf, sortOn, elemIndex)
 import Data.Maybe (catMaybes, mapMaybe, fromMaybe)
 import System.Process (callProcess)


@@ 35,7 35,7 @@ loadDatabase locales = do
     -- Read in the XML files.
     sharePaths <- listDirectory "/usr/share/app-info/xml/" `catch` handleListError
     cachePaths <- listDirectory "/var/cache/app-info/xml/" `catch` handleListError
-    xmls <- forConcurrently (sharePaths ++ sharePaths' ++ cachePaths ++ cachePaths') $ \path -> do
+    xmls <- forM (sharePaths ++ sharePaths' ++ cachePaths ++ cachePaths') $ \path -> do
         text <- LBS.readFile path
         let decompressor = if ".gz" `isSuffixOf` path then decompress else id
         return $ rightToMaybe $ XML.parseLBS XML.def $ decompressor text


@@ 53,7 53,7 @@ yaml2xml source destSubDir = do
     let destDir = home </> cachedir </> destSubDir ++ ".xml.gz"
 
     paths <- listDirectory source
-    forConcurrently paths $ \path -> do
+    forM paths $ \path -> do
         let dest = destDir </> takeBaseName path
         destExists <- doesPathExist dest
 


@@ 196,7 196,7 @@ scanIconCache :: IO IconCache
 scanIconCache = do
     sharePaths <- listDirectory "/usr/share/app-info/icons/" `catch` handleListError
     varPaths <- listDirectory "/usr/share/app-info/icons/"
-    paths <- forConcurrently (sharePaths ++ varPaths) (\x -> listDirectory x `catch` handleListError)
+    paths <- forM (sharePaths ++ varPaths) (\x -> listDirectory x `catch` handleListError)
     return (concat paths ++ sharePaths ++ varPaths)
 
 lookupCachedIcons :: IconCache -> Text -> [(Maybe Int, FilePath)]

@@ 0,0 1,51 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Network.URI.XDG.AppStreamOutput(serializeXML, outputApps, testLocalIcons) where
+
+import qualified Text.XML as XML
+import qualified Data.Map as M
+import Data.Text (Text, append, pack)
+import qualified Data.Text as Txt
+import Data.Text.Lazy (unpack)
+import Network.URI.XDG.AppStream
+
+import Data.List (stripPrefix)
+import Control.Monad (forM)
+import System.Directory (doesFileExist)
+import Data.Maybe (catMaybes)
+
+outputApps apps = serializeXML $ el "p" $ map outputApp apps
+outputApp (App ident' name' summary' icons') =
+    el' "a" [("href", "appstream://" `append` ident'), ("title", summary')] [
+        el "picture" [
+            el' (if i == 0 then "img" else "source") [
+                ("src", url'),
+                ("alt", name' `append` " logo " `append` int2txt width' `append` "x" `append` int2txt height'),
+                ("sizes", int2txt width' `append` "w")] []
+            | (i, Icon _ width' height' url') <- zip [0..] icons'
+        ],
+        XML.Element "caption" M.empty [XML.NodeContent name']]
+
+testLocalIcons icons = do
+    icons' <- forM icons $ \icon -> case "file://" `stripPrefix` Txt.unpack (url icon) of
+        Just path -> do
+            exists <- doesFileExist path
+            return $ if exists then Just icon else Nothing
+        Nothing -> return $ Just icon
+    return $ catMaybes icons'
+
+-- Generic XML/Text utilities
+serializeXML el = unpack $ XML.renderText XML.def XML.Document {
+        XML.documentPrologue = XML.Prologue [] Nothing [],
+        XML.documentRoot = el,
+        XML.documentEpilogue = []
+    }
+
+el' name attrs children = XML.Element {
+        XML.elementName = XML.Name name Nothing Nothing,
+        XML.elementAttributes = M.fromList attrs,
+        XML.elementNodes = map XML.NodeElement children
+    }
+el name children = el' name [] children
+
+int2txt (Just n) = pack $ show n
+int2txt Nothing = "?"