{- |
   Module      : Distribution.Gentoo.GHC
   Description : Find GHC-related breakages on Gentoo.
   Copyright   : (c) Ivan Lazar Miljenovic 2009
   License     : GPL-2 or later

   This module defines helper functions to find broken packages in
   GHC, or else find packages installed with older versions of GHC.
 -}

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}

module Distribution.Gentoo.GHC
       ( -- * Misc
         CabalPV(..)
       , ghcVersion
       , ghcLoc
       , ghcLibDir
         -- * MonadPkgState
       , MonadPkgState(..)
       ) where

import Distribution.Gentoo.Env
import Distribution.Gentoo.Util
import Distribution.Gentoo.Packages

-- Cabal imports
import qualified Distribution.Simple.Utils as DSU
import Distribution.Verbosity(silent)
import Distribution.Package(mungedId)
import Distribution.InstalledPackageInfo
    (InstalledPackageInfo(sourceLibName), parseInstalledPackageInfo)
import Distribution.Text(display)
import Distribution.Types.LibraryName (LibraryName(..))

-- Other imports
import Control.Monad.Reader (ReaderT)
import Control.Monad.State.Strict (StateT, lift)
import Data.Char(isDigit)
import Data.Either(partitionEithers)
import Data.Maybe
import qualified Data.List as L
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BL8
import System.FilePath((</>), takeExtension, pathSeparator)
import System.Directory( canonicalizePath
                       , doesDirectoryExist
                       , findExecutable
                       , listDirectory )
import Control.Monad
import Control.Monad.IO.Class

import Output

-- -----------------------------------------------------------------------------

-- Common helper utils, etc.

-- | Get only the first line of output
rawSysStdOutLine     :: FilePath -> [String] -> IO String
rawSysStdOutLine app args = do
    out <- rawCommand app args
    case lines out of
        [] -> error $ unwords
            [ "rawSysStdOutLine: Empty output from rawCommand"
            , show app, show args ]
        (s:_) -> pure s

rawCommand          :: FilePath -> [String] -> IO String
rawCommand cmd args = do (out,_,_) <- DSU.rawSystemStdInOut
                                                        silent  -- verbosity
                                                        cmd     -- program loc
                                                        args    -- args
#if MIN_VERSION_Cabal(1,18,0)
                                                        Nothing -- cabal-1.18+: new working dir
                                                        Nothing -- cabal-1.18+: new environment
#endif /* MIN_VERSION_Cabal(1,18,0) */
                                                        Nothing -- input text and binary mode
#if MIN_VERSION_Cabal(2,1,0)
                                                        DSU.IODataModeBinary
#else
                                                        False   -- is output in binary mode
#endif /* MIN_VERSION_Cabal(2,1,0) */
#if MIN_VERSION_Cabal(3,2,0)
                         return (BL8.unpack out)
#elif MIN_VERSION_Cabal(2,1,0)
                         case out of
                             ~(DSU.IODataBinary bs) -> return (BL8.unpack bs)
#else
                         return out
#endif /* MIN_VERSION_Cabal(2,1,0) */

-- | Get the first line of output from calling GHC with the given
--   arguments.
ghcRawOut      :: [String] -> IO String
ghcRawOut args = ghcLoc >>= flip rawSysStdOutLine args

-- | Cheat with using fromJust since we know that GHC must be in $PATH
--   somewhere, probably /usr/bin.
ghcLoc :: IO FilePath
ghcLoc = fromJust <$> findExecutable "ghc"

-- | The version of GHC installed.
ghcVersion :: IO String
ghcVersion = dropWhile (not . isDigit) <$> ghcRawOut ["--version"]

-- | The directory where GHC has all its libraries, etc.
ghcLibDir :: IO FilePath
ghcLibDir = canonicalizePath =<< ghcRawOut ["--print-libdir"]

ghcPkgRawOut      :: [String] -> IO String
ghcPkgRawOut args = ghcPkgLoc >>= flip rawCommand args

