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

-- | Functions for the GHC package database.


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

import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as BL
import qualified Data.List as L
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import           Path ( (</>), parent )
import           Path.Extra ( toFilePathNoTrailingSep )
import           Path.IO
                   ( doesDirExist, doesFileExist, ensureDir, resolveDir' )
import           RIO.Process ( HasProcessContext, proc, readProcess_ )
import           Stack.Constants ( relFilePackageCache )
import           Stack.Prelude
import           Stack.Types.Compiler ( WhichCompiler (..) )
import           Stack.Types.CompilerPaths ( GhcPkgExe (..) )
import           Stack.Types.GhcPkgId ( GhcPkgId, ghcPkgIdString )
import           System.FilePath ( searchPathSeparator )

-- | Get the global package database

getGlobalDB ::
     (HasProcessContext env, HasTerm env)
  => GhcPkgExe
  -> RIO env (Path Abs Dir)
getGlobalDB :: forall env.
(HasProcessContext env, HasTerm env) =>
GhcPkgExe -> RIO env (Path Abs Dir)
getGlobalDB GhcPkgExe
pkgexe = do
  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"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

  ByteString
bs <- forall env.
(HasProcessContext env, HasTerm env) =>
GhcPkgExe
-> [Path Abs Dir]
-> [String]
-> RIO env (Either SomeException ByteString)
ghcPkg GhcPkgExe
pkgexe [] [String
"list", String
"--global"] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall (f :: * -> *) a. Applicative f => a -> f a
pure
  let fp :: String
fp = ByteString -> String
S8.unpack forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
stripTrailingColon forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
firstLine ByteString
bs
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
resolveDir' String
fp
 where
  stripTrailingColon :: ByteString -> ByteString
stripTrailingColon ByteString
bs
    | ByteString -> Bool
S8.null ByteString
bs = ByteString
bs
    | ByteString -> Char
S8.last ByteString
bs forall a. Eq a => a -> a -> Bool
== Char
':' = HasCallStack => ByteString -> ByteString
S8.init ByteString
bs
    | Bool
otherwise = ByteString
bs
  firstLine :: ByteString -> ByteString
firstLine = (Char -> Bool) -> ByteString -> ByteString
S8.takeWhile (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
/= Char
'\r' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
'\n')

-- | Run the ghc-pkg executable

ghcPkg ::
     (HasProcessContext env, HasTerm env)
  => GhcPkgExe
  -> [Path Abs Dir]
  -> [String]
  -> RIO env (Either SomeException S8.ByteString)
ghcPkg :: forall env.
(HasProcessContext env, HasTerm env) =>
GhcPkgExe
-> [Path Abs Dir]
-> [String]
-> RIO env (Either SomeException ByteString)
ghcPkg pkgexe :: GhcPkgExe
pkgexe@(GhcPkgExe Path Abs File
pkgPath) [Path Abs Dir]
pkgDbs [String]
args = do
  Either SomeException ByteString
eres <- RIO env (Either SomeException ByteString)
go
  case Either SomeException ByteString
eres of
    Left SomeException
_ -> do
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall env.
(HasProcessContext env, HasTerm env) =>
GhcPkgExe -> Path Abs Dir -> RIO env ()
createDatabase GhcPkgExe
pkgexe) [Path Abs Dir]
pkgDbs
      RIO env (Either SomeException ByteString)
go
    Right ByteString
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Either SomeException ByteString
eres
 where
  pkg :: String
pkg = forall b t. Path b t -> String
toFilePath Path Abs File
pkgPath
  go :: RIO env (Either SomeException ByteString)
go = forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc String
pkg [String]
args' forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_
  args' :: [String]
args' = [Path Abs Dir] -> [String]
packageDbFlags [Path Abs Dir]
pkgDbs forall a. [a] -> [a] -> [a]
++ [String]
args

-- | Create a package database in the given directory, if it doesn't exist.

createDatabase ::
     (HasProcessContext env, HasTerm env)
  => GhcPkgExe
  -> Path Abs Dir
  -> RIO env ()
createDatabase :: forall env.
(HasProcessContext env, HasTerm env) =>
GhcPkgExe -> Path Abs Dir -> RIO env ()
createDatabase (GhcPkgExe Path Abs File
pkgPath) Path Abs Dir
db = do
  Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist (Path Abs Dir
db forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFilePackageCache)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists forall a b. (a -> b) -> a -> b
$ 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.

    Bool
dirExists <- forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
db
    [String]
args <- if Bool
dirExists
      then do
        forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
          [ String -> StyleDoc
flow String
"The package database located at"
          , forall a. Pretty a => a -> StyleDoc
pretty Path Abs Dir
db
          , String -> StyleDoc
flow String
"is corrupted. It is missing its"
          , Style -> StyleDoc -> StyleDoc
style Style
File StyleDoc
"package.cache"
          , String -> StyleDoc
flow String
"file. Stack is proceeding with a recache."
          ]
        forall (f :: * -> *) a. Applicative f => a -> f a
