[WIP] Prototype of recording installed files
This also installs makefile based build system via DESTDIR into a temporary directory and then merges it into the filesystem.
This commit is contained in:
parent
e60b8ee238
commit
48aee1e76c
@ -20,6 +20,7 @@
|
|||||||
- ignore: {name: "Avoid lambda"}
|
- ignore: {name: "Avoid lambda"}
|
||||||
- ignore: {name: "Use uncurry"}
|
- ignore: {name: "Use uncurry"}
|
||||||
- ignore: {name: "Use replicateM"}
|
- ignore: {name: "Use replicateM"}
|
||||||
|
- ignore: {name: "Use unless"}
|
||||||
- ignore: {name: "Redundant irrefutable pattern"}
|
- ignore: {name: "Redundant irrefutable pattern"}
|
||||||
|
|
||||||
|
|
||||||
|
@ -438,6 +438,7 @@ install' _ (_, ListResult {..}) = do
|
|||||||
, FileAlreadyExistsError
|
, FileAlreadyExistsError
|
||||||
, ProcessError
|
, ProcessError
|
||||||
, GHCupShadowed
|
, GHCupShadowed
|
||||||
|
, UninstallFailed
|
||||||
]
|
]
|
||||||
|
|
||||||
run (do
|
run (do
|
||||||
@ -512,7 +513,7 @@ del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnlif
|
|||||||
del' _ (_, ListResult {..}) = do
|
del' _ (_, ListResult {..}) = do
|
||||||
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
|
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
|
||||||
|
|
||||||
let run = runE @'[NotInstalled]
|
let run = runE @'[NotInstalled, UninstallFailed]
|
||||||
|
|
||||||
run (do
|
run (do
|
||||||
let vi = getVersionInfo lVer lTool dls
|
let vi = getVersionInfo lVer lTool dls
|
||||||
|
@ -388,6 +388,7 @@ type GHCEffects = '[ AlreadyInstalled
|
|||||||
, ProcessError
|
, ProcessError
|
||||||
, CopyError
|
, CopyError
|
||||||
, BuildFailed
|
, BuildFailed
|
||||||
|
, UninstallFailed
|
||||||
]
|
]
|
||||||
type HLSEffects = '[ AlreadyInstalled
|
type HLSEffects = '[ AlreadyInstalled
|
||||||
, BuildFailed
|
, BuildFailed
|
||||||
@ -406,6 +407,7 @@ type HLSEffects = '[ AlreadyInstalled
|
|||||||
, NotInstalled
|
, NotInstalled
|
||||||
, DirNotEmpty
|
, DirNotEmpty
|
||||||
, ArchiveResult
|
, ArchiveResult
|
||||||
|
, UninstallFailed
|
||||||
]
|
]
|
||||||
|
|
||||||
|
|
||||||
|
@ -98,7 +98,7 @@ gcFooter = [s|Discussion:
|
|||||||
---------------------------
|
---------------------------
|
||||||
|
|
||||||
|
|
||||||
type GCEffects = '[ NotInstalled ]
|
type GCEffects = '[ NotInstalled, UninstallFailed ]
|
||||||
|
|
||||||
|
|
||||||
runGC :: MonadUnliftIO m
|
runGC :: MonadUnliftIO m
|
||||||
@ -129,7 +129,7 @@ gc :: ( Monad m
|
|||||||
-> (ReaderT LeanAppState m () -> m ())
|
-> (ReaderT LeanAppState m () -> m ())
|
||||||
-> m ExitCode
|
-> m ExitCode
|
||||||
gc GCOptions{..} runAppState runLogger = runGC runAppState (do
|
gc GCOptions{..} runAppState runLogger = runGC runAppState (do
|
||||||
when gcOldGHC rmOldGHC
|
when gcOldGHC (liftE rmOldGHC)
|
||||||
lift $ when gcProfilingLibs rmProfilingLibs
|
lift $ when gcProfilingLibs rmProfilingLibs
|
||||||
lift $ when gcShareDir rmShareDir
|
lift $ when gcShareDir rmShareDir
|
||||||
liftE $ when gcHLSNoGHC rmHLSNoGHC
|
liftE $ when gcHLSNoGHC rmHLSNoGHC
|
||||||
|
@ -257,6 +257,7 @@ type InstallEffects = '[ AlreadyInstalled
|
|||||||
, NoToolVersionSet
|
, NoToolVersionSet
|
||||||
, FileAlreadyExistsError
|
, FileAlreadyExistsError
|
||||||
, ProcessError
|
, ProcessError
|
||||||
|
, UninstallFailed
|
||||||
|
|
||||||
, (AlreadyInstalled, ())
|
, (AlreadyInstalled, ())
|
||||||
, (UnknownArchive, ())
|
, (UnknownArchive, ())
|
||||||
@ -264,9 +265,9 @@ type InstallEffects = '[ AlreadyInstalled
|
|||||||
, (FileDoesNotExistError, ())
|
, (FileDoesNotExistError, ())
|
||||||
, (CopyError, ())
|
, (CopyError, ())
|
||||||
, (NotInstalled, ())
|
, (NotInstalled, ())
|
||||||
|
, (UninstallFailed, ())
|
||||||
, (DirNotEmpty, ())
|
, (DirNotEmpty, ())
|
||||||
, (NoDownload, ())
|
, (NoDownload, ())
|
||||||
, (NotInstalled, ())
|
|
||||||
, (BuildFailed, ())
|
, (BuildFailed, ())
|
||||||
, (TagNotFound, ())
|
, (TagNotFound, ())
|
||||||
, (DigestError, ())
|
, (DigestError, ())
|
||||||
@ -287,6 +288,7 @@ type InstallEffects = '[ AlreadyInstalled
|
|||||||
, (DirNotEmpty, NotInstalled)
|
, (DirNotEmpty, NotInstalled)
|
||||||
, (NoDownload, NotInstalled)
|
, (NoDownload, NotInstalled)
|
||||||
, (NotInstalled, NotInstalled)
|
, (NotInstalled, NotInstalled)
|
||||||
|
, (UninstallFailed, NotInstalled)
|
||||||
, (BuildFailed, NotInstalled)
|
, (BuildFailed, NotInstalled)
|
||||||
, (TagNotFound, NotInstalled)
|
, (TagNotFound, NotInstalled)
|
||||||
, (DigestError, NotInstalled)
|
, (DigestError, NotInstalled)
|
||||||
@ -319,6 +321,7 @@ type InstallGHCEffects = '[ TagNotFound
|
|||||||
, BuildFailed
|
, BuildFailed
|
||||||
, DirNotEmpty
|
, DirNotEmpty
|
||||||
, AlreadyInstalled
|
, AlreadyInstalled
|
||||||
|
, UninstallFailed
|
||||||
|
|
||||||
, (AlreadyInstalled, NotInstalled)
|
, (AlreadyInstalled, NotInstalled)
|
||||||
, (UnknownArchive, NotInstalled)
|
, (UnknownArchive, NotInstalled)
|
||||||
@ -328,6 +331,7 @@ type InstallGHCEffects = '[ TagNotFound
|
|||||||
, (NotInstalled, NotInstalled)
|
, (NotInstalled, NotInstalled)
|
||||||
, (DirNotEmpty, NotInstalled)
|
, (DirNotEmpty, NotInstalled)
|
||||||
, (NoDownload, NotInstalled)
|
, (NoDownload, NotInstalled)
|
||||||
|
, (UninstallFailed, NotInstalled)
|
||||||
, (BuildFailed, NotInstalled)
|
, (BuildFailed, NotInstalled)
|
||||||
, (TagNotFound, NotInstalled)
|
, (TagNotFound, NotInstalled)
|
||||||
, (DigestError, NotInstalled)
|
, (DigestError, NotInstalled)
|
||||||
@ -347,6 +351,7 @@ type InstallGHCEffects = '[ TagNotFound
|
|||||||
, (NotInstalled, ())
|
, (NotInstalled, ())
|
||||||
, (DirNotEmpty, ())
|
, (DirNotEmpty, ())
|
||||||
, (NoDownload, ())
|
, (NoDownload, ())
|
||||||
|
, (UninstallFailed, ())
|
||||||
, (BuildFailed, ())
|
, (BuildFailed, ())
|
||||||
, (TagNotFound, ())
|
, (TagNotFound, ())
|
||||||
, (DigestError, ())
|
, (DigestError, ())
|
||||||
|
@ -42,7 +42,7 @@ import Control.Concurrent (threadDelay)
|
|||||||
---------------------------
|
---------------------------
|
||||||
|
|
||||||
|
|
||||||
type NukeEffects = '[ NotInstalled ]
|
type NukeEffects = '[ NotInstalled, UninstallFailed ]
|
||||||
|
|
||||||
|
|
||||||
runNuke :: AppState
|
runNuke :: AppState
|
||||||
|
@ -127,7 +127,7 @@ rmFooter = [s|Discussion:
|
|||||||
---------------------------
|
---------------------------
|
||||||
|
|
||||||
|
|
||||||
type RmEffects = '[ NotInstalled ]
|
type RmEffects = '[ NotInstalled, UninstallFailed ]
|
||||||
|
|
||||||
|
|
||||||
runRm :: (ReaderT env m (VEither RmEffects a) -> m (VEither RmEffects a))
|
runRm :: (ReaderT env m (VEither RmEffects a) -> m (VEither RmEffects a))
|
||||||
|
@ -176,6 +176,7 @@ type RunEffects = '[ AlreadyInstalled
|
|||||||
, NoToolVersionSet
|
, NoToolVersionSet
|
||||||
, FileAlreadyExistsError
|
, FileAlreadyExistsError
|
||||||
, ProcessError
|
, ProcessError
|
||||||
|
, UninstallFailed
|
||||||
]
|
]
|
||||||
|
|
||||||
runLeanRUN :: (MonadUnliftIO m, MonadIO m)
|
runLeanRUN :: (MonadUnliftIO m, MonadIO m)
|
||||||
@ -339,6 +340,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
|
|||||||
, AlreadyInstalled
|
, AlreadyInstalled
|
||||||
, FileAlreadyExistsError
|
, FileAlreadyExistsError
|
||||||
, CopyError
|
, CopyError
|
||||||
|
, UninstallFailed
|
||||||
] (ResourceT (ReaderT AppState m)) ()
|
] (ResourceT (ReaderT AppState m)) ()
|
||||||
installToolChainFull Toolchain{..} tmp = do
|
installToolChainFull Toolchain{..} tmp = do
|
||||||
forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do
|
forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do
|
||||||
|
@ -1,6 +1,6 @@
|
|||||||
cabal-version: 3.0
|
cabal-version: 3.0
|
||||||
name: ghcup
|
name: ghcup
|
||||||
version: 0.1.17.8
|
version: 0.1.18.0
|
||||||
license: LGPL-3.0-only
|
license: LGPL-3.0-only
|
||||||
license-file: LICENSE
|
license-file: LICENSE
|
||||||
copyright: Julian Ospald 2020
|
copyright: Julian Ospald 2020
|
||||||
@ -127,6 +127,7 @@ library
|
|||||||
, safe-exceptions ^>=0.1
|
, safe-exceptions ^>=0.1
|
||||||
, split ^>=0.2.3.4
|
, split ^>=0.2.3.4
|
||||||
, strict-base ^>=0.4
|
, strict-base ^>=0.4
|
||||||
|
, streamly ^>=0.8.2
|
||||||
, template-haskell >=2.7 && <2.18
|
, template-haskell >=2.7 && <2.18
|
||||||
, temporary ^>=1.3
|
, temporary ^>=1.3
|
||||||
, text ^>=1.2.4.0
|
, text ^>=1.2.4.0
|
||||||
@ -165,6 +166,7 @@ library
|
|||||||
else
|
else
|
||||||
other-modules:
|
other-modules:
|
||||||
GHCup.Utils.File.Posix
|
GHCup.Utils.File.Posix
|
||||||
|
GHCup.Utils.File.Posix.Foreign
|
||||||
GHCup.Utils.Posix
|
GHCup.Utils.Posix
|
||||||
GHCup.Utils.Prelude.Posix
|
GHCup.Utils.Prelude.Posix
|
||||||
|
|
||||||
|
208
lib/GHCup.hs
208
lib/GHCup.hs
@ -77,7 +77,7 @@ import Prelude hiding ( abs
|
|||||||
, writeFile
|
, writeFile
|
||||||
)
|
)
|
||||||
import Safe hiding ( at )
|
import Safe hiding ( at )
|
||||||
import System.Directory hiding ( findFiles )
|
import System.Directory hiding ( findFiles, copyFile )
|
||||||
import System.Environment
|
import System.Environment
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import System.IO.Error
|
import System.IO.Error
|
||||||
@ -202,6 +202,7 @@ installGHCBindist :: ( MonadFail m
|
|||||||
, DirNotEmpty
|
, DirNotEmpty
|
||||||
, ArchiveResult
|
, ArchiveResult
|
||||||
, ProcessError
|
, ProcessError
|
||||||
|
, UninstallFailed
|
||||||
]
|
]
|
||||||
m
|
m
|
||||||
()
|
()
|
||||||
@ -269,6 +270,7 @@ installPackedGHC :: ( MonadMask m
|
|||||||
, MonadIO m
|
, MonadIO m
|
||||||
, MonadUnliftIO m
|
, MonadUnliftIO m
|
||||||
, MonadFail m
|
, MonadFail m
|
||||||
|
, MonadResource m
|
||||||
)
|
)
|
||||||
=> FilePath -- ^ Path to the packed GHC bindist
|
=> FilePath -- ^ Path to the packed GHC bindist
|
||||||
-> Maybe TarDir -- ^ Subdir of the archive
|
-> Maybe TarDir -- ^ Subdir of the archive
|
||||||
@ -300,12 +302,7 @@ installPackedGHC dl msubdir inst ver forceInstall = do
|
|||||||
msubdir
|
msubdir
|
||||||
|
|
||||||
liftE $ runBuildAction tmpUnpack
|
liftE $ runBuildAction tmpUnpack
|
||||||
(case inst of
|
(installUnpackedGHC workdir inst ver forceInstall)
|
||||||
IsolateDirResolved _ -> Nothing -- don't clean up for isolated installs, since that'd potentially delete other
|
|
||||||
-- user files if '--force' is supplied
|
|
||||||
GHCupDir d -> Just d
|
|
||||||
)
|
|
||||||
(installUnpackedGHC workdir inst ver)
|
|
||||||
|
|
||||||
|
|
||||||
-- | Install an unpacked GHC distribution. This only deals with the GHC
|
-- | Install an unpacked GHC distribution. This only deals with the GHC
|
||||||
@ -319,21 +316,27 @@ installUnpackedGHC :: ( MonadReader env m
|
|||||||
, MonadIO m
|
, MonadIO m
|
||||||
, MonadUnliftIO m
|
, MonadUnliftIO m
|
||||||
, MonadMask m
|
, MonadMask m
|
||||||
|
, MonadResource m
|
||||||
|
, MonadFail m
|
||||||
)
|
)
|
||||||
=> FilePath -- ^ Path to the unpacked GHC bindist (where the configure script resides)
|
=> FilePath -- ^ Path to the unpacked GHC bindist (where the configure script resides)
|
||||||
-> InstallDirResolved -- ^ Path to install to
|
-> InstallDirResolved -- ^ Path to install to
|
||||||
-> Version -- ^ The GHC version
|
-> Version -- ^ The GHC version
|
||||||
|
-> Bool -- ^ Force install
|
||||||
-> Excepts '[ProcessError] m ()
|
-> Excepts '[ProcessError] m ()
|
||||||
installUnpackedGHC path (fromInstallDir -> inst) ver
|
installUnpackedGHC path inst ver forceInstall
|
||||||
| isWindows = do
|
| isWindows = do
|
||||||
lift $ logInfo "Installing GHC (this may take a while)"
|
lift $ logInfo "Installing GHC (this may take a while)"
|
||||||
-- Windows bindists are relocatable and don't need
|
-- Windows bindists are relocatable and don't need
|
||||||
-- to run configure.
|
-- to run configure.
|
||||||
-- We also must make sure to preserve mtime to not confuse ghc-pkg.
|
-- We also must make sure to preserve mtime to not confuse ghc-pkg.
|
||||||
lift $ withRunInIO $ \run -> flip onException (run $ recyclePathForcibly inst) $ copyDirectoryRecursive path inst $ \source dest -> do
|
fs <- lift $ withRunInIO $ \_ -> mergeFileTreeAll path (fromInstallDir inst) $ \source dest -> do
|
||||||
mtime <- getModificationTime source
|
mtime <- getModificationTime source
|
||||||
moveFilePortable source dest
|
moveFilePortable source dest
|
||||||
setModificationTime dest mtime
|
setModificationTime dest mtime
|
||||||
|
case inst of
|
||||||
|
IsolateDirResolved _ -> pure ()
|
||||||
|
_ -> recordInstalledFiles fs GHC (mkTVer ver)
|
||||||
| otherwise = do
|
| otherwise = do
|
||||||
PlatformRequest {..} <- lift getPlatformReq
|
PlatformRequest {..} <- lift getPlatformReq
|
||||||
|
|
||||||
@ -345,13 +348,21 @@ installUnpackedGHC path (fromInstallDir -> inst) ver
|
|||||||
|
|
||||||
lift $ logInfo "Installing GHC (this may take a while)"
|
lift $ logInfo "Installing GHC (this may take a while)"
|
||||||
lEM $ execLogged "sh"
|
lEM $ execLogged "sh"
|
||||||
("./configure" : ("--prefix=" <> inst)
|
("./configure" : ("--prefix=" <> fromInstallDir inst)
|
||||||
: alpineArgs
|
: alpineArgs
|
||||||
)
|
)
|
||||||
(Just path)
|
(Just path)
|
||||||
"ghc-configure"
|
"ghc-configure"
|
||||||
Nothing
|
Nothing
|
||||||
lEM $ make ["install"] (Just path)
|
tmpInstallDest <- lift withGHCupTmpDir
|
||||||
|
lEM $ make ["DESTDIR=" <> tmpInstallDest, "install"] (Just path)
|
||||||
|
lift $ logInfo $ "Merging file tree from \"" <> T.pack tmpInstallDest <> "\" to \"" <> T.pack (fromInstallDir inst) <> "\""
|
||||||
|
fs <- mergeFileTreeAll (tmpInstallDest </> dropDrive (fromInstallDir inst))
|
||||||
|
(fromInstallDir inst)
|
||||||
|
(\f t -> liftIO $ install f t (not forceInstall))
|
||||||
|
case inst of
|
||||||
|
IsolateDirResolved _ -> pure ()
|
||||||
|
_ -> recordInstalledFiles fs GHC (mkTVer ver)
|
||||||
pure ()
|
pure ()
|
||||||
|
|
||||||
|
|
||||||
@ -389,6 +400,7 @@ installGHCBin :: ( MonadFail m
|
|||||||
, DirNotEmpty
|
, DirNotEmpty
|
||||||
, ArchiveResult
|
, ArchiveResult
|
||||||
, ProcessError
|
, ProcessError
|
||||||
|
, UninstallFailed
|
||||||
]
|
]
|
||||||
m
|
m
|
||||||
()
|
()
|
||||||
@ -493,12 +505,10 @@ installCabalUnpacked path inst ver forceInstall = do
|
|||||||
<> exeExt
|
<> exeExt
|
||||||
let destPath = fromInstallDir inst </> destFileName
|
let destPath = fromInstallDir inst </> destFileName
|
||||||
|
|
||||||
unless forceInstall -- Overwrite it when it IS a force install
|
|
||||||
(liftE $ throwIfFileAlreadyExists destPath)
|
|
||||||
|
|
||||||
copyFileE
|
copyFileE
|
||||||
(path </> cabalFile <> exeExt)
|
(path </> cabalFile <> exeExt)
|
||||||
destPath
|
destPath
|
||||||
|
(not forceInstall)
|
||||||
lift $ chmod_755 destPath
|
lift $ chmod_755 destPath
|
||||||
|
|
||||||
-- | Installs cabal into @~\/.ghcup\/bin/cabal-\<ver\>@ and
|
-- | Installs cabal into @~\/.ghcup\/bin/cabal-\<ver\>@ and
|
||||||
@ -572,6 +582,7 @@ installHLSBindist :: ( MonadMask m
|
|||||||
, FileAlreadyExistsError
|
, FileAlreadyExistsError
|
||||||
, ProcessError
|
, ProcessError
|
||||||
, DirNotEmpty
|
, DirNotEmpty
|
||||||
|
, UninstallFailed
|
||||||
]
|
]
|
||||||
m
|
m
|
||||||
()
|
()
|
||||||
@ -620,15 +631,15 @@ installHLSBindist dlinfo ver installDir forceInstall = do
|
|||||||
lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir
|
lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir
|
||||||
if legacy
|
if legacy
|
||||||
then liftE $ installHLSUnpackedLegacy workdir (IsolateDirResolved isoDir) ver forceInstall
|
then liftE $ installHLSUnpackedLegacy workdir (IsolateDirResolved isoDir) ver forceInstall
|
||||||
else liftE $ runBuildAction tmpUnpack Nothing $ installHLSUnpacked workdir (IsolateDirResolved isoDir) ver
|
else liftE $ runBuildAction tmpUnpack $ installHLSUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall
|
||||||
|
|
||||||
GHCupInternal -> do
|
GHCupInternal -> do
|
||||||
if legacy
|
if legacy
|
||||||
then liftE $ installHLSUnpackedLegacy workdir (GHCupDir binDir) ver forceInstall
|
then liftE $ installHLSUnpackedLegacy workdir (GHCupDir binDir) ver forceInstall
|
||||||
else do
|
else do
|
||||||
inst <- ghcupHLSDir ver
|
inst <- ghcupHLSDir ver
|
||||||
liftE $ runBuildAction tmpUnpack (Just inst)
|
liftE $ runBuildAction tmpUnpack
|
||||||
$ installHLSUnpacked workdir (GHCupDir inst) ver
|
$ installHLSUnpacked workdir (GHCupDir inst) ver forceInstall
|
||||||
liftE $ setHLS ver SetHLS_XYZ Nothing
|
liftE $ setHLS ver SetHLS_XYZ Nothing
|
||||||
|
|
||||||
|
|
||||||
@ -638,15 +649,32 @@ isLegacyHLSBindist path = do
|
|||||||
not <$> doesFileExist (path </> "GNUmakefile")
|
not <$> doesFileExist (path </> "GNUmakefile")
|
||||||
|
|
||||||
-- | Install an unpacked hls distribution.
|
-- | Install an unpacked hls distribution.
|
||||||
installHLSUnpacked :: (MonadMask m, MonadUnliftIO m, MonadReader env m, MonadFail m, HasLog env, HasDirs env, HasSettings env, MonadCatch m, MonadIO m)
|
installHLSUnpacked :: ( MonadMask m
|
||||||
|
, MonadUnliftIO m
|
||||||
|
, MonadReader env m
|
||||||
|
, MonadFail m
|
||||||
|
, HasLog env
|
||||||
|
, HasDirs env
|
||||||
|
, HasSettings env
|
||||||
|
, MonadCatch m
|
||||||
|
, MonadIO m
|
||||||
|
, MonadResource m
|
||||||
|
)
|
||||||
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
|
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
|
||||||
-> InstallDirResolved -- ^ Path to install to
|
-> InstallDirResolved -- ^ Path to install to
|
||||||
-> Version
|
-> Version
|
||||||
|
-> Bool
|
||||||
-> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled] m ()
|
-> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled] m ()
|
||||||
installHLSUnpacked path (fromInstallDir -> inst) _ = do
|
installHLSUnpacked path inst ver forceInstall = do
|
||||||
lift $ logInfo "Installing HLS"
|
lift $ logInfo "Installing HLS"
|
||||||
liftIO $ createDirRecursive' inst
|
tmpInstallDest <- lift withGHCupTmpDir
|
||||||
lEM $ make ["PREFIX=" <> inst, "install"] (Just path)
|
lEM $ make ["DESTDIR=" <> tmpInstallDest, "PREFIX=" <> fromInstallDir inst, "install"] (Just path)
|
||||||
|
fs <- mergeFileTreeAll (tmpInstallDest </> dropDrive (fromInstallDir inst))
|
||||||
|
(fromInstallDir inst)
|
||||||
|
(\f t -> liftIO $ install f t (not forceInstall))
|
||||||
|
case inst of
|
||||||
|
IsolateDirResolved _ -> pure ()
|
||||||
|
_ -> recordInstalledFiles fs HLS (mkTVer ver)
|
||||||
|
|
||||||
-- | Install an unpacked hls distribution (legacy).
|
-- | Install an unpacked hls distribution (legacy).
|
||||||
installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
|
installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
|
||||||
@ -677,12 +705,10 @@ installHLSUnpackedLegacy path installDir ver forceInstall = do
|
|||||||
let srcPath = path </> f
|
let srcPath = path </> f
|
||||||
let destPath = fromInstallDir installDir </> toF
|
let destPath = fromInstallDir installDir </> toF
|
||||||
|
|
||||||
unless forceInstall -- if it is a force install, overwrite it.
|
|
||||||
(liftE $ throwIfFileAlreadyExists destPath)
|
|
||||||
|
|
||||||
copyFileE
|
copyFileE
|
||||||
srcPath
|
srcPath
|
||||||
destPath
|
destPath
|
||||||
|
(not forceInstall)
|
||||||
lift $ chmod_755 destPath
|
lift $ chmod_755 destPath
|
||||||
|
|
||||||
-- install haskell-language-server-wrapper
|
-- install haskell-language-server-wrapper
|
||||||
@ -696,12 +722,10 @@ installHLSUnpackedLegacy path installDir ver forceInstall = do
|
|||||||
srcWrapperPath = path </> wrapper <> exeExt
|
srcWrapperPath = path </> wrapper <> exeExt
|
||||||
destWrapperPath = fromInstallDir installDir </> toF
|
destWrapperPath = fromInstallDir installDir </> toF
|
||||||
|
|
||||||
unless forceInstall
|
|
||||||
(liftE $ throwIfFileAlreadyExists destWrapperPath)
|
|
||||||
|
|
||||||
copyFileE
|
copyFileE
|
||||||
srcWrapperPath
|
srcWrapperPath
|
||||||
destWrapperPath
|
destWrapperPath
|
||||||
|
(not forceInstall)
|
||||||
|
|
||||||
lift $ chmod_755 destWrapperPath
|
lift $ chmod_755 destWrapperPath
|
||||||
|
|
||||||
@ -739,6 +763,7 @@ installHLSBin :: ( MonadMask m
|
|||||||
, FileAlreadyExistsError
|
, FileAlreadyExistsError
|
||||||
, ProcessError
|
, ProcessError
|
||||||
, DirNotEmpty
|
, DirNotEmpty
|
||||||
|
, UninstallFailed
|
||||||
]
|
]
|
||||||
m
|
m
|
||||||
()
|
()
|
||||||
@ -850,7 +875,6 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
|
|||||||
|
|
||||||
liftE $ runBuildAction
|
liftE $ runBuildAction
|
||||||
workdir
|
workdir
|
||||||
Nothing
|
|
||||||
(reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed workdir) $ do
|
(reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed workdir) $ do
|
||||||
let tmpInstallDir = workdir </> "out"
|
let tmpInstallDir = workdir </> "out"
|
||||||
liftIO $ createDirRecursive' tmpInstallDir
|
liftIO $ createDirRecursive' tmpInstallDir
|
||||||
@ -862,19 +886,19 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
|
|||||||
cp <- case cabalProject of
|
cp <- case cabalProject of
|
||||||
Just (Left cp)
|
Just (Left cp)
|
||||||
| isAbsolute cp -> do
|
| isAbsolute cp -> do
|
||||||
copyFileE cp (workdir </> "cabal.project")
|
copyFileE cp (workdir </> "cabal.project") False
|
||||||
pure "cabal.project"
|
pure "cabal.project"
|
||||||
| otherwise -> pure (takeFileName cp)
|
| otherwise -> pure (takeFileName cp)
|
||||||
Just (Right uri) -> do
|
Just (Right uri) -> do
|
||||||
tmpUnpack <- lift withGHCupTmpDir
|
tmpUnpack <- lift withGHCupTmpDir
|
||||||
cp <- liftE $ download uri Nothing Nothing tmpUnpack (Just "cabal.project") False
|
cp <- liftE $ download uri Nothing Nothing tmpUnpack (Just "cabal.project") False
|
||||||
copyFileE cp (workdir </> "cabal.project")
|
copyFileE cp (workdir </> "cabal.project") False
|
||||||
pure "cabal.project"
|
pure "cabal.project"
|
||||||
Nothing -> pure "cabal.project"
|
Nothing -> pure "cabal.project"
|
||||||
forM_ cabalProjectLocal $ \uri -> do
|
forM_ cabalProjectLocal $ \uri -> do
|
||||||
tmpUnpack <- lift withGHCupTmpDir
|
tmpUnpack <- lift withGHCupTmpDir
|
||||||
cpl <- liftE $ download uri Nothing Nothing tmpUnpack (Just (cp <.> "local")) False
|
cpl <- liftE $ download uri Nothing Nothing tmpUnpack (Just (cp <.> "local")) False
|
||||||
copyFileE cpl (workdir </> cp <.> "local")
|
copyFileE cpl (workdir </> cp <.> "local") False
|
||||||
artifacts <- forM (sort ghcs) $ \ghc -> do
|
artifacts <- forM (sort ghcs) $ \ghc -> do
|
||||||
let ghcInstallDir = tmpInstallDir </> T.unpack (prettyVer ghc)
|
let ghcInstallDir = tmpInstallDir </> T.unpack (prettyVer ghc)
|
||||||
liftIO $ createDirRecursive' tmpInstallDir
|
liftIO $ createDirRecursive' tmpInstallDir
|
||||||
@ -1049,12 +1073,10 @@ installStackUnpacked path installDir ver forceInstall = do
|
|||||||
<> exeExt
|
<> exeExt
|
||||||
destPath = fromInstallDir installDir </> destFileName
|
destPath = fromInstallDir installDir </> destFileName
|
||||||
|
|
||||||
unless forceInstall
|
|
||||||
(liftE $ throwIfFileAlreadyExists destPath)
|
|
||||||
|
|
||||||
copyFileE
|
copyFileE
|
||||||
(path </> stackFile <> exeExt)
|
(path </> stackFile <> exeExt)
|
||||||
destPath
|
destPath
|
||||||
|
(not forceInstall)
|
||||||
lift $ chmod_755 destPath
|
lift $ chmod_755 destPath
|
||||||
|
|
||||||
|
|
||||||
@ -1754,12 +1776,11 @@ rmGHCVer :: ( MonadReader env m
|
|||||||
, MonadUnliftIO m
|
, MonadUnliftIO m
|
||||||
)
|
)
|
||||||
=> GHCTargetVersion
|
=> GHCTargetVersion
|
||||||
-> Excepts '[NotInstalled] m ()
|
-> Excepts '[NotInstalled, UninstallFailed] m ()
|
||||||
rmGHCVer ver = do
|
rmGHCVer ver = do
|
||||||
isSetGHC <- lift $ fmap (== Just ver) $ ghcSet (_tvTarget ver)
|
isSetGHC <- lift $ fmap (== Just ver) $ ghcSet (_tvTarget ver)
|
||||||
|
|
||||||
whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC ver))
|
whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC ver))
|
||||||
dir <- lift $ ghcupGHCDir ver
|
|
||||||
|
|
||||||
-- this isn't atomic, order matters
|
-- this isn't atomic, order matters
|
||||||
when isSetGHC $ do
|
when isSetGHC $ do
|
||||||
@ -1774,8 +1795,19 @@ rmGHCVer ver = do
|
|||||||
handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorGHCSymlinks ver
|
handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorGHCSymlinks ver
|
||||||
-- then fix them (e.g. with an earlier version)
|
-- then fix them (e.g. with an earlier version)
|
||||||
|
|
||||||
lift $ logInfo $ "Removing directory recursively: " <> T.pack dir
|
dir <- lift $ ghcupGHCDir ver
|
||||||
lift $ recyclePathForcibly dir
|
lift (getInstalledFiles GHC ver) >>= \case
|
||||||
|
Just files -> do
|
||||||
|
lift $ logInfo $ "Removing files safely from: " <> T.pack dir
|
||||||
|
forM_ files (liftIO . deleteFile . (\f -> dir </> dropDrive f))
|
||||||
|
f <- recordedInstallationFile GHC ver
|
||||||
|
liftIO $ deleteFile f
|
||||||
|
removeEmptyDirsRecursive dir
|
||||||
|
survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory dir
|
||||||
|
when (not (null survivors)) $ throwE $ UninstallFailed dir survivors
|
||||||
|
Nothing -> do
|
||||||
|
lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack dir
|
||||||
|
lift $ recyclePathForcibly dir
|
||||||
|
|
||||||
v' <-
|
v' <-
|
||||||
handle
|
handle
|
||||||
@ -1834,23 +1866,37 @@ rmHLSVer :: ( MonadMask m
|
|||||||
, MonadUnliftIO m
|
, MonadUnliftIO m
|
||||||
)
|
)
|
||||||
=> Version
|
=> Version
|
||||||
-> Excepts '[NotInstalled] m ()
|
-> Excepts '[NotInstalled, UninstallFailed] m ()
|
||||||
rmHLSVer ver = do
|
rmHLSVer ver = do
|
||||||
whenM (lift $ fmap not $ hlsInstalled ver) $ throwE (NotInstalled HLS (GHCTargetVersion Nothing ver))
|
whenM (lift $ fmap not $ hlsInstalled ver) $ throwE (NotInstalled HLS (GHCTargetVersion Nothing ver))
|
||||||
|
|
||||||
isHlsSet <- lift hlsSet
|
isHlsSet <- lift hlsSet
|
||||||
|
|
||||||
liftE $ rmMinorHLSSymlinks ver
|
liftE $ rmMinorHLSSymlinks ver
|
||||||
hlsDir <- ghcupHLSDir ver
|
|
||||||
recyclePathForcibly hlsDir
|
|
||||||
|
|
||||||
when (Just ver == isHlsSet) $ do
|
when (Just ver == isHlsSet) $ do
|
||||||
-- delete all set symlinks
|
-- delete all set symlinks
|
||||||
rmPlainHLS
|
liftE rmPlainHLS
|
||||||
|
|
||||||
|
hlsDir <- ghcupHLSDir ver
|
||||||
|
lift (getInstalledFiles HLS (mkTVer ver)) >>= \case
|
||||||
|
Just files -> do
|
||||||
|
lift $ logInfo $ "Removing files safely from: " <> T.pack hlsDir
|
||||||
|
forM_ files (liftIO . deleteFile . (\f -> hlsDir </> dropDrive f))
|
||||||
|
f <- recordedInstallationFile HLS (mkTVer ver)
|
||||||
|
liftIO $ deleteFile f
|
||||||
|
removeEmptyDirsRecursive hlsDir
|
||||||
|
survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory hlsDir
|
||||||
|
when (not (null survivors)) $ throwE $ UninstallFailed hlsDir survivors
|
||||||
|
Nothing -> do
|
||||||
|
lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack hlsDir
|
||||||
|
recyclePathForcibly hlsDir
|
||||||
|
|
||||||
|
when (Just ver == isHlsSet) $ do
|
||||||
-- set latest hls
|
-- set latest hls
|
||||||
hlsVers <- lift $ fmap rights getInstalledHLSs
|
hlsVers <- lift $ fmap rights getInstalledHLSs
|
||||||
case headMay . reverse . sort $ hlsVers of
|
case headMay . reverse . sort $ hlsVers of
|
||||||
Just latestver -> setHLS latestver SetHLSOnly Nothing
|
Just latestver -> liftE $ setHLS latestver SetHLSOnly Nothing
|
||||||
Nothing -> pure ()
|
Nothing -> pure ()
|
||||||
|
|
||||||
|
|
||||||
@ -1946,15 +1992,15 @@ rmTool :: ( MonadReader env m
|
|||||||
, MonadMask m
|
, MonadMask m
|
||||||
, MonadUnliftIO m)
|
, MonadUnliftIO m)
|
||||||
=> ListResult
|
=> ListResult
|
||||||
-> Excepts '[NotInstalled ] m ()
|
-> Excepts '[NotInstalled, UninstallFailed] m ()
|
||||||
rmTool ListResult {lVer, lTool, lCross} = do
|
rmTool ListResult {lVer, lTool, lCross} = do
|
||||||
case lTool of
|
case lTool of
|
||||||
GHC ->
|
GHC ->
|
||||||
let ghcTargetVersion = GHCTargetVersion lCross lVer
|
let ghcTargetVersion = GHCTargetVersion lCross lVer
|
||||||
in rmGHCVer ghcTargetVersion
|
in rmGHCVer ghcTargetVersion
|
||||||
HLS -> rmHLSVer lVer
|
HLS -> rmHLSVer lVer
|
||||||
Cabal -> rmCabalVer lVer
|
Cabal -> liftE $ rmCabalVer lVer
|
||||||
Stack -> rmStackVer lVer
|
Stack -> liftE $ rmStackVer lVer
|
||||||
GHCup -> lift rmGhcup
|
GHCup -> lift rmGhcup
|
||||||
|
|
||||||
|
|
||||||
@ -2005,12 +2051,12 @@ rmGhcupDirs = do
|
|||||||
rmEnvFile :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
|
rmEnvFile :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
|
||||||
rmEnvFile enFilePath = do
|
rmEnvFile enFilePath = do
|
||||||
logInfo "Removing Ghcup Environment File"
|
logInfo "Removing Ghcup Environment File"
|
||||||
hideErrorDef [permissionErrorType] () $ deleteFile enFilePath
|
hideErrorDef [permissionErrorType] () $ deleteFile' enFilePath
|
||||||
|
|
||||||
rmConfFile :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
|
rmConfFile :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
|
||||||
rmConfFile confFilePath = do
|
rmConfFile confFilePath = do
|
||||||
logInfo "removing Ghcup Config File"
|
logInfo "removing Ghcup Config File"
|
||||||
hideErrorDef [permissionErrorType] () $ deleteFile confFilePath
|
hideErrorDef [permissionErrorType] () $ deleteFile' confFilePath
|
||||||
|
|
||||||
rmDir :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
|
rmDir :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
|
||||||
rmDir dir =
|
rmDir dir =
|
||||||
@ -2020,7 +2066,7 @@ rmGhcupDirs = do
|
|||||||
hideErrorDef [doesNotExistErrorType] () $ do
|
hideErrorDef [doesNotExistErrorType] () $ do
|
||||||
logInfo $ "removing " <> T.pack dir
|
logInfo $ "removing " <> T.pack dir
|
||||||
contents <- liftIO $ getDirectoryContentsRecursive dir
|
contents <- liftIO $ getDirectoryContentsRecursive dir
|
||||||
forM_ contents (deleteFile . (dir </>))
|
forM_ contents (deleteFile' . (dir </>))
|
||||||
|
|
||||||
rmBinDir :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
|
rmBinDir :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
|
||||||
rmBinDir binDir
|
rmBinDir binDir
|
||||||
@ -2049,35 +2095,33 @@ rmGhcupDirs = do
|
|||||||
compareFn :: FilePath -> FilePath -> Ordering
|
compareFn :: FilePath -> FilePath -> Ordering
|
||||||
compareFn fp1 fp2 = compare (calcDepth fp1) (calcDepth fp2)
|
compareFn fp1 fp2 = compare (calcDepth fp1) (calcDepth fp2)
|
||||||
|
|
||||||
removeEmptyDirsRecursive :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
|
-- we expect only files inside cache/log dir
|
||||||
removeEmptyDirsRecursive fp = do
|
-- we report remaining files/dirs later,
|
||||||
cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>)
|
-- hence the force/quiet mode in these delete functions below.
|
||||||
forM_ cs removeEmptyDirsRecursive
|
|
||||||
hideError InappropriateType $ removeDirIfEmptyOrIsSymlink fp
|
|
||||||
|
|
||||||
|
deleteFile' :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m) => FilePath -> m ()
|
||||||
|
deleteFile' filepath = do
|
||||||
|
hideError doesNotExistErrorType
|
||||||
|
$ hideError InappropriateType $ rmFile filepath
|
||||||
|
|
||||||
-- we expect only files inside cache/log dir
|
removeDirIfEmptyOrIsSymlink :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
|
||||||
-- we report remaining files/dirs later,
|
removeDirIfEmptyOrIsSymlink filepath =
|
||||||
-- hence the force/quiet mode in these delete functions below.
|
hideError UnsatisfiedConstraints $
|
||||||
|
handleIO' InappropriateType
|
||||||
deleteFile :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m) => FilePath -> m ()
|
(handleIfSym filepath)
|
||||||
deleteFile filepath = do
|
(liftIO $ rmDirectory filepath)
|
||||||
hideError doesNotExistErrorType
|
where
|
||||||
$ hideError InappropriateType $ rmFile filepath
|
handleIfSym fp e = do
|
||||||
|
isSym <- liftIO $ pathIsSymbolicLink fp
|
||||||
removeDirIfEmptyOrIsSymlink :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
|
if isSym
|
||||||
removeDirIfEmptyOrIsSymlink filepath =
|
then deleteFile' fp
|
||||||
hideError UnsatisfiedConstraints $
|
else liftIO $ ioError e
|
||||||
handleIO' InappropriateType
|
|
||||||
(handleIfSym filepath)
|
|
||||||
(liftIO $ rmDirectory filepath)
|
|
||||||
where
|
|
||||||
handleIfSym fp e = do
|
|
||||||
isSym <- liftIO $ pathIsSymbolicLink fp
|
|
||||||
if isSym
|
|
||||||
then deleteFile fp
|
|
||||||
else liftIO $ ioError e
|
|
||||||
|
|
||||||
|
removeEmptyDirsRecursive :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
|
||||||
|
removeEmptyDirsRecursive fp = do
|
||||||
|
cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>)
|
||||||
|
forM_ cs removeEmptyDirsRecursive
|
||||||
|
hideError InappropriateType $ removeDirIfEmptyOrIsSymlink fp
|
||||||
|
|
||||||
|
|
||||||
------------------
|
------------------
|
||||||
@ -2161,6 +2205,7 @@ compileGHC :: ( MonadMask m
|
|||||||
, ProcessError
|
, ProcessError
|
||||||
, CopyError
|
, CopyError
|
||||||
, BuildFailed
|
, BuildFailed
|
||||||
|
, UninstallFailed
|
||||||
]
|
]
|
||||||
m
|
m
|
||||||
GHCTargetVersion
|
GHCTargetVersion
|
||||||
@ -2252,7 +2297,6 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
|
|||||||
|
|
||||||
(mBindist, bmk) <- liftE $ runBuildAction
|
(mBindist, bmk) <- liftE $ runBuildAction
|
||||||
tmpUnpack
|
tmpUnpack
|
||||||
Nothing
|
|
||||||
(do
|
(do
|
||||||
b <- if hadrian
|
b <- if hadrian
|
||||||
then compileHadrianBindist tver workdir ghcdir
|
then compileHadrianBindist tver workdir ghcdir
|
||||||
@ -2387,7 +2431,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
|
|||||||
Just bc -> liftIOException
|
Just bc -> liftIOException
|
||||||
doesNotExistErrorType
|
doesNotExistErrorType
|
||||||
(FileDoesNotExistError bc)
|
(FileDoesNotExistError bc)
|
||||||
(liftIO $ copyFile bc (build_mk workdir))
|
(liftIO $ copyFile bc (build_mk workdir) False)
|
||||||
Nothing ->
|
Nothing ->
|
||||||
liftIO $ T.writeFile (build_mk workdir) (addBuildFlavourToConf defaultConf)
|
liftIO $ T.writeFile (build_mk workdir) (addBuildFlavourToConf defaultConf)
|
||||||
|
|
||||||
@ -2453,8 +2497,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
|
|||||||
<> ".tar"
|
<> ".tar"
|
||||||
<> takeExtension tar)
|
<> takeExtension tar)
|
||||||
let tarPath = cacheDir </> tarName
|
let tarPath = cacheDir </> tarName
|
||||||
copyFileE (workdir </> tar)
|
copyFileE (workdir </> tar) tarPath False
|
||||||
tarPath
|
|
||||||
lift $ logInfo $ "Copied bindist to " <> T.pack tarPath
|
lift $ logInfo $ "Copied bindist to " <> T.pack tarPath
|
||||||
pure tarPath
|
pure tarPath
|
||||||
|
|
||||||
@ -2637,8 +2680,7 @@ upgradeGHCup mtarget force' fatal = do
|
|||||||
lift $ logDebug $ "rm -f " <> T.pack destFile
|
lift $ logDebug $ "rm -f " <> T.pack destFile
|
||||||
lift $ hideError NoSuchThing $ recycleFile destFile
|
lift $ hideError NoSuchThing $ recycleFile destFile
|
||||||
lift $ logDebug $ "cp " <> T.pack p <> " " <> T.pack destFile
|
lift $ logDebug $ "cp " <> T.pack p <> " " <> T.pack destFile
|
||||||
copyFileE p
|
copyFileE p destFile False
|
||||||
destFile
|
|
||||||
lift $ chmod_755 destFile
|
lift $ chmod_755 destFile
|
||||||
|
|
||||||
liftIO (isInPath destFile) >>= \b -> unless b $
|
liftIO (isInPath destFile) >>= \b -> unless b $
|
||||||
@ -2793,7 +2835,7 @@ rmOldGHC :: ( MonadReader env m
|
|||||||
, MonadMask m
|
, MonadMask m
|
||||||
, MonadUnliftIO m
|
, MonadUnliftIO m
|
||||||
)
|
)
|
||||||
=> Excepts '[NotInstalled] m ()
|
=> Excepts '[NotInstalled, UninstallFailed] m ()
|
||||||
rmOldGHC = do
|
rmOldGHC = do
|
||||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||||
let oldGHCs = mkTVer <$> toListOf (ix GHC % getTagged Old % to fst) dls
|
let oldGHCs = mkTVer <$> toListOf (ix GHC % getTagged Old % to fst) dls
|
||||||
@ -2859,7 +2901,7 @@ rmHLSNoGHC :: ( MonadReader env m
|
|||||||
, MonadFail m
|
, MonadFail m
|
||||||
, MonadUnliftIO m
|
, MonadUnliftIO m
|
||||||
)
|
)
|
||||||
=> Excepts '[NotInstalled] m ()
|
=> Excepts '[NotInstalled, UninstallFailed] m ()
|
||||||
rmHLSNoGHC = do
|
rmHLSNoGHC = do
|
||||||
Dirs {..} <- getDirs
|
Dirs {..} <- getDirs
|
||||||
ghcs <- fmap rights getInstalledGHCs
|
ghcs <- fmap rights getInstalledGHCs
|
||||||
|
@ -146,6 +146,13 @@ instance Pretty NotInstalled where
|
|||||||
pPrint (NotInstalled tool ver) =
|
pPrint (NotInstalled tool ver) =
|
||||||
text "The version" <+> pPrint ver <+> text "of the tool" <+> pPrint tool <+> text "is not installed."
|
text "The version" <+> pPrint ver <+> text "of the tool" <+> pPrint tool <+> text "is not installed."
|
||||||
|
|
||||||
|
data UninstallFailed = UninstallFailed FilePath [FilePath]
|
||||||
|
deriving Show
|
||||||
|
|
||||||
|
instance Pretty UninstallFailed where
|
||||||
|
pPrint (UninstallFailed dir files) =
|
||||||
|
text "The following files survived uninstallation: " <+> pPrint files <+> text "...consider removing" <+> pPrint dir <+> text "manually."
|
||||||
|
|
||||||
-- | An executable was expected to be in PATH, but was not found.
|
-- | An executable was expected to be in PATH, but was not found.
|
||||||
data NotFoundInPATH = NotFoundInPATH FilePath
|
data NotFoundInPATH = NotFoundInPATH FilePath
|
||||||
deriving Show
|
deriving Show
|
||||||
|
@ -443,6 +443,7 @@ data Dirs = Dirs
|
|||||||
, cacheDir :: FilePath
|
, cacheDir :: FilePath
|
||||||
, logsDir :: FilePath
|
, logsDir :: FilePath
|
||||||
, confDir :: FilePath
|
, confDir :: FilePath
|
||||||
|
, dbDir :: FilePath
|
||||||
, recycleDir :: FilePath -- mainly used on windows
|
, recycleDir :: FilePath -- mainly used on windows
|
||||||
}
|
}
|
||||||
deriving (Show, GHC.Generic)
|
deriving (Show, GHC.Generic)
|
||||||
|
@ -1,4 +1,5 @@
|
|||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE BangPatterns #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
@ -71,7 +72,7 @@ import GHC.IO.Exception
|
|||||||
import Haskus.Utils.Variant.Excepts
|
import Haskus.Utils.Variant.Excepts
|
||||||
import Optics
|
import Optics
|
||||||
import Safe
|
import Safe
|
||||||
import System.Directory hiding ( findFiles )
|
import System.Directory hiding ( findFiles, copyFile )
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import System.IO.Error
|
import System.IO.Error
|
||||||
import Text.Regex.Posix
|
import Text.Regex.Posix
|
||||||
@ -86,6 +87,9 @@ import qualified Data.Text as T
|
|||||||
import qualified Data.Text.Encoding as E
|
import qualified Data.Text.Encoding as E
|
||||||
import qualified Text.Megaparsec as MP
|
import qualified Text.Megaparsec as MP
|
||||||
import qualified Data.List.NonEmpty as NE
|
import qualified Data.List.NonEmpty as NE
|
||||||
|
import Text.PrettyPrint.HughesPJClass (prettyShow)
|
||||||
|
import Control.DeepSeq (force)
|
||||||
|
import GHC.IO (evaluate)
|
||||||
|
|
||||||
|
|
||||||
-- $setup
|
-- $setup
|
||||||
@ -1051,14 +1055,11 @@ runBuildAction :: ( MonadReader env m
|
|||||||
, MonadCatch m
|
, MonadCatch m
|
||||||
)
|
)
|
||||||
=> FilePath -- ^ build directory (cleaned up depending on Settings)
|
=> FilePath -- ^ build directory (cleaned up depending on Settings)
|
||||||
-> Maybe FilePath -- ^ dir to *always* clean up on exception
|
|
||||||
-> Excepts e m a
|
-> Excepts e m a
|
||||||
-> Excepts e m a
|
-> Excepts e m a
|
||||||
runBuildAction bdir instdir action = do
|
runBuildAction bdir action = do
|
||||||
Settings {..} <- lift getSettings
|
Settings {..} <- lift getSettings
|
||||||
let exAction = do
|
let exAction = do
|
||||||
forM_ instdir $ \dir ->
|
|
||||||
hideError doesNotExistErrorType $ recyclePathForcibly dir
|
|
||||||
when (keepDirs == Never)
|
when (keepDirs == Never)
|
||||||
$ rmBDir bdir
|
$ rmBDir bdir
|
||||||
v <-
|
v <-
|
||||||
@ -1089,6 +1090,26 @@ cleanUpOnError bdir action = do
|
|||||||
flip onException (lift exAction) $ onE_ exAction action
|
flip onException (lift exAction) $ onE_ exAction action
|
||||||
|
|
||||||
|
|
||||||
|
-- | Clean up the given directory if the action fails,
|
||||||
|
-- depending on the Settings.
|
||||||
|
cleanFinally :: ( MonadReader env m
|
||||||
|
, HasDirs env
|
||||||
|
, HasSettings env
|
||||||
|
, MonadIO m
|
||||||
|
, MonadMask m
|
||||||
|
, HasLog env
|
||||||
|
, MonadUnliftIO m
|
||||||
|
, MonadFail m
|
||||||
|
, MonadCatch m
|
||||||
|
)
|
||||||
|
=> FilePath -- ^ build directory (cleaned up depending on Settings)
|
||||||
|
-> Excepts e m a
|
||||||
|
-> Excepts e m a
|
||||||
|
cleanFinally bdir action = do
|
||||||
|
Settings {..} <- lift getSettings
|
||||||
|
let exAction = when (keepDirs == Never) $ rmBDir bdir
|
||||||
|
flip finally (lift exAction) $ onE_ exAction action
|
||||||
|
|
||||||
|
|
||||||
-- | Remove a build directory, ignoring if it doesn't exist and gracefully
|
-- | Remove a build directory, ignoring if it doesn't exist and gracefully
|
||||||
-- printing other errors without crashing.
|
-- printing other errors without crashing.
|
||||||
@ -1194,7 +1215,7 @@ createLink link exe
|
|||||||
rmLink exe
|
rmLink exe
|
||||||
|
|
||||||
logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
|
logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
|
||||||
liftIO $ copyFile shimGen exe
|
liftIO $ copyFile shimGen exe False
|
||||||
liftIO $ writeFile shim shimContents
|
liftIO $ writeFile shim shimContents
|
||||||
| otherwise = do
|
| otherwise = do
|
||||||
logDebug $ "rm -f " <> T.pack exe
|
logDebug $ "rm -f " <> T.pack exe
|
||||||
@ -1234,7 +1255,7 @@ ensureGlobalTools
|
|||||||
|
|
||||||
-- | Ensure ghcup directory structure exists.
|
-- | Ensure ghcup directory structure exists.
|
||||||
ensureDirectories :: Dirs -> IO ()
|
ensureDirectories :: Dirs -> IO ()
|
||||||
ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir) = do
|
ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir dbDir) = do
|
||||||
createDirRecursive' baseDir
|
createDirRecursive' baseDir
|
||||||
createDirRecursive' (baseDir </> "ghc")
|
createDirRecursive' (baseDir </> "ghc")
|
||||||
createDirRecursive' binDir
|
createDirRecursive' binDir
|
||||||
@ -1242,6 +1263,7 @@ ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir) = do
|
|||||||
createDirRecursive' logsDir
|
createDirRecursive' logsDir
|
||||||
createDirRecursive' confDir
|
createDirRecursive' confDir
|
||||||
createDirRecursive' trashDir
|
createDirRecursive' trashDir
|
||||||
|
createDirRecursive' dbDir
|
||||||
pure ()
|
pure ()
|
||||||
|
|
||||||
|
|
||||||
@ -1272,3 +1294,52 @@ installDestSanityCheck (IsolateDirResolved isoDir) = do
|
|||||||
contents <- liftIO $ getDirectoryContentsRecursive isoDir
|
contents <- liftIO $ getDirectoryContentsRecursive isoDir
|
||||||
unless (null contents) (throwE $ DirNotEmpty isoDir)
|
unless (null contents) (throwE $ DirNotEmpty isoDir)
|
||||||
installDestSanityCheck _ = pure ()
|
installDestSanityCheck _ = pure ()
|
||||||
|
|
||||||
|
|
||||||
|
-- | Write installed files into database.
|
||||||
|
recordInstalledFiles :: ( MonadIO m
|
||||||
|
, MonadReader env m
|
||||||
|
, HasDirs env
|
||||||
|
, MonadFail m
|
||||||
|
)
|
||||||
|
=> [FilePath]
|
||||||
|
-> Tool
|
||||||
|
-> GHCTargetVersion
|
||||||
|
-> m ()
|
||||||
|
recordInstalledFiles files tool v' = do
|
||||||
|
dest <- recordedInstallationFile tool v'
|
||||||
|
liftIO $ createDirectoryIfMissing True (takeDirectory dest)
|
||||||
|
-- TODO: what if the filepath has newline? :)
|
||||||
|
let contents = unlines files
|
||||||
|
liftIO $ writeFile dest contents
|
||||||
|
pure ()
|
||||||
|
|
||||||
|
|
||||||
|
-- | Returns 'Nothing' for legacy installs.
|
||||||
|
getInstalledFiles :: ( MonadIO m
|
||||||
|
, MonadCatch m
|
||||||
|
, MonadReader env m
|
||||||
|
, HasDirs env
|
||||||
|
, MonadFail m
|
||||||
|
)
|
||||||
|
=> Tool
|
||||||
|
-> GHCTargetVersion
|
||||||
|
-> m (Maybe [FilePath])
|
||||||
|
getInstalledFiles t v' = hideErrorDef [doesNotExistErrorType] Nothing $ do
|
||||||
|
f <- recordedInstallationFile t v'
|
||||||
|
(force -> !c) <- liftIO
|
||||||
|
(readFile f >>= evaluate)
|
||||||
|
pure (Just $ lines c)
|
||||||
|
|
||||||
|
|
||||||
|
recordedInstallationFile :: ( MonadReader env m
|
||||||
|
, HasDirs env
|
||||||
|
)
|
||||||
|
=> Tool
|
||||||
|
-> GHCTargetVersion
|
||||||
|
-> m FilePath
|
||||||
|
recordedInstallationFile t v' = do
|
||||||
|
Dirs {..} <- getDirs
|
||||||
|
pure (dbDir </> prettyShow t </> T.unpack (tVerToText v'))
|
||||||
|
|
||||||
|
|
||||||
|
@ -53,8 +53,8 @@ import Data.Versions
|
|||||||
import GHC.IO.Exception ( IOErrorType(NoSuchThing) )
|
import GHC.IO.Exception ( IOErrorType(NoSuchThing) )
|
||||||
import Haskus.Utils.Variant.Excepts
|
import Haskus.Utils.Variant.Excepts
|
||||||
import Optics
|
import Optics
|
||||||
import System.Directory
|
import System.Directory
|
||||||
import System.DiskSpace
|
import System.DiskSpace
|
||||||
import System.Environment
|
import System.Environment
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import System.IO.Temp
|
import System.IO.Temp
|
||||||
@ -180,6 +180,26 @@ ghcupLogsDir
|
|||||||
else ghcupBaseDir <&> (</> "logs")
|
else ghcupBaseDir <&> (</> "logs")
|
||||||
|
|
||||||
|
|
||||||
|
-- | Defaults to '~/.ghcup/db.
|
||||||
|
--
|
||||||
|
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
|
||||||
|
-- then uses 'XDG_CACHE_HOME/ghcup/db as per xdg spec.
|
||||||
|
ghcupDbDir :: IO FilePath
|
||||||
|
ghcupDbDir
|
||||||
|
| isWindows = ghcupBaseDir <&> (</> "db")
|
||||||
|
| otherwise = do
|
||||||
|
xdg <- useXDG
|
||||||
|
if xdg
|
||||||
|
then do
|
||||||
|
bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
|
||||||
|
Just r -> pure r
|
||||||
|
Nothing -> do
|
||||||
|
home <- liftIO getHomeDirectory
|
||||||
|
pure (home </> ".cache")
|
||||||
|
pure (bdir </> "ghcup" </> "db")
|
||||||
|
else ghcupBaseDir <&> (</> "db")
|
||||||
|
|
||||||
|
|
||||||
-- | '~/.ghcup/trash'.
|
-- | '~/.ghcup/trash'.
|
||||||
-- Mainly used on windows to improve file removal operations
|
-- Mainly used on windows to improve file removal operations
|
||||||
ghcupRecycleDir :: IO FilePath
|
ghcupRecycleDir :: IO FilePath
|
||||||
@ -195,6 +215,7 @@ getAllDirs = do
|
|||||||
logsDir <- ghcupLogsDir
|
logsDir <- ghcupLogsDir
|
||||||
confDir <- ghcupConfigDir
|
confDir <- ghcupConfigDir
|
||||||
recycleDir <- ghcupRecycleDir
|
recycleDir <- ghcupRecycleDir
|
||||||
|
dbDir <- ghcupDbDir
|
||||||
pure Dirs { .. }
|
pure Dirs { .. }
|
||||||
|
|
||||||
|
|
||||||
|
@ -1,6 +1,16 @@
|
|||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE BangPatterns #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
module GHCup.Utils.File (
|
module GHCup.Utils.File (
|
||||||
|
mergeFileTree,
|
||||||
|
mergeFileTreeAll,
|
||||||
|
copyFileE,
|
||||||
module GHCup.Utils.File.Common,
|
module GHCup.Utils.File.Common,
|
||||||
#if IS_WINDOWS
|
#if IS_WINDOWS
|
||||||
module GHCup.Utils.File.Windows
|
module GHCup.Utils.File.Windows
|
||||||
@ -15,3 +25,79 @@ import GHCup.Utils.File.Windows
|
|||||||
#else
|
#else
|
||||||
import GHCup.Utils.File.Posix
|
import GHCup.Utils.File.Posix
|
||||||
#endif
|
#endif
|
||||||
|
import GHCup.Errors
|
||||||
|
import GHCup.Utils.Prelude
|
||||||
|
|
||||||
|
import GHC.IO ( evaluate )
|
||||||
|
import Control.Exception.Safe
|
||||||
|
import Haskus.Utils.Variant.Excepts
|
||||||
|
import Control.Monad.Reader
|
||||||
|
import System.Directory hiding (findFiles, copyFile)
|
||||||
|
import System.FilePath
|
||||||
|
|
||||||
|
import Data.List (nub)
|
||||||
|
import Data.Foldable (traverse_)
|
||||||
|
import Control.DeepSeq (force)
|
||||||
|
|
||||||
|
|
||||||
|
-- | Like 'mergeFileTree', except reads the entire source base dir to determine files to copy recursively.
|
||||||
|
mergeFileTreeAll :: MonadIO m
|
||||||
|
=> FilePath -- ^ source base directory from which to install findFiles
|
||||||
|
-> FilePath -- ^ destination base dir
|
||||||
|
-> (FilePath -> FilePath -> m ()) -- ^ file copy operation
|
||||||
|
-> m [FilePath]
|
||||||
|
mergeFileTreeAll sourceBase destBase copyOp = do
|
||||||
|
(force -> !sourceFiles) <- liftIO
|
||||||
|
(getDirectoryContentsRecursive sourceBase >>= evaluate)
|
||||||
|
mergeFileTree sourceBase sourceFiles destBase copyOp
|
||||||
|
pure sourceFiles
|
||||||
|
|
||||||
|
|
||||||
|
mergeFileTree :: MonadIO m
|
||||||
|
=> FilePath -- ^ source base directory from which to install findFiles
|
||||||
|
-> [FilePath] -- ^ relative filepaths from source base directory
|
||||||
|
-> FilePath -- ^ destination base dir
|
||||||
|
-> (FilePath -> FilePath -> m ()) -- ^ file copy operation
|
||||||
|
-> m ()
|
||||||
|
mergeFileTree sourceBase sources destBase copyOp = do
|
||||||
|
-- These checks are not atomic, but we perform them to have
|
||||||
|
-- the opportunity to abort before copying has started.
|
||||||
|
--
|
||||||
|
-- The actual copying might still fail.
|
||||||
|
liftIO baseCheck
|
||||||
|
liftIO destCheck
|
||||||
|
liftIO sourcesCheck
|
||||||
|
|
||||||
|
-- finally copy
|
||||||
|
copy
|
||||||
|
|
||||||
|
where
|
||||||
|
copy = do
|
||||||
|
let dirs = map (destBase </>) . nub . fmap takeDirectory $ sources
|
||||||
|
traverse_ (liftIO . createDirectoryIfMissing True) dirs
|
||||||
|
|
||||||
|
forM_ sources $ \source -> do
|
||||||
|
let dest = destBase </> source
|
||||||
|
src = sourceBase </> source
|
||||||
|
copyOp src dest
|
||||||
|
|
||||||
|
baseCheck = do
|
||||||
|
when (isRelative sourceBase)
|
||||||
|
$ throwIO $ userError ("mergeFileTree: source base directory " <> sourceBase <> " is not absolute!")
|
||||||
|
whenM (not <$> doesDirectoryExist sourceBase)
|
||||||
|
$ throwIO $ userError ("mergeFileTree: source base directory " <> sourceBase <> " does not exist!")
|
||||||
|
destCheck = do
|
||||||
|
when (isRelative destBase)
|
||||||
|
$ throwIO $ userError ("mergeFileTree: destination base directory " <> destBase <> " is not absolute!")
|
||||||
|
whenM (doesDirectoryExist destBase)
|
||||||
|
$ throwIO $ userError ("mergeFileTree: destination base directory " <> destBase <> " does already exist!")
|
||||||
|
sourcesCheck =
|
||||||
|
forM_ sources $ \source -> do
|
||||||
|
-- TODO: use Excepts or HPath
|
||||||
|
when (isAbsolute source)
|
||||||
|
$ throwIO $ userError ("mergeFileTree: source file " <> source <> " is not relative!")
|
||||||
|
whenM (not <$> doesFileExist (sourceBase </> source))
|
||||||
|
$ throwIO $ userError ("mergeFileTree: source file " <> (sourceBase </> source) <> " does not exist!")
|
||||||
|
|
||||||
|
copyFileE :: (CopyError :< xs, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Bool -> Excepts xs m ()
|
||||||
|
copyFileE from to = handleIO (throwE . CopyError . show) . liftIO . copyFile from to
|
||||||
|
@ -1,3 +1,4 @@
|
|||||||
|
{-# LANGUAGE CPP #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
|
||||||
@ -15,14 +16,11 @@ import Data.Maybe
|
|||||||
import Data.Text ( Text )
|
import Data.Text ( Text )
|
||||||
import Data.Void
|
import Data.Void
|
||||||
import GHC.IO.Exception
|
import GHC.IO.Exception
|
||||||
import Optics hiding ((<|), (|>))
|
import System.Directory hiding (findFiles, copyFile)
|
||||||
import System.Directory hiding (findFiles)
|
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import Text.PrettyPrint.HughesPJClass hiding ( (<>) )
|
|
||||||
import Text.Regex.Posix
|
import Text.Regex.Posix
|
||||||
|
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import qualified Data.ByteString.Lazy as BL
|
|
||||||
import qualified Text.Megaparsec as MP
|
import qualified Text.Megaparsec as MP
|
||||||
|
|
||||||
|
|
||||||
@ -109,3 +107,5 @@ findFiles' path parser = do
|
|||||||
|
|
||||||
checkFileAlreadyExists :: (MonadIO m) => FilePath -> m Bool
|
checkFileAlreadyExists :: (MonadIO m) => FilePath -> m Bool
|
||||||
checkFileAlreadyExists fp = liftIO $ doesFileExist fp
|
checkFileAlreadyExists fp = liftIO $ doesFileExist fp
|
||||||
|
|
||||||
|
|
||||||
|
@ -34,12 +34,16 @@ import Data.IORef
|
|||||||
import Data.Sequence ( Seq, (|>) )
|
import Data.Sequence ( Seq, (|>) )
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.Word8
|
import Data.Word8
|
||||||
|
import Foreign.C.String
|
||||||
|
import Foreign.C.Types
|
||||||
import GHC.IO.Exception
|
import GHC.IO.Exception
|
||||||
import System.IO ( stderr )
|
import System.IO ( stderr, hClose, hSetBinaryMode )
|
||||||
import System.IO.Error
|
import System.IO.Error
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import System.Directory
|
import System.Directory hiding ( copyFile )
|
||||||
import System.Posix.Directory
|
import System.Posix.Directory
|
||||||
|
import System.Posix.Error ( throwErrnoPathIfMinus1Retry )
|
||||||
|
import System.Posix.Internals ( withFilePath )
|
||||||
import System.Posix.Files
|
import System.Posix.Files
|
||||||
import System.Posix.IO
|
import System.Posix.IO
|
||||||
import System.Posix.Process ( ProcessStatus(..) )
|
import System.Posix.Process ( ProcessStatus(..) )
|
||||||
@ -50,12 +54,20 @@ import qualified Control.Exception as EX
|
|||||||
import qualified Data.Sequence as Sq
|
import qualified Data.Sequence as Sq
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import qualified Data.Text.Encoding as E
|
import qualified Data.Text.Encoding as E
|
||||||
|
import qualified System.Posix.Files as PF
|
||||||
import qualified System.Posix.Process as SPP
|
import qualified System.Posix.Process as SPP
|
||||||
|
import qualified System.Posix.IO as SPI
|
||||||
import qualified System.Console.Terminal.Size as TP
|
import qualified System.Console.Terminal.Size as TP
|
||||||
|
import qualified System.Posix as Posix
|
||||||
import qualified Data.ByteString as BS
|
import qualified Data.ByteString as BS
|
||||||
import qualified Data.ByteString.Lazy as BL
|
import qualified Data.ByteString.Lazy as BL
|
||||||
import qualified "unix-bytestring" System.Posix.IO.ByteString
|
import qualified "unix-bytestring" System.Posix.IO.ByteString
|
||||||
as SPIB
|
as SPIB
|
||||||
|
import qualified Streamly.FileSystem.Handle as FH
|
||||||
|
import qualified Streamly.Internal.FileSystem.Handle
|
||||||
|
as IFH
|
||||||
|
import qualified Streamly.Prelude as S
|
||||||
|
import qualified GHCup.Utils.File.Posix.Foreign as FD
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@ -399,3 +411,155 @@ isBrokenSymlink fp = do
|
|||||||
Right b -> pure b
|
Right b -> pure b
|
||||||
Left e | isDoesNotExistError e -> pure False
|
Left e | isDoesNotExistError e -> pure False
|
||||||
| otherwise -> throwIO e
|
| otherwise -> throwIO e
|
||||||
|
|
||||||
|
copyFile :: FilePath -- ^ source file
|
||||||
|
-> FilePath -- ^ destination file
|
||||||
|
-> Bool -- ^ fail if file exists
|
||||||
|
-> IO ()
|
||||||
|
copyFile from to fail' = do
|
||||||
|
bracket
|
||||||
|
(do
|
||||||
|
fd <- openFd' from SPI.ReadOnly [FD.oNofollow] Nothing
|
||||||
|
handle' <- SPI.fdToHandle fd
|
||||||
|
pure (fd, handle')
|
||||||
|
)
|
||||||
|
(\(_, handle') -> hClose handle')
|
||||||
|
$ \(fromFd, fH) -> do
|
||||||
|
sourceFileMode <- fileMode
|
||||||
|
<$> getFdStatus fromFd
|
||||||
|
let dflags =
|
||||||
|
[ FD.oNofollow
|
||||||
|
, case fail' of
|
||||||
|
True -> FD.oExcl
|
||||||
|
False -> FD.oTrunc
|
||||||
|
]
|
||||||
|
bracketeer
|
||||||
|
(do
|
||||||
|
fd <- openFd' to SPI.WriteOnly dflags $ Just sourceFileMode
|
||||||
|
handle' <- SPI.fdToHandle fd
|
||||||
|
pure (fd, handle')
|
||||||
|
)
|
||||||
|
(\(_, handle') -> hClose handle')
|
||||||
|
(\(_, handle') -> do
|
||||||
|
hClose handle'
|
||||||
|
case fail' of
|
||||||
|
-- if we created the file and copying failed, it's
|
||||||
|
-- safe to clean up
|
||||||
|
True -> PF.removeLink to
|
||||||
|
False -> pure ()
|
||||||
|
)
|
||||||
|
$ \(_, tH) -> do
|
||||||
|
hSetBinaryMode fH True
|
||||||
|
hSetBinaryMode tH True
|
||||||
|
streamlyCopy (fH, tH)
|
||||||
|
where
|
||||||
|
streamlyCopy (fH, tH) =
|
||||||
|
S.fold (FH.writeChunks tH) $ IFH.toChunksWithBufferOf (256 * 1024) fH
|
||||||
|
|
||||||
|
foreign import ccall unsafe "open"
|
||||||
|
c_open :: CString -> CInt -> Posix.CMode -> IO CInt
|
||||||
|
|
||||||
|
|
||||||
|
open_ :: CString
|
||||||
|
-> Posix.OpenMode
|
||||||
|
-> [FD.Flags]
|
||||||
|
-> Maybe Posix.FileMode
|
||||||
|
-> IO Posix.Fd
|
||||||
|
open_ str how optional_flags maybe_mode = do
|
||||||
|
fd <- c_open str all_flags mode_w
|
||||||
|
return (Posix.Fd fd)
|
||||||
|
where
|
||||||
|
all_flags = FD.unionFlags $ optional_flags ++ [open_mode] ++ creat
|
||||||
|
|
||||||
|
|
||||||
|
(creat, mode_w) = case maybe_mode of
|
||||||
|
Nothing -> ([],0)
|
||||||
|
Just x -> ([FD.oCreat], x)
|
||||||
|
|
||||||
|
open_mode = case how of
|
||||||
|
Posix.ReadOnly -> FD.oRdonly
|
||||||
|
Posix.WriteOnly -> FD.oWronly
|
||||||
|
Posix.ReadWrite -> FD.oRdwr
|
||||||
|
|
||||||
|
|
||||||
|
-- |Open and optionally create this file. See 'System.Posix.Files'
|
||||||
|
-- for information on how to use the 'FileMode' type.
|
||||||
|
--
|
||||||
|
-- Note that passing @Just x@ as the 4th argument triggers the
|
||||||
|
-- `oCreat` status flag, which must be set when you pass in `oExcl`
|
||||||
|
-- to the status flags. Also see the manpage for @open(2)@.
|
||||||
|
openFd' :: FilePath
|
||||||
|
-> Posix.OpenMode
|
||||||
|
-> [FD.Flags] -- ^ status flags of @open(2)@
|
||||||
|
-> Maybe Posix.FileMode -- ^ @Just x@ => creates the file with the given modes, Nothing => the file must exist.
|
||||||
|
-> IO Posix.Fd
|
||||||
|
openFd' name how optional_flags maybe_mode =
|
||||||
|
withFilePath name $ \str ->
|
||||||
|
throwErrnoPathIfMinus1Retry "openFd" name $
|
||||||
|
open_ str how optional_flags maybe_mode
|
||||||
|
|
||||||
|
|
||||||
|
-- |Deletes the given file. Raises `eISDIR`
|
||||||
|
-- if run on a directory. Does not follow symbolic links.
|
||||||
|
--
|
||||||
|
-- Throws:
|
||||||
|
--
|
||||||
|
-- - `InappropriateType` for wrong file type (directory)
|
||||||
|
-- - `NoSuchThing` if the file does not exist
|
||||||
|
-- - `PermissionDenied` if the directory cannot be read
|
||||||
|
--
|
||||||
|
-- Notes: calls `unlink`
|
||||||
|
deleteFile :: FilePath -> IO ()
|
||||||
|
deleteFile = removeLink
|
||||||
|
|
||||||
|
|
||||||
|
-- |Recreate a symlink.
|
||||||
|
--
|
||||||
|
-- In `Overwrite` copy mode only files and empty directories are deleted.
|
||||||
|
--
|
||||||
|
-- Safety/reliability concerns:
|
||||||
|
--
|
||||||
|
-- * `Overwrite` mode is inherently non-atomic
|
||||||
|
--
|
||||||
|
-- Throws:
|
||||||
|
--
|
||||||
|
-- - `InvalidArgument` if source file is wrong type (not a symlink)
|
||||||
|
-- - `PermissionDenied` if output directory cannot be written to
|
||||||
|
-- - `PermissionDenied` if source directory cannot be opened
|
||||||
|
-- - `SameFile` if source and destination are the same file
|
||||||
|
-- (`HPathIOException`)
|
||||||
|
--
|
||||||
|
--
|
||||||
|
-- Throws in `Strict` mode only:
|
||||||
|
--
|
||||||
|
-- - `AlreadyExists` if destination already exists
|
||||||
|
--
|
||||||
|
-- Throws in `Overwrite` mode only:
|
||||||
|
--
|
||||||
|
-- - `UnsatisfiedConstraints` if destination file is non-empty directory
|
||||||
|
--
|
||||||
|
-- Notes:
|
||||||
|
--
|
||||||
|
-- - calls `symlink`
|
||||||
|
recreateSymlink :: FilePath -- ^ the old symlink file
|
||||||
|
-> FilePath -- ^ destination file
|
||||||
|
-> Bool -- ^ fail if destination file exists
|
||||||
|
-> IO ()
|
||||||
|
recreateSymlink symsource newsym fail' = do
|
||||||
|
sympoint <- readSymbolicLink symsource
|
||||||
|
case fail' of
|
||||||
|
True -> pure ()
|
||||||
|
False ->
|
||||||
|
hideError doesNotExistErrorType $ deleteFile newsym
|
||||||
|
createSymbolicLink sympoint newsym
|
||||||
|
|
||||||
|
|
||||||
|
-- copys files, recreates symlinks, fails on all other types
|
||||||
|
install :: FilePath -> FilePath -> Bool -> IO ()
|
||||||
|
install from to fail' = do
|
||||||
|
fs <- PF.getSymbolicLinkStatus from
|
||||||
|
decide fs
|
||||||
|
where
|
||||||
|
decide fs | PF.isRegularFile fs = copyFile from to fail'
|
||||||
|
| PF.isSymbolicLink fs = recreateSymlink from to fail'
|
||||||
|
| otherwise = ioError $ mkIOError illegalOperationErrorType "install: not a regular file or symlink" Nothing (Just from)
|
||||||
|
77
lib/GHCup/Utils/File/Posix/Foreign.hsc
Normal file
77
lib/GHCup/Utils/File/Posix/Foreign.hsc
Normal file
@ -0,0 +1,77 @@
|
|||||||
|
{-# LANGUAGE PatternSynonyms #-}
|
||||||
|
|
||||||
|
module GHCup.Utils.File.Posix.Foreign where
|
||||||
|
|
||||||
|
import Data.Bits
|
||||||
|
import Data.List (foldl')
|
||||||
|
import Foreign.C.Types
|
||||||
|
|
||||||
|
#include <limits.h>
|
||||||
|
#include <stdlib.h>
|
||||||
|
#include <dirent.h>
|
||||||
|
#include <sys/types.h>
|
||||||
|
#include <sys/stat.h>
|
||||||
|
#include <fcntl.h>
|
||||||
|
|
||||||
|
newtype DirType = DirType Int deriving (Eq, Show)
|
||||||
|
data Flags = Flags Int | UnsupportedFlag String deriving (Eq, Show)
|
||||||
|
|
||||||
|
unFlags :: Flags -> Int
|
||||||
|
unFlags (Flags i) = i
|
||||||
|
unFlags (UnsupportedFlag name) = error (name ++ " is not supported on this platform")
|
||||||
|
|
||||||
|
-- |Returns @True@ if posix-paths was compiled with support for the provided
|
||||||
|
-- flag. (As of this writing, the only flag for which this check may be
|
||||||
|
-- necessary is 'oCloexec'; all other flags will always yield @True@.)
|
||||||
|
isSupported :: Flags -> Bool
|
||||||
|
isSupported (Flags _) = True
|
||||||
|
isSupported _ = False
|
||||||
|
|
||||||
|
-- |@O_CLOEXEC@ is not supported on every POSIX platform. Use
|
||||||
|
-- @'isSupported' oCloexec@ to determine if support for @O_CLOEXEC@ was
|
||||||
|
-- compiled into your version of posix-paths. (If not, using @oCloexec@ will
|
||||||
|
-- throw an exception.)
|
||||||
|
oCloexec :: Flags
|
||||||
|
#ifdef O_CLOEXEC
|
||||||
|
oCloexec = Flags #{const O_CLOEXEC}
|
||||||
|
#else
|
||||||
|
{-# WARNING oCloexec
|
||||||
|
"This version of posix-paths was compiled without @O_CLOEXEC@ support." #-}
|
||||||
|
oCloexec = UnsupportedFlag "O_CLOEXEC"
|
||||||
|
#endif
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- If these enum declarations occur earlier in the file, haddock
|
||||||
|
-- gets royally confused about the above doc comments.
|
||||||
|
-- Probably http://trac.haskell.org/haddock/ticket/138
|
||||||
|
|
||||||
|
#{enum DirType, DirType, DT_BLK, DT_CHR, DT_DIR, DT_FIFO, DT_LNK, DT_REG, DT_SOCK, DT_UNKNOWN}
|
||||||
|
|
||||||
|
#{enum Flags, Flags, O_APPEND, O_ASYNC, O_CREAT, O_DIRECTORY, O_EXCL, O_NOCTTY, O_NOFOLLOW, O_NONBLOCK, O_RDONLY, O_WRONLY, O_RDWR, O_SYNC, O_TRUNC}
|
||||||
|
|
||||||
|
pathMax :: Int
|
||||||
|
pathMax = #{const PATH_MAX}
|
||||||
|
|
||||||
|
unionFlags :: [Flags] -> CInt
|
||||||
|
unionFlags = fromIntegral . foldl' ((. unFlags) . (.|.)) 0
|
||||||
|
|
||||||
|
|
||||||
|
pattern DtBlk :: DirType
|
||||||
|
pattern DtBlk <- dtBlk
|
||||||
|
pattern DtChr :: DirType
|
||||||
|
pattern DtChr <- dtChr
|
||||||
|
pattern DtDir :: DirType
|
||||||
|
pattern DtDir <- dtdir
|
||||||
|
pattern DtFifo :: DirType
|
||||||
|
pattern DtFifo <- dtFifo
|
||||||
|
pattern DtLnk :: DirType
|
||||||
|
pattern DtLnk <- dtLnk
|
||||||
|
pattern DtReg :: DirType
|
||||||
|
pattern DtReg <- dtReg
|
||||||
|
pattern DtSock :: DirType
|
||||||
|
pattern DtSock <- dtSock
|
||||||
|
pattern DtUnknown :: DirType
|
||||||
|
pattern DtUnknown <- dtUnknown
|
||||||
|
|
||||||
|
{-# COMPLETE DtBlk, DtChr, DtDir, DtFifo, DtLnk, DtReg, DtSock, DtUnknown #-}
|
@ -31,12 +31,13 @@ import Data.List
|
|||||||
import Foreign.C.Error
|
import Foreign.C.Error
|
||||||
import GHC.IO.Exception
|
import GHC.IO.Exception
|
||||||
import GHC.IO.Handle
|
import GHC.IO.Handle
|
||||||
import System.Directory
|
import System.Directory hiding ( copyFile )
|
||||||
import System.Environment
|
import System.Environment
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import System.IO
|
import System.IO
|
||||||
import System.Process
|
import System.Process
|
||||||
|
|
||||||
|
import qualified System.Win32.File as WS
|
||||||
import qualified Control.Exception as EX
|
import qualified Control.Exception as EX
|
||||||
import qualified Data.ByteString as BS
|
import qualified Data.ByteString as BS
|
||||||
import qualified Data.ByteString.Lazy as BL
|
import qualified Data.ByteString.Lazy as BL
|
||||||
@ -269,3 +270,16 @@ isBrokenSymlink fp = do
|
|||||||
-- this drops 'symDir' if 'tfp' is absolute
|
-- this drops 'symDir' if 'tfp' is absolute
|
||||||
(takeDirectory fp </> tfp)
|
(takeDirectory fp </> tfp)
|
||||||
else pure False
|
else pure False
|
||||||
|
|
||||||
|
|
||||||
|
copyFile :: FilePath -- ^ source file
|
||||||
|
-> FilePath -- ^ destination file
|
||||||
|
-> Bool -- ^ fail if file exists
|
||||||
|
-> IO ()
|
||||||
|
copyFile = WS.copyFile
|
||||||
|
|
||||||
|
deleteFile :: FilePath -> IO ()
|
||||||
|
deleteFile = WS.deleteFile
|
||||||
|
|
||||||
|
install :: FilePath -> FilePath -> Bool -> IO ()
|
||||||
|
install = copyFile
|
||||||
|
@ -58,7 +58,7 @@ import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )
|
|||||||
import System.IO.Error
|
import System.IO.Error
|
||||||
import System.IO.Temp
|
import System.IO.Temp
|
||||||
import System.IO.Unsafe
|
import System.IO.Unsafe
|
||||||
import System.Directory
|
import System.Directory hiding ( copyFile )
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
|
|
||||||
import Control.Retry
|
import Control.Retry
|
||||||
@ -412,7 +412,7 @@ copyDirectoryRecursive srcDir destDir doCopy = do
|
|||||||
copyFilesWith targetDir srcFiles = do
|
copyFilesWith targetDir srcFiles = do
|
||||||
|
|
||||||
-- Create parent directories for everything
|
-- Create parent directories for everything
|
||||||
let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles
|
let dirs = map (targetDir </>) . nub . map takeDirectory $ fmap snd srcFiles
|
||||||
traverse_ (createDirectoryIfMissing True) dirs
|
traverse_ (createDirectoryIfMissing True) dirs
|
||||||
|
|
||||||
-- Copy all the files
|
-- Copy all the files
|
||||||
@ -428,6 +428,7 @@ copyDirectoryRecursive srcDir destDir doCopy = do
|
|||||||
-- parent directories. The list is generated lazily so is not well defined if
|
-- parent directories. The list is generated lazily so is not well defined if
|
||||||
-- the source directory structure changes before the list is used.
|
-- the source directory structure changes before the list is used.
|
||||||
--
|
--
|
||||||
|
-- TODO: use streamly
|
||||||
getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
|
getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
|
||||||
getDirectoryContentsRecursive topdir = recurseDirectories [""]
|
getDirectoryContentsRecursive topdir = recurseDirectories [""]
|
||||||
where
|
where
|
||||||
@ -549,10 +550,6 @@ recover action =
|
|||||||
(\_ -> action)
|
(\_ -> action)
|
||||||
|
|
||||||
|
|
||||||
copyFileE :: (CopyError :< xs, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Excepts xs m ()
|
|
||||||
copyFileE from = handleIO (throwE . CopyError . show) . liftIO . copyFile from
|
|
||||||
|
|
||||||
|
|
||||||
-- | Gathering monoidal values
|
-- | Gathering monoidal values
|
||||||
--
|
--
|
||||||
-- >>> traverseFold (pure . (:["0"])) ["1","2"]
|
-- >>> traverseFold (pure . (:["0"])) ["1","2"]
|
||||||
@ -763,3 +760,20 @@ breakOn needle haystack | needle `isPrefixOf` haystack = ([], haystack)
|
|||||||
breakOn _ [] = ([], [])
|
breakOn _ [] = ([], [])
|
||||||
breakOn needle (x:xs) = first (x:) $ breakOn needle xs
|
breakOn needle (x:xs) = first (x:) $ breakOn needle xs
|
||||||
|
|
||||||
|
|
||||||
|
-- |Like `bracket`, but allows to have different clean-up
|
||||||
|
-- actions depending on whether the in-between computation
|
||||||
|
-- has raised an exception or not.
|
||||||
|
bracketeer :: IO a -- ^ computation to run first
|
||||||
|
-> (a -> IO b) -- ^ computation to run last, when
|
||||||
|
-- no exception was raised
|
||||||
|
-> (a -> IO b) -- ^ computation to run last,
|
||||||
|
-- when an exception was raised
|
||||||
|
-> (a -> IO c) -- ^ computation to run in-between
|
||||||
|
-> IO c
|
||||||
|
bracketeer before after afterEx thing =
|
||||||
|
mask $ \restore -> do
|
||||||
|
a <- before
|
||||||
|
r <- restore (thing a) `onException` afterEx a
|
||||||
|
_ <- after a
|
||||||
|
return r
|
||||||
|
@ -17,4 +17,4 @@ moveFilePortable :: FilePath -> FilePath -> IO ()
|
|||||||
moveFilePortable from to = do
|
moveFilePortable from to = do
|
||||||
copyFile from to
|
copyFile from to
|
||||||
removeFile from
|
removeFile from
|
||||||
|
|
||||||
|
@ -26,7 +26,7 @@ extra-deps:
|
|||||||
- hspec-golden-aeson-0.9.0.0@sha256:aa17274114026661ba4dfc9c60c230673c8f408bd86482fd611d2d5cb6aff996,2179
|
- hspec-golden-aeson-0.9.0.0@sha256:aa17274114026661ba4dfc9c60c230673c8f408bd86482fd611d2d5cb6aff996,2179
|
||||||
- http-io-streams-0.1.6.0@sha256:53f5bab177efb52cd65ec396fd04ed59b93e5f919fb3700cd7dacd6cfce6f06d,3582
|
- http-io-streams-0.1.6.0@sha256:53f5bab177efb52cd65ec396fd04ed59b93e5f919fb3700cd7dacd6cfce6f06d,3582
|
||||||
- libarchive-3.0.3.0
|
- libarchive-3.0.3.0
|
||||||
- libyaml-streamly-0.2.0
|
- libyaml-streamly-0.2.1
|
||||||
- lzma-static-5.2.5.3@sha256:2758ee58c35992fcf7db78e98684c357a16a82fa2a4e7c352a6c210c08c555d8,7308
|
- lzma-static-5.2.5.3@sha256:2758ee58c35992fcf7db78e98684c357a16a82fa2a4e7c352a6c210c08c555d8,7308
|
||||||
- optics-0.4@sha256:9fb69bf0195b8d8f1f8cd0098000946868b8a3c3ffb51e5b64f79fc600c3eb4c,6568
|
- optics-0.4@sha256:9fb69bf0195b8d8f1f8cd0098000946868b8a3c3ffb51e5b64f79fc600c3eb4c,6568
|
||||||
- optics-core-0.4@sha256:59e04aebca536bd011ae50c781937f45af4c1456af1eb9fb578f9a69eee293cd,4995
|
- optics-core-0.4@sha256:59e04aebca536bd011ae50c781937f45af4c1456af1eb9fb578f9a69eee293cd,4995
|
||||||
@ -35,10 +35,11 @@ extra-deps:
|
|||||||
- os-release-1.0.1@sha256:1281c62081f438fc3f0874d3bae6a4887d5964ac25261ba06e29d368ab173467,2716
|
- os-release-1.0.1@sha256:1281c62081f438fc3f0874d3bae6a4887d5964ac25261ba06e29d368ab173467,2716
|
||||||
- primitive-0.7.1.0@sha256:29de6bfd0cf8ba023ceb806203dfbec0e51e3524e75ffe41056f70b4229c6f0f,2728
|
- primitive-0.7.1.0@sha256:29de6bfd0cf8ba023ceb806203dfbec0e51e3524e75ffe41056f70b4229c6f0f,2728
|
||||||
- regex-posix-clib-2.7
|
- regex-posix-clib-2.7
|
||||||
- streamly-0.8.0@sha256:9784c80ee1ada51477520cabc4e92a0c76a6bb265f968a188f2fce818e7398e0,19654
|
- streamly-0.8.2@sha256:ec521b7c1c4db068501c35804af77f40b7d34232f5e29d9b99e722229040eb80,23500
|
||||||
|
- unicode-data-0.3.0@sha256:0545e079705a5381d0893f8fe8daaa08fc9174baeab269b9cf651817d8eadbc6,5123
|
||||||
- strict-base-0.4.0.0@sha256:2ff4e43cb95eedf2995558d7fc34d19362846413dd39e6aa6a5b3ea8228fef9f,1248
|
- strict-base-0.4.0.0@sha256:2ff4e43cb95eedf2995558d7fc34d19362846413dd39e6aa6a5b3ea8228fef9f,1248
|
||||||
- xor-0.0.1.0@sha256:f8362b4a68562b9afbcd727ff64c1a303970df3a032e0033d2f4c094c3501df3,2243
|
- xor-0.0.1.0@sha256:f8362b4a68562b9afbcd727ff64c1a303970df3a032e0033d2f4c094c3501df3,2243
|
||||||
- yaml-streamly-0.12.0
|
- yaml-streamly-0.12.1
|
||||||
|
|
||||||
flags:
|
flags:
|
||||||
http-io-streams:
|
http-io-streams:
|
||||||
|
Loading…
Reference in New Issue
Block a user