-- | Cheat with using fromJust since we know that ghc-pkg must be in $PATH
--   somewhere, probably /usr/bin.
ghcPkgLoc :: IO FilePath
ghcPkgLoc = fromJust <$> findExecutable "ghc-pkg"

ghcConfsPath, gentooConfsPath :: FilePath
ghcConfsPath = "package.conf.d"
gentooConfsPath = "gentoo"

-- | Return the Gentoo .conf files found in this GHC libdir
listConfFiles :: FilePath -> IO [FilePath]
listConfFiles subdir = do
    dir <- ghcLibDir
    let gDir = dir </> subdir
    exists <- doesDirectoryExist gDir
    if exists
        then do conts <- listDirectory gDir
                return $ map (gDir </>)
                    $ filter isConf conts
        else return []
  where
    isConf file = takeExtension file == ".conf"

-- | String representation of a package and version from Cabal
newtype CabalPV = CPV { unCPV :: String } -- serialized 'PackageIdentifier'
    deriving (Ord, Eq, Show)

-- | Unique (normal) or multiple (broken) mapping
type ConfMap = Map.Map CabalPV [FilePath]

-- | Fold Gentoo .conf files from the current GHC version and
--   create a Map
foldConf :: (MonadSay m, MonadIO m) => [FilePath] -> m ConfMap
foldConf = foldM addConf Map.empty

-- | cabal package text format
--   @"[InstalledPackageInfo {installedPackageId = Insta..."@
parse_as_cabal_package :: BS.ByteString -> Maybe InstalledPackageInfo
parse_as_cabal_package cont =
    case parseInstalledPackageInfo cont of
        Left _es -> Nothing
        Right (_ws, ipi) -> Just ipi

-- | ghc package text format
--   @
--       "name: zlib-conduit\n
--       version: 1.1.0\n
--       id: zlib-condui..."
--   @
parse_as_ghc_package :: BS.ByteString -> Maybe CabalPV
parse_as_ghc_package cont =
    case (map BS.words . BS.lines) cont of
        ( [name_key, bn] : [ver_key, bv] : _)
            | name_key == BS.pack "name:" && ver_key == BS.pack "version:"
            -> Just $ CPV $ BS.unpack bn ++ "-" ++ BS.unpack bv
        _   -> Nothing

-- | Add this .conf file to the Map
--
--   NOTE: It is important that the 'CabalPV's that are added to the 'ConfMap'
--   should be in their "munged form", which may be z-encoded
--
--   See:
--     * <https://hackage.haskell.org/package/Cabal-syntax-3.12.0.0/docs/Distribution-Types-MungedPackageName.html>
--     * <https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/symbol-names>
addConf :: (MonadSay m, MonadIO m) => ConfMap -> FilePath -> m ConfMap
addConf cmp conf = do
    bs <- liftIO $ BS.readFile conf
    case
        ( BS.null bs
        , parse_as_ghc_package bs
        , parse_as_cabal_package bs
        ) of
            -- empty files are created for
            -- phony packages like CABAL_CORE_LIB_GHC_PV
            -- and binary-only packages.
            (True, _      , _       ) -> pure cmp
            -- 'parse_as_ghc_package' is more efficient, so try it first
            (_   , Just dn, _       ) -> do
                vsay $ unwords [conf, "resolved as ghc package:", show dn]
                pure $ pushConf cmp dn conf
            -- 'parse_as_cabal_package' is more flexible, so use it as a fallback
            (_   , _      , Just ipi) -> do
                let cpv = toCPV ipi
                vsay $ unwords [conf, "resolved as cabal package:", show (cpv, ipi)]
                pure $ pushConf cmp cpv conf
            _                         -> do
                say $ unwords
                    [ "failed to parse", show conf, ":", show (BS.take 30 bs)]
                return cmp
  where
    pushConf :: ConfMap -> CabalPV -> FilePath -> ConfMap
    pushConf m k fp = Map.insertWith (++) k [fp] m

    -- 'MungedPackageId's get displayed using the z-encoded format, so are
    -- compatible with ghc-pkg. This is important for resolving broken packages
    -- (reported by ghc-pkg) to @.conf@ files!
    toCPV :: InstalledPackageInfo -> CabalPV
    toCPV = CPV . display . mungedId

