GhcPkg.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Functions for the GHC package database.

module Stack.GhcPkg
  (getGlobalDB
  ,findGhcPkgField
  ,createDatabase
  ,unregisterGhcPkgIds
  ,ghcPkgPathEnvVar
  ,mkGhcPackagePath)
  where

import           Stack.Prelude
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as BL
import           Data.List
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import           Path (parent, (</>))
import           Path.Extra (toFilePathNoTrailingSep)
import           Path.IO
import           Stack.Constants
import           Stack.Types.Config (GhcPkgExe (..))
import           Stack.Types.GhcPkgId
import           Stack.Types.Compiler
import           System.FilePath (searchPathSeparator)
import           RIO.Process

-- | Get the global package database
getGlobalDB
  :: (HasProcessContext env, HasLogFunc env)
  => GhcPkgExe
  -> RIO env (Path Abs Dir)
getGlobalDB pkgexe = do
    logDebug "Getting global package database location"
    -- This seems like a strange way to get the global package database
    -- location, but I don't know of a better one
    bs <- ghcPkg pkgexe [] ["list", "--global"] >>= either throwIO return
    let fp = S8.unpack $ stripTrailingColon $ firstLine bs
    liftIO $ resolveDir' fp
  where
    stripTrailingColon bs
        | S8.null bs = bs
        | S8.last bs == ':' = S8.init bs
        | otherwise = bs
    firstLine = S8.takeWhile (\c -> c /= '\r' && c /= '\n')

-- | Run the ghc-pkg executable
ghcPkg
  :: (HasProcessContext env, HasLogFunc env)
  => GhcPkgExe
  -> [Path Abs Dir]
  -> [String]
  -> RIO env (Either SomeException S8.ByteString)
ghcPkg pkgexe@(GhcPkgExe pkgPath) pkgDbs args = do
    eres <- go
    case eres of
      Left _ -> do
        mapM_ (createDatabase pkgexe) pkgDbs
        go
      Right _ -> return eres
  where
    pkg = toFilePath pkgPath
    go = tryAny $ BL.toStrict . fst <$> proc pkg args' readProcess_
    args' = packageDbFlags pkgDbs ++ args

-- | Create a package database in the given directory, if it doesn't exist.
createDatabase
  :: (HasProcessContext env, HasLogFunc env)
  => GhcPkgExe
  -> Path Abs Dir
  -> RIO env ()
createDatabase (GhcPkgExe pkgPath) db = do
    exists <- doesFileExist (db </> relFilePackageCache)
    unless exists $ do
        -- ghc-pkg requires that the database directory does not exist
        -- yet. If the directory exists but the package.cache file
        -- does, we're in a corrupted state. Check for that state.
        dirExists <- doesDirExist db
        args <- if dirExists
            then do
                logWarn $
                    "The package database located at " <>
                    fromString (toFilePath db) <>
                    " is corrupted (missing its package.cache file)."
                logWarn "Proceeding with a recache"
                return ["--package-db", toFilePath db, "recache"]
            else do
                -- Creating the parent doesn't seem necessary, as ghc-pkg
                -- seems to be sufficiently smart. But I don't feel like
                -- finding out it isn't the hard way
                ensureDir (parent db)
                return ["init", toFilePath db]
        void $ proc (toFilePath pkgPath) args $ \pc ->
          readProcess_ pc `onException`
          logError ("Unable to create package database at " <> fromString (toFilePath db))

-- | Get the environment variable to use for the package DB paths.
ghcPkgPathEnvVar :: WhichCompiler -> Text
ghcPkgPathEnvVar Ghc = "GHC_PACKAGE_PATH"

-- | Get the necessary ghc-pkg flags for setting up the given package database
packageDbFlags :: [Path Abs Dir] -> [String]
packageDbFlags pkgDbs =
          "--no-user-package-db"
        : map (\x -> "--package-db=" ++ toFilePath x) pkgDbs

-- | Get the value of a field of the package.
findGhcPkgField
    :: (HasProcessContext env, HasLogFunc env)
    => GhcPkgExe
    -> [Path Abs Dir] -- ^ package databases
    -> String -- ^ package identifier, or GhcPkgId
    -> Text
    -> RIO env (Maybe Text)
findGhcPkgField pkgexe pkgDbs name field = do
    result <-
        ghcPkg
            pkgexe
            pkgDbs
            ["field", "--simple-output", name, T.unpack field]
    return $
        case result of
            Left{} -> Nothing
            Right bs ->
                fmap (stripCR . T.decodeUtf8) $ listToMaybe $ S8.lines bs

-- | unregister list of package ghcids, batching available from GHC 8.2.1,
-- see https://github.com/commercialhaskell/stack/issues/2662#issuecomment-460342402
-- using GHC package id where available (from GHC 7.9)
unregisterGhcPkgIds
  :: (HasProcessContext env, HasLogFunc env)
  => GhcPkgExe
  -> Path Abs Dir -- ^ package database
  -> NonEmpty (Either PackageIdentifier GhcPkgId)
  -> RIO env ()
unregisterGhcPkgIds pkgexe pkgDb epgids = do
    eres <- ghcPkg pkgexe [pkgDb] args
    case eres of
        Left e -> logWarn $ displayShow e
        Right _ -> return ()
  where
    (idents, gids) = partitionEithers $ toList epgids
    args = "unregister" : "--user" : "--force" :
        map packageIdentifierString idents ++
        if null gids then [] else "--ipid" : map ghcPkgIdString gids

-- | Get the value for GHC_PACKAGE_PATH
mkGhcPackagePath :: Bool -> Path Abs Dir -> Path Abs Dir -> [Path Abs Dir] -> Path Abs Dir -> Text
mkGhcPackagePath locals localdb deps extras globaldb =
  T.pack $ intercalate [searchPathSeparator] $ concat
    [ [toFilePathNoTrailingSep localdb | locals]
    , [toFilePathNoTrailingSep deps]
    , [toFilePathNoTrailingSep db | db <- reverse extras]
    , [toFilePathNoTrailingSep globaldb]
    ]