EMeta.hs

{-|
Module      : Portage.EMeta
License     : GPL-3+
Maintainer  : haskell@gentoo.org

Functions to propagate existing ebuild information
(such as its licence, description, switched flags etc.) to
a new ebuild.
-}
module Portage.EMeta
  ( EMeta(..)
  , findExistingMeta
  , parseExternalDepends
  ) where

import Control.Monad
import Control.Monad.IO.Class
import Data.Char (isSpace)
import qualified Data.List as L
import qualified Data.Monoid as Monoid
import System.Directory (doesDirectoryExist, getDirectoryContents)
import System.FilePath ((</>))
import Text.Printf

import qualified Distribution.Parsec as Cabal

import qualified Merge.Dependencies as Merge
import qualified Portage.Dependency.Types as Portage
import qualified Portage.PackageId as Portage

-- | Extract a value of variable in \'var=\"val\"\' format.
-- There should be exactly one variable assignment in the ebuild.
-- It's a bit of an artificial limitation, but it's common for \'if / else\' blocks.
extract_quoted_string :: FilePath -> String -> String -> Maybe String
extract_quoted_string ebuild_path s_ebuild var_name =
    case filter (L.isPrefixOf var_prefix . ltrim) $ lines s_ebuild of
        []        -> Nothing
        [kw_line] -> up_to_quote $ skip_prefix $ ltrim kw_line
        other     -> bail_out $ printf "strange '%s' assignments:\n%s" var_name (unlines other)

    where ltrim :: String -> String
          ltrim = dropWhile isSpace
          var_prefix = var_name ++ "=\""
          skip_prefix = drop (length var_prefix)
          up_to_quote l = case break (== '"') l of
                              ("", _)  -> Nothing -- empty line
                              (_, "")  -> bail_out $ printf "failed to find closing quote for '%s'" l
                              (val, _) -> Just val
          bail_out :: String -> e
          bail_out msg = error $ printf "%s:extract_quoted_string %s" ebuild_path msg

-- | Extract a value of variable in \'#hackport: var: val\' format.
-- There should be exactly one variable assignment in the ebuild.
extract_hackport_var :: FilePath -> String -> String -> Maybe String
extract_hackport_var ebuild_path s_ebuild var_name =
    case filter (L.isPrefixOf var_prefix) $ lines s_ebuild of
        []         -> Nothing
        [var_line] -> Just $ skip_prefix var_line
        other      -> bail_out $ printf "strange '%s' assignmets:\n%s" var_name (unlines other)

    where var_prefix = "#hackport: " ++ var_name ++ ": "
          skip_prefix = drop (length var_prefix)
          bail_out :: String -> e
          bail_out msg = error $ printf "%s:extract_hackport_var %s" ebuild_path msg

-- | Extract the existing keywords from an ebuild.
extractKeywords :: FilePath -> String -> Maybe [String]
extractKeywords ebuild_path s_ebuild =
    words `fmap ` extract_quoted_string ebuild_path s_ebuild "KEYWORDS"

-- | Extract the existing license from an ebuild.
extractLicense :: FilePath -> String -> Maybe String
extractLicense ebuild_path s_ebuild =
    extract_quoted_string ebuild_path s_ebuild "LICENSE"

-- | Extract the existing Cabal flags from an ebuild.
extractCabalFlags :: FilePath -> String -> Maybe String
extractCabalFlags ebuild_path s_ebuild =
    extract_hackport_var ebuild_path s_ebuild "flags"

-- | Extract the existing description from an ebuild.
extractDescription :: FilePath -> String -> Maybe String
extractDescription ebuild_path s_ebuild =
    extract_quoted_string ebuild_path s_ebuild "DESCRIPTION"

-- | Extract information on external dependencies that cannot be specified in
--   the .cabal file.
extractExternalDepends :: FilePath -> String -> Maybe String
extractExternalDepends ebuild_path s_ebuild =
    extract_hackport_var ebuild_path s_ebuild "external-depends"

-- | Parse @external-depends@ string from ebulds. These can be added to an
--   existing 'Merge.EDep' using its 'Semigroup' instance.
--
--   Example of valid input:
--
--   @@@
--   "rdepend:app-misc/foo,depend:app-misc/bar"
--   @@@
--
--   NOTE: This does not currently support flags or version ranges on the atoms

parseExternalDepends :: String -> Either String Merge.EDep
parseExternalDepends
    = Monoid.getAp
    . foldMap parseEntry
    . finalizeSplit
    . foldr splitOnCommas ([],"")
  where
    finalizeSplit :: ([String], String) -> [String]
    finalizeSplit (results,"") = results
    finalizeSplit (results,working) = results ++ [working]

    splitOnCommas :: Char -> ([String],String) -> ([String], String)
    splitOnCommas ',' (results,working) = (results ++ [working], "")
    splitOnCommas  c  (results,working) = (results, c : working)

    parseEntry :: String -> Monoid.Ap (Either String) Merge.EDep
    parseEntry s0 = Monoid.Ap $ case L.span (/= ':') s0 of
        (ls, ':' : rs) -> do

            pkg@(Portage.PackageName _ _) <- Cabal.eitherParsec rs

            let drange = Portage.DRange Portage.ZeroB Portage.InfinityB
                dattr = Portage.DAttr Portage.AnySlot []
                atom = Portage.Atom pkg drange dattr

            f <- case ls of
                "rdepend" -> Right $ \a p -> p { Merge.rdep = a }
                "depend" -> Right $ \a p -> p { Merge.dep = a }
                s -> Left $ "could not parse dependency class: " ++ show s

            pure $ f (Portage.DependAtom atom) mempty

        _ -> Left $ "could not parse entry: " ++ show s0


-- | Type representing the aggregated (best inferred) metadata for a
-- new ebuild of a package.
data EMeta = EMeta { keywords :: Maybe [String]
                   , license  :: Maybe String
                   , cabal_flags :: Maybe String
                   , description :: Maybe String
                   , externalDepends :: Maybe String
                   }

-- | Find the existing package metadata from the last available ebuild.
findExistingMeta :: MonadIO m => FilePath -> m EMeta
findExistingMeta pkgdir = liftIO $ do
    ebuilds <- filter (L.isSuffixOf ".ebuild") <$> do
        b <- doesDirectoryExist pkgdir
        if b
            then getDirectoryContents pkgdir
            else pure []
    -- TODO: version sort
    eMetas <- forM ebuilds $ \e -> do
        let ePath = pkgdir </> e
        eConts <- readFile ePath
        pure EMeta
            { keywords = extractKeywords e eConts
            , license = extractLicense e eConts
            , cabal_flags = extractCabalFlags e eConts
            , description = extractDescription e eConts
            , externalDepends = extractExternalDepends e eConts
            }
    let get_latest candidates = last (Nothing : filter (/= Nothing) candidates)
        aggregated_meta = EMeta
            { keywords = get_latest $ map keywords eMetas
            , license = get_latest $ map license eMetas
            , cabal_flags = get_latest $ map cabal_flags eMetas
            , description = get_latest $ map description eMetas
            , externalDepends = get_latest $ map externalDepends eMetas
            }
    pure aggregated_meta