checkPkgs :: (MonadSay m, MonadIO m)
             => ([CabalPV], [FilePath])
             -> m ([Package],[CabalPV],[FilePath])
checkPkgs (pns, gentoo_cnfs) = do
       files_to_pkgs <- liftIO $ resolveFiles gentoo_cnfs
       let (gentoo_files, pkgs) = unzip $ Set.toList files_to_pkgs
           orphan_gentoo_files = gentoo_cnfs L.\\ gentoo_files
       vsay $ unwords [ "checkPkgs: searching for gentoo .conf orphans"
                      , show (length orphan_gentoo_files)
                      , "of"
                      , show (length gentoo_cnfs)
                      ]
       return (pkgs, pns, orphan_gentoo_files)

-- -----------------------------------------------------------------------------

-- | Monads that can retrieve the state of Haskell packages on the
--   system (or other database).
--
--   This is primarily used with the 'Env' monad. Making this a class helps
--   with the creation of test mockups.
class Monad m => MonadPkgState m where
    -- | Finding packages installed with other versions of GHC
    oldGhcPkgs :: m (Set.Set Package)

    -- | Finding broken packages in this install of GHC.
    brokenPkgs :: m ([Package],[CabalPV],[FilePath])

    -- | All registered Haskell packages on the system
    allInstalledPkgs :: m (Set.Set Package)


instance MonadIO m => MonadPkgState (EnvT m) where
    oldGhcPkgs =
        do thisGhc <- liftIO ghcLibDir
           vsay $ "oldGhcPkgs ghc lib: " ++ show thisGhc
           let thisGhc' = BS.pack thisGhc
           -- It would be nice to do this, but we can't assume
           -- some crazy user hasn't deleted one of these dirs
           -- libFronts' <- filterM doesDirectoryExist libFronts
           notGHC <$> checkLibDirs thisGhc' libFronts

    brokenPkgs = brokenConfs >>= checkPkgs

    allInstalledPkgs = do libDir <- liftIO ghcLibDir
                          let libDir' = BS.pack libDir
                          fmap notGHC $ liftIO $ pkgsHaveContent
                                $ hasDirMatching (==libDir')

instance MonadPkgState m => MonadPkgState (StateT s m) where
    oldGhcPkgs = lift oldGhcPkgs
    brokenPkgs = lift brokenPkgs
    allInstalledPkgs = lift allInstalledPkgs

instance MonadPkgState m => MonadPkgState (ReaderT r m) where
    oldGhcPkgs = lift oldGhcPkgs
    brokenPkgs = lift brokenPkgs
    allInstalledPkgs = lift allInstalledPkgs

-- | Find packages installed by other versions of GHC in this possible
--   library directory.
checkLibDirs :: (MonadSay m, MonadIO m)
    => BSFilePath -> [BSFilePath] -> m (Set.Set Package)
checkLibDirs thisGhc libDirs =
    do vsay $ "checkLibDir ghc libs: " ++ show (thisGhc, libDirs)
       liftIO $ pkgsHaveContent (hasDirMatching wanted)
  where
    wanted dir = isValid dir && (not . isInvalid) dir

    isValid dir = any (`isGhcLibDir` dir) libDirs

#if MIN_VERSION_bytestring(0,11,1)
    -- Correct the path for hadrian-based installations
    -- See https://github.com/gentoo-haskell/haskell-updater/issues/20
    thisGhc' = if BS.isSuffixOf (BS.pack "/lib") thisGhc then BS.dropEnd 4 thisGhc else thisGhc

    -- Invalid if it's this GHC
    isInvalid fp = fp == thisGhc' || BS.isPrefixOf (thisGhc' `BS.snoc` pathSeparator) fp
