{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
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
getGlobalDB
:: (HasProcessContext env, HasLogFunc env)
=> GhcPkgExe
-> RIO env (Path Abs Dir)
getGlobalDB :: GhcPkgExe -> RIO env (Path Abs Dir)
getGlobalDB GhcPkgExe
pkgexe = do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Getting global package database location"
ByteString
bs <- GhcPkgExe
-> [Path Abs Dir]
-> [String]
-> RIO env (Either SomeException ByteString)
forall env.
(HasProcessContext env, HasLogFunc env) =>
GhcPkgExe
-> [Path Abs Dir]
-> [String]
-> RIO env (Either SomeException ByteString)
ghcPkg GhcPkgExe
pkgexe [] [String
"list", String
"--global"] RIO env (Either SomeException ByteString)
-> (Either SomeException ByteString -> RIO env ByteString)
-> RIO env ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> RIO env ByteString)
-> (ByteString -> RIO env ByteString)
-> Either SomeException ByteString
-> RIO env ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> RIO env ByteString
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ByteString -> RIO env ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return
let fp :: String
fp = ByteString -> String
S8.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
stripTrailingColon (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
firstLine ByteString
bs
IO (Path Abs Dir) -> RIO env (Path Abs Dir)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Path Abs Dir) -> RIO env (Path Abs Dir))
-> IO (Path Abs Dir) -> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ String -> IO (Path Abs Dir)
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 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':' = ByteString -> ByteString
S8.init ByteString
bs
| Bool
otherwise = ByteString
bs
firstLine :: ByteString -> ByteString
firstLine = (Char -> Bool) -> ByteString -> ByteString
S8.takeWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n')
ghcPkg
:: (HasProcessContext env, HasLogFunc env)
=> GhcPkgExe
-> [Path Abs Dir]
-> [String]
-> RIO env (Either SomeException S8.ByteString)
ghcPkg :: 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
(Path Abs Dir -> RIO env ()) -> [Path Abs Dir] -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (GhcPkgExe -> Path Abs Dir -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env) =>
GhcPkgExe -> Path Abs Dir -> RIO env ()
createDatabase GhcPkgExe
pkgexe) [Path Abs Dir]
pkgDbs
RIO env (Either SomeException ByteString)
go
Right ByteString
_ -> Either SomeException ByteString
-> RIO env (Either SomeException ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Either SomeException ByteString
eres
where
pkg :: String
pkg = Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
pkgPath
go :: RIO env (Either SomeException ByteString)
go = RIO env ByteString -> RIO env (Either SomeException ByteString)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (RIO env ByteString -> RIO env (Either SomeException ByteString))
-> RIO env ByteString -> RIO env (Either SomeException ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, ByteString) -> ByteString)
-> RIO env (ByteString, ByteString) -> RIO env ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> [String]
-> (ProcessConfig () () () -> RIO env (ByteString, ByteString))
-> RIO env (ByteString, ByteString)
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' ProcessConfig () () () -> RIO env (ByteString, ByteString)
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 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args
createDatabase
:: (HasProcessContext env, HasLogFunc env)
=> GhcPkgExe
-> Path Abs Dir
-> RIO env ()
createDatabase :: GhcPkgExe -> Path Abs Dir -> RIO env ()
createDatabase (GhcPkgExe Path Abs File
pkgPath) Path Abs Dir
db = do
Bool
exists <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist (Path Abs Dir
db Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFilePackageCache)
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
Bool
dirExists <- Path Abs Dir -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
db
[String]
args <- if Bool
dirExists
then do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
Utf8Builder
"The package database located at " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
db) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
" is corrupted (missing its package.cache file)."
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Proceeding with a recache"
[String] -> RIO env [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
"--package-db", Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
db, String
"recache"]
else do
Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (Path Abs Dir -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs Dir
db)
[String] -> RIO env [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
"init", Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
db]
RIO env (ByteString, ByteString) -> RIO env ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO env (ByteString, ByteString) -> RIO env ())
-> RIO env (ByteString, ByteString) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ String
-> [String]
-> (ProcessConfig () () () -> RIO env (ByteString, ByteString))
-> RIO env (ByteString, ByteString)
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
MonadIO m, HasCallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
pkgPath) [String]
args ((ProcessConfig () () () -> RIO env (ByteString, ByteString))
-> RIO env (ByteString, ByteString))
-> (ProcessConfig () () () -> RIO env (ByteString, ByteString))
-> RIO env (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ \ProcessConfig () () ()
pc ->
ProcessConfig () () () -> RIO env (ByteString, ByteString)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_ ProcessConfig () () ()
pc RIO env (ByteString, ByteString)
-> RIO env () -> RIO env (ByteString, ByteString)
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`onException`
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder
"Unable to create package database at " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs Dir -> String
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"
String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Path Abs Dir -> String) -> [Path Abs Dir] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\Path Abs Dir
x -> String
"--package-db=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
x) [Path Abs Dir]
pkgDbs
findGhcPkgField
:: (HasProcessContext env, HasLogFunc env)
=> GhcPkgExe
-> [Path Abs Dir]
-> String
-> Text
-> RIO env (Maybe Text)
findGhcPkgField :: 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 <-
GhcPkgExe
-> [Path Abs Dir]
-> [String]
-> RIO env (Either SomeException ByteString)
forall env.
(HasProcessContext env, HasLogFunc 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]
Maybe Text -> RIO env (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> RIO env (Maybe Text))
-> Maybe Text -> RIO env (Maybe Text)
forall a b. (a -> b) -> a -> b
$
case Either SomeException ByteString
result of
Left{} -> Maybe Text
forall a. Maybe a
Nothing
Right ByteString
bs ->
(ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text
stripCR (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8) (Maybe ByteString -> Maybe Text) -> Maybe ByteString -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [ByteString] -> Maybe ByteString
forall a. [a] -> Maybe a
listToMaybe ([ByteString] -> Maybe ByteString)
-> [ByteString] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
S8.lines ByteString
bs
unregisterGhcPkgIds
:: (HasProcessContext env, HasLogFunc env)
=> GhcPkgExe
-> Path Abs Dir
-> NonEmpty (Either PackageIdentifier GhcPkgId)
-> RIO env ()
unregisterGhcPkgIds :: 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 <- GhcPkgExe
-> [Path Abs Dir]
-> [String]
-> RIO env (Either SomeException ByteString)
forall env.
(HasProcessContext env, HasLogFunc 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 -> Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ SomeException -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow SomeException
e
Right ByteString
_ -> () -> RIO env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
([PackageIdentifier]
idents, [GhcPkgId]
gids) = [Either PackageIdentifier GhcPkgId]
-> ([PackageIdentifier], [GhcPkgId])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either PackageIdentifier GhcPkgId]
-> ([PackageIdentifier], [GhcPkgId]))
-> [Either PackageIdentifier GhcPkgId]
-> ([PackageIdentifier], [GhcPkgId])
forall a b. (a -> b) -> a -> b
$ NonEmpty (Either PackageIdentifier GhcPkgId)
-> [Either PackageIdentifier GhcPkgId]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (Either PackageIdentifier GhcPkgId)
epgids
args :: [String]
args = String
"unregister" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"--user" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"--force" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
(PackageIdentifier -> String) -> [PackageIdentifier] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageIdentifier -> String
packageIdentifierString [PackageIdentifier]
idents [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
if [GhcPkgId] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GhcPkgId]
gids then [] else String
"--ipid" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (GhcPkgId -> String) -> [GhcPkgId] -> [String]
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 (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate [Char
searchPathSeparator] ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
localdb | Bool
locals]
, [Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
deps]
, [Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
db | Path Abs Dir
db <- [Path Abs Dir] -> [Path Abs Dir]
forall a. [a] -> [a]
reverse [Path Abs Dir]
extras]
, [Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
globaldb]
]