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.2.0.0 +version: 1.3.0.0 -- A short (one-line) description of the package. synopsis: Haskell URL resolver @@ -64,10 +64,15 @@ Manual: True Flag freedesktop - Description: Dispatches unsupported URIs to external apps on FreeDesktop.Org-compatible desktops. Works on most non-mainstream/non-proprietary desktops. + Description: Dispatches unsupported URIs and MIMEtypes to external apps on FreeDesktop.Org-compatible desktops. Works on most non-mainstream/non-proprietary desktops. Default: True Manual: True +Flag appstream + Description: Failing to dispatch URIs and MIMEtypes as per `freedesktop`, consults the local AppStream database to suggest apps to install. Only has an effect if the `freedesktop` is also set. + Default: True + Manual: True + source-repository head type: git location: https://git.nzoss.org.nz/alcinnz/hurl.git @@ -105,3 +110,7 @@ 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, 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, containers + other-modules: Network.URI.XDG.AppStream, Network.URI.XDG.AppStreamOutput 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 @@ -37,7 +37,7 @@ 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 @@ -- 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 @@ #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 @@ #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 diff --git a/src/Network/URI/Locale.hs b/src/Network/URI/Locale.hs --- a/src/Network/URI/Locale.hs +++ b/src/Network/URI/Locale.hs @@ -11,11 +11,12 @@ -- | 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' [] = [] -- 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 _ [] = [[]] 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 @@ -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) = + "

Please install a compatible app to open " ++ linkType ++ " links

