{-# LANGUAGE OverloadedStrings #-}
module Network.URI.XDG.AppStream(loadDatabase, xmlForID) where -- , appsForMIME

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.Concurrent.Async (forConcurrently)
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)

----
-- 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 <- forConcurrently (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
    forConcurrently 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)
    )

----
-- 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 _ [] = []