{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
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 )
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"
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')
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
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
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
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)
ghcPkgPathEnvVar :: WhichCompiler -> Text
ghcPkgPathEnvVar :: WhichCompiler -> Text
ghcPkgPathEnvVar WhichCompiler
Ghc = Text
"GHC_PACKAGE_PATH"
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
findGhcPkgField ::
(HasProcessContext env, HasTerm env)
=> GhcPkgExe
-> [Path Abs Dir]
-> String
-> 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
unregisterGhcPkgIds ::
(HasProcessContext env, HasTerm env)
=> GhcPkgExe
-> Path Abs Dir
-> 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
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]
]