\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 (_: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 diff --git a/src/Network/URI/XDG.hs b/src/Network/URI/XDG.hs --- a/src/Network/URI/XDG.hs +++ b/src/Network/URI/XDG.hs @@ -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 diff --git a/src/Network/URI/XDG/AppStream.hs b/src/Network/URI/XDG/AppStream.hs new file mode 100644 --- /dev/null +++ b/src/Network/URI/XDG/AppStream.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.URI.XDG.AppStream( + Component, loadDatabase, xmlForID, buildMIMEIndex, + App(..), Icon(..), IconCache, scanIconCache, appsForMIME +) where + +import qualified Data.Map as M +import qualified Text.XML as XML +import Codec.Compression.GZip (decompress) +import qualified Data.ByteString.Lazy as LBS +import System.Directory +import System.FilePath ((), takeBaseName) +import Control.Exception (catch) +import Control.Monad (forM) +import Data.List (isSuffixOf, sortOn, elemIndex) +import Data.Maybe (catMaybes, mapMaybe, fromMaybe) +import System.Process (callProcess) +import Data.Text (Text) +import qualified Data.Text as Txt +import Text.Read (readMaybe) +import Data.Char (isDigit) + +---- +-- Load in the XML files +---- +type Component = M.Map Text [XML.Element] +cachedir = ".cache/nz.geek.adrian.hurl/appstream/" + +loadDatabase :: [String] -> IO (M.Map Text Component) +loadDatabase locales = do + -- Handle YAML files for Debian-derivatives + sharePaths' <- yaml2xml "/usr/share/app-info/yaml/" "share" `catch` handleListError + cachePaths' <- yaml2xml "/var/cache/app-info/yaml/" "cache" `catch` handleListError + + -- Read in the XML files. + sharePaths <- listDirectory "/usr/share/app-info/xml/" `catch` handleListError + cachePaths <- listDirectory "/var/cache/app-info/xml/" `catch` handleListError + 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 + + -- Index components by ID and their subelements by name + let components = concat $ map getComponents $ catMaybes xmls + let componentsByID = list2map [(getText "id" comp, comp) | comp <- components] + let mergeComponents' = filterMergeAttrs . localizeComponent locales . mergeComponents + let componentByID = M.filter M.null $ M.map mergeComponents' componentsByID + return componentByID + +yaml2xml :: FilePath -> String -> IO [FilePath] +yaml2xml source destSubDir = do + home <- getHomeDirectory + let destDir = home cachedir destSubDir ++ ".xml.gz" + + paths <- listDirectory source + forM paths $ \path -> do + let dest = destDir takeBaseName path + destExists <- doesPathExist dest + + srcTime <- getModificationTime path + destTime <- if destExists then getModificationTime path else return srcTime + if srcTime >= destTime + then callProcess "appstreamcli" ["convert", "--format=xml", path, dest] + else return () + + listDirectory destDir + +getComponents :: XML.Document -> [Component] +getComponents XML.Document { + XML.documentRoot = XML.Element { + XML.elementNodes = nodes + } + } = mapMaybe getComponent nodes +getComponent :: XML.Node -> Maybe Component +getComponent (XML.NodeElement XML.Element { + XML.elementName = XML.Name "component" _ _, + XML.elementAttributes = attrs, + XML.elementNodes = nodes + }) = Just $ list2map ( + [(key, txt2el name val) | (name@(XML.Name key _ _), val) <- M.toList attrs] ++ + [(key, node) | XML.NodeElement node@(XML.Element (XML.Name key _ _) _ _) <- nodes] + ) + where txt2el name txt = XML.Element name M.empty [XML.NodeContent txt] +getComponent _ = Nothing + +mergeComponents :: [Component] -> Component +mergeComponents comps = mergeComponents' $ reverse $ sortOn (getInt "priority") comps +mergeComponents' [] = M.empty +mergeComponents' (comp:comps) = let base = mergeComponents' comps in + case getText "merge" comp of + "append" -> M.unionWith (++) comp base + "replace" -> M.union comp base + "remove-component" -> M.empty + "" -> comp + +localizeComponent :: [String] -> Component -> Component +localizeComponent locales comp = let locales' = map Txt.pack locales in + let locale = bestXMLLocale locales' $ comp2xml comp in + M.filter null $ M.map (mapMaybe $ filterElByLocale locale) comp + +filterMergeAttrs :: Component -> Component +filterMergeAttrs comp = "priority" `M.delete` M.delete "merge" comp + +---- +-- Lookup by ID +---- + +xmlForID :: M.Map Text Component -> Text -> Maybe XML.Element +xmlForID comps id = comp2xml <$> M.lookup id comps + +elementOrder :: [Text] +elementOrder = [ + "id", "pkgname", "source_pkgname", "name", + "project_license", "summary", "description", + "url", "project_group", "icon", + "mimetypes", "categories", "keywords", + "screenshots", + "compulsory_for_desktop", "provides", + "developer_name", "launchable", "releases", + "languages", "bundle", "suggests", + "content_rating", "agreement" + ] + +comp2xml :: Component -> XML.Element +comp2xml comp = XML.Element "component" M.empty $ map XML.NodeElement $ comp2els comp +comp2els :: Component -> [XML.Element] +comp2els comp = concat ( + map (\k -> M.findWithDefault [] k comp) elementOrder ++ + (map snd $ M.toList $ M.filterWithKey (\k v -> k `notElem` elementOrder) comp) + ) + +---- +-- Lookup by MIME +---- + +buildMIMEIndex :: M.Map Text Component -> M.Map Text [Component] +buildMIMEIndex comps = list2map [(mime, comp) | (_, comp) <- M.toList comps, mime <- getMIMEs comp] + +getMIMEs :: Component -> [Text] +getMIMEs comp = let nodes = concat $ map (XML.elementNodes) $ getEls "mimetypes" comp + in filter Txt.null $ map node2txt nodes + +-- + +data App = App { + ident :: Text, + name :: Text, + summary :: Text, + icons :: [Icon] +} +data Icon = Icon { + source :: Text, + width :: Maybe Int, + height :: Maybe Int, + url :: Text +} + +appsForMIME :: IconCache -> M.Map Text [Component] -> Text -> [App] +appsForMIME iconcache comps mime = mapMaybe (comp2app iconcache) $ M.findWithDefault [] mime comps + +comp2app :: IconCache -> Component -> Maybe App +comp2app iconcache comp + | getText "type" comp == "desktop-application" = Just $ App { + ident = getText "id" comp, + name = getText "name" comp, + summary = getText "summary" comp, + icons = sortOn rankIcon $ concat $ map (el2icon iconcache) $ getEls "icon" comp + } + | otherwise = Nothing + where rankIcon icon = source icon `elemIndex` ["stock", "cached", "local", "remote"] + +el2icon :: IconCache -> XML.Element -> [Icon] +el2icon iconcache el@(XML.Element _ attrs _) + | Just "cached" <- "type" `M.lookup` attrs = + [Icon "cached" size size $ Txt.append "file://" $ Txt.pack path + | (size, path) <- lookupCachedIcons iconcache $ el2txt el] +el2icon _ el@(XML.Element _ attrs _) = [Icon { + source = M.findWithDefault "" "type" attrs, + width = parseIntAttr "width", + height = parseIntAttr "height", + url = iconURL el + }] + where parseIntAttr attr = M.lookup attr attrs >>= readMaybe . Txt.unpack + +iconURL el@(XML.Element _ attrs _) = case "type" `M.lookup` attrs of + Just "stock" -> "icon:" `Txt.append` val -- URI scheme NOT implemented + Just "cached" -> "file:///{usr/share,var/cache}/app-info/icons/*/*/" `Txt.append` val -- FIXME, resolve & provide multiple options. + Just "local" -> "file://" `Txt.append` val + Just "remote" -> val + _ -> "about:blank" + where val = el2txt el + +-- AppStream icon cache +type IconCache = [FilePath] +scanIconCache :: IO IconCache +scanIconCache = do + sharePaths <- listDirectory "/usr/share/app-info/icons/" `catch` handleListError + varPaths <- listDirectory "/usr/share/app-info/icons/" + paths <- forM (sharePaths ++ varPaths) (\x -> listDirectory x `catch` handleListError) + return (concat paths ++ sharePaths ++ varPaths) + +lookupCachedIcons :: IconCache -> Text -> [(Maybe Int, FilePath)] +lookupCachedIcons iconcache icon = [(size $ takeBaseName dir, dir Txt.unpack icon) | dir <- iconcache] + where size dirname = readMaybe $ takeWhile isDigit dirname + +---- +-- Supporting utilities +---- +handleListError :: IOError -> IO [a] +handleListError _ = return [] + +-- It's not worth importing Data.Either.Combinators for this. +rightToMaybe :: Either l r -> Maybe r +rightToMaybe (Left _) = Nothing +rightToMaybe (Right x) = Just x + +list2map :: Ord a => [(a, b)] -> M.Map a [b] +list2map = foldr insertEntry M.empty + where insertEntry (key, value) = M.insertWith (++) key [value] + +-- XML Utils + +el2txt :: XML.Element -> Text +el2txt el = Txt.concat $ map node2txt $ XML.elementNodes el +node2txt :: XML.Node -> Text +node2txt (XML.NodeElement el) = el2txt el +node2txt (XML.NodeContent txt) = txt +node2txt _ = "" + +getEls :: Text -> Component -> [XML.Element] +getEls key comp = M.findWithDefault [emptyEl] key comp +getEl :: Text -> Component -> XML.Element +getEl key comp | ret:_ <- getEls key comp = ret + | otherwise = emptyEl +getText :: Text -> Component -> Text +getText key comp = el2txt $ getEl key comp +getInt :: Text -> Component -> Integer +getInt key comp = fromMaybe 0 $ readMaybe $ Txt.unpack $ getText key comp +emptyEl :: XML.Element +emptyEl = XML.Element "placeholder" M.empty [] + +bestXMLLocale :: [Text] -> XML.Element -> Text +bestXMLLocale locales (XML.Element _ attrs nodes) + | Just locale <- "xml:lang" `M.lookup` attrs = locale + | locale:_ <- sortOn rankLocale [bestXMLLocale locales el + | XML.NodeElement el <- nodes] = locale + | otherwise = "" + where rankLocale locale = locale `elemIndex` locales + +filterElByLocale :: Text -> XML.Element -> Maybe XML.Element +filterElByLocale locale el@(XML.Element _ attrs nodes) + | Just locale' <- "xml:lang" `M.lookup` attrs, locale' /= locale = Nothing + | otherwise = Just $ el {XML.elementNodes = filterNodesByLocale locale nodes} +filterNodesByLocale :: Text -> [XML.Node] -> [XML.Node] +filterNodesByLocale locale (XML.NodeElement el:nodes) + | Just el' <- filterElByLocale locale el = XML.NodeElement el' : filterNodesByLocale locale nodes + | otherwise = filterNodesByLocale locale nodes +filterNodesByLocale locale (node:nodes) = node : filterNodesByLocale locale nodes +filterNodesByLocale _ [] = [] diff --git a/src/Network/URI/XDG/AppStreamOutput.hs b/src/Network/URI/XDG/AppStreamOutput.hs new file mode 100644 --- /dev/null +++ b/src/Network/URI/XDG/AppStreamOutput.hs @@ -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 = "?"