#else
    -- Versions of GHC with old 'bytestring' can use the old behavior
    isInvalid fp = fp == thisGhc || BS.isPrefixOf (thisGhc `BS.snoc` pathSeparator) fp
#endif

-- | A valid GHC library directory starting at libdir has a name of
--   "ghc", then a hyphen and then a version number.
isGhcLibDir :: BSFilePath -> BSFilePath -> Bool
isGhcLibDir libdir dir = go ghcDirName
  where
    -- This is hacky because FilePath doesn't work on Bytestrings...
    libdir' = BS.snoc libdir pathSeparator
    ghcDirName = BS.pack "ghc"

    go dn = BS.isPrefixOf ghcDir dir
            -- Any possible version starts with a digit
            && isDigit (BS.index dir ghcDirLen)
      where
        ghcDir = flip BS.snoc '-' $ BS.append libdir' dn
        ghcDirLen = BS.length ghcDir


-- | The possible places GHC could have installed lib directories
libFronts :: [BSFilePath]
libFronts = map BS.pack
            $ do lib <- ["lib", "lib64"]
                 return $ "/" </> "usr" </> lib

-- -----------------------------------------------------------------------------

-- | .conf files from broken packages of this GHC version
--   Returns two lists:
--       * @[CabalPV]@ - list of broken cabal packages we could not resolve
--                       to Gentoo's .conf files
--       * @[FilePath]@ - list of '.conf' files resolved from broken
--                        CabalPV reported by 'ghc-pkg check'
brokenConfs :: (MonadSay m, MonadIO m) => m ([CabalPV], [FilePath])
brokenConfs =
    do vsay "brokenConfs: getting broken output from 'ghc-pkg'"
       ghc_pkg_brokens <- liftIO getBrokenGhcPkg
       vsay $ unwords ["brokenConfs: resolving Cabal package names to gentoo equivalents."
                      , show (length ghc_pkg_brokens)
                      , "Cabal packages are broken:"
                      , unwords $ map unCPV ghc_pkg_brokens
                      ]

       (orphan_broken, orphan_confs) <- liftIO getOrphanBroken
       vsay $ unwords [ "brokenConfs: ghc .conf orphans:"
                      , show (length orphan_broken)
                      , "are orphan:"
                      , unwords $ map unCPV orphan_broken
                      ]

       installed_but_not_registered <- getNotRegistered
       vsay $ unwords [ "brokenConfs: ghc .conf not registered:"
                      , show (length installed_but_not_registered)
                      , "are not registered:"
                      , unwords $ map unCPV installed_but_not_registered
                      ]

       registered_twice <- getRegisteredTwice
       vsay $ unwords [ "brokenConfs: ghc .conf registered twice:"
                      , show (length registered_twice)
                      , "are registered twice:"
                      , unwords $ map unCPV registered_twice
                      ]

       let all_broken = concat [ ghc_pkg_brokens
                               , orphan_broken
                               , installed_but_not_registered
                               , registered_twice
                               ]

       vsay "brokenConfs: reading '*.conf' files"
       cnfs <- liftIO (listConfFiles gentooConfsPath) >>= foldConf
       vsay $ "brokenConfs: got " ++ show (Map.size cnfs) ++ " '*.conf' files"
       let (known_broken, orphans) = partitionEithers $ map (matchConf cnfs) all_broken
       return (known_broken, orphan_confs ++ L.concat orphans)
  where
    -- Attempt to match the provided broken package to one of the
    -- installed packages.
    matchConf :: ConfMap -> CabalPV -> Either CabalPV [FilePath]
    matchConf cmp cpv =
        case Map.lookup cpv cmp of
            Just fps -> Right fps
            Nothing -> Left cpv