pure [String
"--package-db", forall b t. Path b t -> String
toFilePath Path Abs Dir
db, String
"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

        forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (forall b t. Path b t -> Path b Dir
parent Path Abs Dir
db)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure [String
"init", forall b t. Path b t -> String
toFilePath Path Abs Dir
db]
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc (forall b t. Path b t -> String
toFilePath Path Abs File
pkgPath) [String]
args forall a b. (a -> b) -> a -> b
$ \ProcessConfig () () ()
pc ->
      forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
onException (forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_ ProcessConfig () () ()
pc) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$
          Utf8Builder
"Error: [S-9735]\n" forall a. Semigroup a => a -> a -> a
<>
           Utf8Builder
"Unable to create package database at " forall a. Semigroup a => a -> a -> a
<>
           forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path Abs Dir
db)

-- | Get the environment variable to use for the package DB paths.

ghcPkgPathEnvVar :: WhichCompiler -> Text
ghcPkgPathEnvVar :: WhichCompiler -> Text
ghcPkgPathEnvVar WhichCompiler
Ghc = Text
"GHC_PACKAGE_PATH"

-- | Get the necessary ghc-pkg flags for setting up the given package database

packageDbFlags :: [Path Abs Dir] -> [String]
packageDbFlags :: [Path Abs Dir] -> [String]
packageDbFlags [Path Abs Dir]
pkgDbs =
    String
"--no-user-package-db"
  forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (\Path Abs Dir
x -> String
"--package-db=" forall a. [a] -> [a] -> [a]
++ forall b t. Path b t -> String
toFilePath Path Abs Dir
x) [Path Abs Dir]
pkgDbs

-- | Get the value of a field of the package.

findGhcPkgField ::
     (HasProcessContext env, HasTerm env)
  => GhcPkgExe
  -> [Path Abs Dir] -- ^ package databases

  -> String -- ^ package identifier, or GhcPkgId

  -> Text
  -> RIO env (Maybe Text)
findGhcPkgField :: forall env.
(HasProcessContext env, HasTerm env) =>
GhcPkgExe
-> [Path Abs Dir] -> String -> Text -> RIO env (Maybe Text)
findGhcPkgField GhcPkgExe
pkgexe [Path Abs Dir]
pkgDbs String
name Text
field = do
  Either SomeException ByteString
result <-
    forall env.
(HasProcessContext env, HasTerm env) =>
GhcPkgExe
-> [Path Abs Dir]
-> [String]
-> RIO env (Either SomeException ByteString)
ghcPkg
      GhcPkgExe
pkgexe
      [Path Abs Dir]
pkgDbs
      [String
"field", String
"--simple-output", String
name, Text -> String
T.unpack Text
field]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    case Either SomeException ByteString
result of
      Left{} -> forall a. Maybe a
Nothing
      Right ByteString
bs ->
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text
stripCR forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
S8.lines ByteString
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, HasTerm env)
  => GhcPkgExe
  -> Path Abs Dir -- ^ package database

  -> NonEmpty (Either PackageIdentifier GhcPkgId)
  -> RIO env ()
unregisterGhcPkgIds :: forall env.
(HasProcessContext env, HasTerm env) =>
GhcPkgExe
-> Path Abs Dir
-> NonEmpty (Either PackageIdentifier GhcPkgId)
-> RIO env ()
unregisterGhcPkgIds GhcPkgExe
pkgexe Path Abs Dir
pkgDb NonEmpty (Either PackageIdentifier GhcPkgId)
epgids = do
  Either SomeException ByteString
eres <- forall env.
(HasProcessContext env, HasTerm env) =>
GhcPkgExe
-> [Path Abs Dir]
-> [String]
-> RIO env (Either SomeException ByteString)
ghcPkg GhcPkgExe
pkgexe [Path Abs Dir
pkgDb] [String]
args
  case Either SomeException ByteString
eres of
    Left SomeException
e -> forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$ String -> StyleDoc
string forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> String
displayException SomeException
e
    Right ByteString
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
 where
  ([PackageIdentifier]
idents, [GhcPkgId]
gids) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (Either PackageIdentifier GhcPkgId)
epgids
  args :: [String]
args = String
"unregister" forall a. a -> [a] -> [a]
: String
"--user" forall a. a -> [a] -> [a]
: String
"--force" forall a. a -> [a] -> [a]
:
    forall a b. (a -> b) -> [a] -> [b]
map PackageIdentifier -> String
packageIdentifierString [PackageIdentifier]
idents forall a. [a] -> [a] -> [a]
++
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GhcPkgId]
gids then [] else String
"--ipid" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map GhcPkgId -> String
ghcPkgIdString [GhcPkgId]
gids

-- | Get the value for GHC_PACKAGE_PATH

mkGhcPackagePath :: Bool -> Path Abs Dir -> Path Abs Dir -> [Path Abs Dir] -> Path Abs Dir -> Text
mkGhcPackagePath :: Bool
-> Path Abs Dir
-> Path Abs Dir
-> [Path Abs Dir]
-> Path Abs Dir
-> Text
mkGhcPackagePath Bool
locals Path Abs Dir
localdb Path Abs Dir
deps [Path Abs Dir]
extras Path Abs Dir
globaldb =
  String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
L.intercalate [Char
searchPathSeparator] forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
localdb | Bool
locals]
    , [forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
deps]
    , [forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
db | Path Abs Dir
db <- forall a. [a] -> [a]
reverse [Path Abs Dir]
extras]
    , [forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
globaldb]
    ]