-- | Return the closure of all packages affected by breakage
--   in format of ["name-version", ... ]
getBrokenGhcPkg :: IO [CabalPV]
getBrokenGhcPkg = map CPV . words
                  <$> ghcPkgRawOut ["check", "--simple-output"]

getOrphanBroken :: IO ([CabalPV], [FilePath])
getOrphanBroken = do
       -- Around Jan 2015 we have started to install
       -- all the .conf files in 'src_install()' phase.
       -- Here we pick orphan ones and notify user about it.
       registered_confs <- listConfFiles ghcConfsPath
       confs_to_pkgs <- resolveFiles registered_confs
       let (conf_files, _conf_pkgs) = unzip $ Set.toList confs_to_pkgs
           orphan_conf_files = registered_confs L.\\ conf_files
       orphan_packages <- fmap catMaybes $
                              forM orphan_conf_files $
                                  fmap parse_as_ghc_package . BS.readFile
       return (orphan_packages, orphan_conf_files)

-- | Return packages, that seem to have
--   been installed via emerge (have gentoo/.conf entry),
--   but are not registered in package.conf.d.
--   Usually happens on manual cleaning or
--   due to unregistration bugs in old eclass.
getNotRegistered :: (MonadSay m, MonadIO m) => m [CabalPV]
getNotRegistered = do
    installed_confs  <- liftIO (listConfFiles gentooConfsPath) >>= foldConf
    registered_confs <- liftIO (listConfFiles ghcConfsPath) >>= foldConf
    return $ Map.keys installed_confs L.\\ Map.keys registered_confs

-- | Return packages, that seem to have
--   been installed more, than once.
--   It usually happens this way:
--       1. user installs dev-lang/ghc-7.8.4-r0 (comes with bundled @transformers-3.0.0.0-ghc-7.8.4-{abi}.conf@)
--       2. user installs dev-haskell/transformers-0.4.3.0 (registered as @transformers-0.4.3.0-{abi}.conf@)
--       3. user upgrades up to dev-lang/ghc-7.8.4-r4 (comes with bundled @transformers-0.4.3.0-ghc-7.8.4-{abi}.conf@)
--   this way we have single package registered twice:
--       * @transformers-0.4.3.0-ghc-7.8.4-{abi}.conf@
--       * @transformers-0.4.3.0-{abi}.conf@
--   It's is easy to fix just by reinstalling transformers.
getRegisteredTwice :: (MonadSay m, MonadIO m) => m [CabalPV]
getRegisteredTwice = do
    registered_confs <- liftIO (listConfFiles ghcConfsPath) >>= foldConf
    let registered_twice = Map.filter (\fs -> length fs > 1) registered_confs

    -- Double check that all of the "duplicates" are main libraries, since
    -- a package may also have one or more sub-libraries registered as
    -- well.
    rtMainLibs <- foldM
        (\m k -> Map.alterF (liftIO . onlyMultipleMains) k m)
        registered_twice
        (Map.keys registered_twice)

    return $ Map.keys rtMainLibs
  where
    -- Filter out all but entries with multiple main libraries
    onlyMultipleMains :: Maybe [FilePath] -> IO (Maybe [FilePath])
    onlyMultipleMains (Just fps@(_:_)) = do
        fps' <- filterM filterMain fps
        -- Remove entries with one or less elements, since they are no longer
        -- relevant to the getRegisteredTwice function
        pure $ if length fps' <= 1 then Nothing else Just fps'
    onlyMultipleMains _ = pure Nothing

    -- Only keep conf files that correspond to main libraries. This runs
    -- 'parse_as_cabal_package' to get
    filterMain :: FilePath -> IO Bool
    filterMain conf = do
        bs <- BS.readFile conf
        let ipi = parse_as_cabal_package bs
        pure $ case sourceLibName <$> ipi of
            Just LMainLibName -> True
            _ -> False

-- -----------------------------------------------------------------------------