From 48aee1e76ccafacf1b46339e792e84d740d922f7 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 12 May 2022 17:58:40 +0200 Subject: [PATCH 01/20] [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. --- .hlint.yaml | 1 + app/ghcup/BrickMain.hs | 3 +- app/ghcup/GHCup/OptParse/Compile.hs | 2 + app/ghcup/GHCup/OptParse/GC.hs | 4 +- app/ghcup/GHCup/OptParse/Install.hs | 7 +- app/ghcup/GHCup/OptParse/Nuke.hs | 2 +- app/ghcup/GHCup/OptParse/Rm.hs | 2 +- app/ghcup/GHCup/OptParse/Run.hs | 2 + ghcup.cabal | 4 +- lib/GHCup.hs | 208 +++++++++++++++---------- lib/GHCup/Errors.hs | 7 + lib/GHCup/Types.hs | 1 + lib/GHCup/Utils.hs | 85 +++++++++- lib/GHCup/Utils/Dirs.hs | 25 ++- lib/GHCup/Utils/File.hs | 86 ++++++++++ lib/GHCup/Utils/File/Common.hs | 8 +- lib/GHCup/Utils/File/Posix.hs | 168 +++++++++++++++++++- lib/GHCup/Utils/File/Posix/Foreign.hsc | 77 +++++++++ lib/GHCup/Utils/File/Windows.hs | 18 ++- lib/GHCup/Utils/Prelude.hs | 26 +++- lib/GHCup/Utils/Prelude/Posix.hs | 2 +- stack.yaml | 7 +- 22 files changed, 628 insertions(+), 117 deletions(-) create mode 100644 lib/GHCup/Utils/File/Posix/Foreign.hsc diff --git a/.hlint.yaml b/.hlint.yaml index 3540f0e..e7fea9c 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -20,6 +20,7 @@ - ignore: {name: "Avoid lambda"} - ignore: {name: "Use uncurry"} - ignore: {name: "Use replicateM"} +- ignore: {name: "Use unless"} - ignore: {name: "Redundant irrefutable pattern"} diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index de367e8..19499ca 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -438,6 +438,7 @@ install' _ (_, ListResult {..}) = do , FileAlreadyExistsError , ProcessError , GHCupShadowed + , UninstallFailed ] run (do @@ -512,7 +513,7 @@ del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnlif del' _ (_, ListResult {..}) = do AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask - let run = runE @'[NotInstalled] + let run = runE @'[NotInstalled, UninstallFailed] run (do let vi = getVersionInfo lVer lTool dls diff --git a/app/ghcup/GHCup/OptParse/Compile.hs b/app/ghcup/GHCup/OptParse/Compile.hs index 6989af9..f15793f 100644 --- a/app/ghcup/GHCup/OptParse/Compile.hs +++ b/app/ghcup/GHCup/OptParse/Compile.hs @@ -388,6 +388,7 @@ type GHCEffects = '[ AlreadyInstalled , ProcessError , CopyError , BuildFailed + , UninstallFailed ] type HLSEffects = '[ AlreadyInstalled , BuildFailed @@ -406,6 +407,7 @@ type HLSEffects = '[ AlreadyInstalled , NotInstalled , DirNotEmpty , ArchiveResult + , UninstallFailed ] diff --git a/app/ghcup/GHCup/OptParse/GC.hs b/app/ghcup/GHCup/OptParse/GC.hs index f8a1310..b3a28f7 100644 --- a/app/ghcup/GHCup/OptParse/GC.hs +++ b/app/ghcup/GHCup/OptParse/GC.hs @@ -98,7 +98,7 @@ gcFooter = [s|Discussion: --------------------------- -type GCEffects = '[ NotInstalled ] +type GCEffects = '[ NotInstalled, UninstallFailed ] runGC :: MonadUnliftIO m @@ -129,7 +129,7 @@ gc :: ( Monad m -> (ReaderT LeanAppState m () -> m ()) -> m ExitCode gc GCOptions{..} runAppState runLogger = runGC runAppState (do - when gcOldGHC rmOldGHC + when gcOldGHC (liftE rmOldGHC) lift $ when gcProfilingLibs rmProfilingLibs lift $ when gcShareDir rmShareDir liftE $ when gcHLSNoGHC rmHLSNoGHC diff --git a/app/ghcup/GHCup/OptParse/Install.hs b/app/ghcup/GHCup/OptParse/Install.hs index 363ce51..4c3d5b1 100644 --- a/app/ghcup/GHCup/OptParse/Install.hs +++ b/app/ghcup/GHCup/OptParse/Install.hs @@ -257,6 +257,7 @@ type InstallEffects = '[ AlreadyInstalled , NoToolVersionSet , FileAlreadyExistsError , ProcessError + , UninstallFailed , (AlreadyInstalled, ()) , (UnknownArchive, ()) @@ -264,9 +265,9 @@ type InstallEffects = '[ AlreadyInstalled , (FileDoesNotExistError, ()) , (CopyError, ()) , (NotInstalled, ()) + , (UninstallFailed, ()) , (DirNotEmpty, ()) , (NoDownload, ()) - , (NotInstalled, ()) , (BuildFailed, ()) , (TagNotFound, ()) , (DigestError, ()) @@ -287,6 +288,7 @@ type InstallEffects = '[ AlreadyInstalled , (DirNotEmpty, NotInstalled) , (NoDownload, NotInstalled) , (NotInstalled, NotInstalled) + , (UninstallFailed, NotInstalled) , (BuildFailed, NotInstalled) , (TagNotFound, NotInstalled) , (DigestError, NotInstalled) @@ -319,6 +321,7 @@ type InstallGHCEffects = '[ TagNotFound , BuildFailed , DirNotEmpty , AlreadyInstalled + , UninstallFailed , (AlreadyInstalled, NotInstalled) , (UnknownArchive, NotInstalled) @@ -328,6 +331,7 @@ type InstallGHCEffects = '[ TagNotFound , (NotInstalled, NotInstalled) , (DirNotEmpty, NotInstalled) , (NoDownload, NotInstalled) + , (UninstallFailed, NotInstalled) , (BuildFailed, NotInstalled) , (TagNotFound, NotInstalled) , (DigestError, NotInstalled) @@ -347,6 +351,7 @@ type InstallGHCEffects = '[ TagNotFound , (NotInstalled, ()) , (DirNotEmpty, ()) , (NoDownload, ()) + , (UninstallFailed, ()) , (BuildFailed, ()) , (TagNotFound, ()) , (DigestError, ()) diff --git a/app/ghcup/GHCup/OptParse/Nuke.hs b/app/ghcup/GHCup/OptParse/Nuke.hs index 75537de..43bcc7c 100644 --- a/app/ghcup/GHCup/OptParse/Nuke.hs +++ b/app/ghcup/GHCup/OptParse/Nuke.hs @@ -42,7 +42,7 @@ import Control.Concurrent (threadDelay) --------------------------- -type NukeEffects = '[ NotInstalled ] +type NukeEffects = '[ NotInstalled, UninstallFailed ] runNuke :: AppState diff --git a/app/ghcup/GHCup/OptParse/Rm.hs b/app/ghcup/GHCup/OptParse/Rm.hs index 591840e..d91faef 100644 --- a/app/ghcup/GHCup/OptParse/Rm.hs +++ b/app/ghcup/GHCup/OptParse/Rm.hs @@ -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)) diff --git a/app/ghcup/GHCup/OptParse/Run.hs b/app/ghcup/GHCup/OptParse/Run.hs index 7f95021..78393f8 100644 --- a/app/ghcup/GHCup/OptParse/Run.hs +++ b/app/ghcup/GHCup/OptParse/Run.hs @@ -176,6 +176,7 @@ type RunEffects = '[ AlreadyInstalled , NoToolVersionSet , FileAlreadyExistsError , ProcessError + , UninstallFailed ] runLeanRUN :: (MonadUnliftIO m, MonadIO m) @@ -339,6 +340,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do , AlreadyInstalled , FileAlreadyExistsError , CopyError + , UninstallFailed ] (ResourceT (ReaderT AppState m)) () installToolChainFull Toolchain{..} tmp = do forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do diff --git a/ghcup.cabal b/ghcup.cabal index 64889bc..6a12eca 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ghcup -version: 0.1.17.8 +version: 0.1.18.0 license: LGPL-3.0-only license-file: LICENSE copyright: Julian Ospald 2020 @@ -127,6 +127,7 @@ library , safe-exceptions ^>=0.1 , split ^>=0.2.3.4 , strict-base ^>=0.4 + , streamly ^>=0.8.2 , template-haskell >=2.7 && <2.18 , temporary ^>=1.3 , text ^>=1.2.4.0 @@ -165,6 +166,7 @@ library else other-modules: GHCup.Utils.File.Posix + GHCup.Utils.File.Posix.Foreign GHCup.Utils.Posix GHCup.Utils.Prelude.Posix diff --git a/lib/GHCup.hs b/lib/GHCup.hs index be7c681..c8c6c4a 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -77,7 +77,7 @@ import Prelude hiding ( abs , writeFile ) import Safe hiding ( at ) -import System.Directory hiding ( findFiles ) +import System.Directory hiding ( findFiles, copyFile ) import System.Environment import System.FilePath import System.IO.Error @@ -202,6 +202,7 @@ installGHCBindist :: ( MonadFail m , DirNotEmpty , ArchiveResult , ProcessError + , UninstallFailed ] m () @@ -269,6 +270,7 @@ installPackedGHC :: ( MonadMask m , MonadIO m , MonadUnliftIO m , MonadFail m + , MonadResource m ) => FilePath -- ^ Path to the packed GHC bindist -> Maybe TarDir -- ^ Subdir of the archive @@ -300,12 +302,7 @@ installPackedGHC dl msubdir inst ver forceInstall = do msubdir liftE $ runBuildAction tmpUnpack - (case inst of - 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) + (installUnpackedGHC workdir inst ver forceInstall) -- | Install an unpacked GHC distribution. This only deals with the GHC @@ -319,21 +316,27 @@ installUnpackedGHC :: ( MonadReader env m , MonadIO m , MonadUnliftIO m , MonadMask m + , MonadResource m + , MonadFail m ) => FilePath -- ^ Path to the unpacked GHC bindist (where the configure script resides) -> InstallDirResolved -- ^ Path to install to -> Version -- ^ The GHC version + -> Bool -- ^ Force install -> Excepts '[ProcessError] m () -installUnpackedGHC path (fromInstallDir -> inst) ver +installUnpackedGHC path inst ver forceInstall | isWindows = do lift $ logInfo "Installing GHC (this may take a while)" -- Windows bindists are relocatable and don't need -- to run configure. -- 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 moveFilePortable source dest setModificationTime dest mtime + case inst of + IsolateDirResolved _ -> pure () + _ -> recordInstalledFiles fs GHC (mkTVer ver) | otherwise = do PlatformRequest {..} <- lift getPlatformReq @@ -345,13 +348,21 @@ installUnpackedGHC path (fromInstallDir -> inst) ver lift $ logInfo "Installing GHC (this may take a while)" lEM $ execLogged "sh" - ("./configure" : ("--prefix=" <> inst) + ("./configure" : ("--prefix=" <> fromInstallDir inst) : alpineArgs ) (Just path) "ghc-configure" 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 () @@ -389,6 +400,7 @@ installGHCBin :: ( MonadFail m , DirNotEmpty , ArchiveResult , ProcessError + , UninstallFailed ] m () @@ -493,12 +505,10 @@ installCabalUnpacked path inst ver forceInstall = do <> exeExt let destPath = fromInstallDir inst destFileName - unless forceInstall -- Overwrite it when it IS a force install - (liftE $ throwIfFileAlreadyExists destPath) - copyFileE (path cabalFile <> exeExt) destPath + (not forceInstall) lift $ chmod_755 destPath -- | Installs cabal into @~\/.ghcup\/bin/cabal-\@ and @@ -572,6 +582,7 @@ installHLSBindist :: ( MonadMask m , FileAlreadyExistsError , ProcessError , DirNotEmpty + , UninstallFailed ] m () @@ -620,15 +631,15 @@ installHLSBindist dlinfo ver installDir forceInstall = do lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir if legacy 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 if legacy then liftE $ installHLSUnpackedLegacy workdir (GHCupDir binDir) ver forceInstall else do inst <- ghcupHLSDir ver - liftE $ runBuildAction tmpUnpack (Just inst) - $ installHLSUnpacked workdir (GHCupDir inst) ver + liftE $ runBuildAction tmpUnpack + $ installHLSUnpacked workdir (GHCupDir inst) ver forceInstall liftE $ setHLS ver SetHLS_XYZ Nothing @@ -638,15 +649,32 @@ isLegacyHLSBindist path = do not <$> doesFileExist (path "GNUmakefile") -- | 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) -> InstallDirResolved -- ^ Path to install to -> Version + -> Bool -> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled] m () -installHLSUnpacked path (fromInstallDir -> inst) _ = do +installHLSUnpacked path inst ver forceInstall = do lift $ logInfo "Installing HLS" - liftIO $ createDirRecursive' inst - lEM $ make ["PREFIX=" <> inst, "install"] (Just path) + tmpInstallDest <- lift withGHCupTmpDir + 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). 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 destPath = fromInstallDir installDir toF - unless forceInstall -- if it is a force install, overwrite it. - (liftE $ throwIfFileAlreadyExists destPath) - copyFileE srcPath destPath + (not forceInstall) lift $ chmod_755 destPath -- install haskell-language-server-wrapper @@ -696,12 +722,10 @@ installHLSUnpackedLegacy path installDir ver forceInstall = do srcWrapperPath = path wrapper <> exeExt destWrapperPath = fromInstallDir installDir toF - unless forceInstall - (liftE $ throwIfFileAlreadyExists destWrapperPath) - copyFileE srcWrapperPath destWrapperPath + (not forceInstall) lift $ chmod_755 destWrapperPath @@ -739,6 +763,7 @@ installHLSBin :: ( MonadMask m , FileAlreadyExistsError , ProcessError , DirNotEmpty + , UninstallFailed ] m () @@ -850,7 +875,6 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc liftE $ runBuildAction workdir - Nothing (reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed workdir) $ do let tmpInstallDir = workdir "out" liftIO $ createDirRecursive' tmpInstallDir @@ -862,19 +886,19 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc cp <- case cabalProject of Just (Left cp) | isAbsolute cp -> do - copyFileE cp (workdir "cabal.project") + copyFileE cp (workdir "cabal.project") False pure "cabal.project" | otherwise -> pure (takeFileName cp) Just (Right uri) -> do tmpUnpack <- lift withGHCupTmpDir 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" Nothing -> pure "cabal.project" forM_ cabalProjectLocal $ \uri -> do tmpUnpack <- lift withGHCupTmpDir 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 let ghcInstallDir = tmpInstallDir T.unpack (prettyVer ghc) liftIO $ createDirRecursive' tmpInstallDir @@ -1049,12 +1073,10 @@ installStackUnpacked path installDir ver forceInstall = do <> exeExt destPath = fromInstallDir installDir destFileName - unless forceInstall - (liftE $ throwIfFileAlreadyExists destPath) - copyFileE (path stackFile <> exeExt) destPath + (not forceInstall) lift $ chmod_755 destPath @@ -1754,12 +1776,11 @@ rmGHCVer :: ( MonadReader env m , MonadUnliftIO m ) => GHCTargetVersion - -> Excepts '[NotInstalled] m () + -> Excepts '[NotInstalled, UninstallFailed] m () rmGHCVer ver = do isSetGHC <- lift $ fmap (== Just ver) $ ghcSet (_tvTarget ver) whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC ver)) - dir <- lift $ ghcupGHCDir ver -- this isn't atomic, order matters when isSetGHC $ do @@ -1774,8 +1795,19 @@ rmGHCVer ver = do handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorGHCSymlinks ver -- then fix them (e.g. with an earlier version) - lift $ logInfo $ "Removing directory recursively: " <> T.pack dir - lift $ recyclePathForcibly dir + dir <- lift $ ghcupGHCDir ver + 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' <- handle @@ -1834,23 +1866,37 @@ rmHLSVer :: ( MonadMask m , MonadUnliftIO m ) => Version - -> Excepts '[NotInstalled] m () + -> Excepts '[NotInstalled, UninstallFailed] m () rmHLSVer ver = do whenM (lift $ fmap not $ hlsInstalled ver) $ throwE (NotInstalled HLS (GHCTargetVersion Nothing ver)) isHlsSet <- lift hlsSet liftE $ rmMinorHLSSymlinks ver - hlsDir <- ghcupHLSDir ver - recyclePathForcibly hlsDir when (Just ver == isHlsSet) $ do -- 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 hlsVers <- lift $ fmap rights getInstalledHLSs case headMay . reverse . sort $ hlsVers of - Just latestver -> setHLS latestver SetHLSOnly Nothing + Just latestver -> liftE $ setHLS latestver SetHLSOnly Nothing Nothing -> pure () @@ -1946,15 +1992,15 @@ rmTool :: ( MonadReader env m , MonadMask m , MonadUnliftIO m) => ListResult - -> Excepts '[NotInstalled ] m () + -> Excepts '[NotInstalled, UninstallFailed] m () rmTool ListResult {lVer, lTool, lCross} = do case lTool of GHC -> let ghcTargetVersion = GHCTargetVersion lCross lVer in rmGHCVer ghcTargetVersion HLS -> rmHLSVer lVer - Cabal -> rmCabalVer lVer - Stack -> rmStackVer lVer + Cabal -> liftE $ rmCabalVer lVer + Stack -> liftE $ rmStackVer lVer 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 enFilePath = do 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 confFilePath = do 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 dir = @@ -2020,7 +2066,7 @@ rmGhcupDirs = do hideErrorDef [doesNotExistErrorType] () $ do logInfo $ "removing " <> T.pack 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 binDir @@ -2049,35 +2095,33 @@ rmGhcupDirs = do compareFn :: FilePath -> FilePath -> Ordering compareFn fp1 fp2 = compare (calcDepth fp1) (calcDepth fp2) - 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 +-- we expect only files inside cache/log dir +-- we report remaining files/dirs later, +-- hence the force/quiet mode in these delete functions below. +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 - -- we report remaining files/dirs later, - -- hence the force/quiet mode in these delete functions below. - - deleteFile :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m) => FilePath -> m () - deleteFile filepath = do - hideError doesNotExistErrorType - $ hideError InappropriateType $ rmFile filepath - - removeDirIfEmptyOrIsSymlink :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m () - removeDirIfEmptyOrIsSymlink filepath = - hideError UnsatisfiedConstraints $ - 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 +removeDirIfEmptyOrIsSymlink :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m () +removeDirIfEmptyOrIsSymlink filepath = + hideError UnsatisfiedConstraints $ + 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 , CopyError , BuildFailed + , UninstallFailed ] m GHCTargetVersion @@ -2252,7 +2297,6 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr (mBindist, bmk) <- liftE $ runBuildAction tmpUnpack - Nothing (do b <- if hadrian then compileHadrianBindist tver workdir ghcdir @@ -2387,7 +2431,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr Just bc -> liftIOException doesNotExistErrorType (FileDoesNotExistError bc) - (liftIO $ copyFile bc (build_mk workdir)) + (liftIO $ copyFile bc (build_mk workdir) False) Nothing -> liftIO $ T.writeFile (build_mk workdir) (addBuildFlavourToConf defaultConf) @@ -2453,8 +2497,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr <> ".tar" <> takeExtension tar) let tarPath = cacheDir tarName - copyFileE (workdir tar) - tarPath + copyFileE (workdir tar) tarPath False lift $ logInfo $ "Copied bindist to " <> T.pack tarPath pure tarPath @@ -2637,8 +2680,7 @@ upgradeGHCup mtarget force' fatal = do lift $ logDebug $ "rm -f " <> T.pack destFile lift $ hideError NoSuchThing $ recycleFile destFile lift $ logDebug $ "cp " <> T.pack p <> " " <> T.pack destFile - copyFileE p - destFile + copyFileE p destFile False lift $ chmod_755 destFile liftIO (isInPath destFile) >>= \b -> unless b $ @@ -2793,7 +2835,7 @@ rmOldGHC :: ( MonadReader env m , MonadMask m , MonadUnliftIO m ) - => Excepts '[NotInstalled] m () + => Excepts '[NotInstalled, UninstallFailed] m () rmOldGHC = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let oldGHCs = mkTVer <$> toListOf (ix GHC % getTagged Old % to fst) dls @@ -2859,7 +2901,7 @@ rmHLSNoGHC :: ( MonadReader env m , MonadFail m , MonadUnliftIO m ) - => Excepts '[NotInstalled] m () + => Excepts '[NotInstalled, UninstallFailed] m () rmHLSNoGHC = do Dirs {..} <- getDirs ghcs <- fmap rights getInstalledGHCs diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index df72bd2..33c8332 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -146,6 +146,13 @@ instance Pretty NotInstalled where pPrint (NotInstalled tool ver) = 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. data NotFoundInPATH = NotFoundInPATH FilePath deriving Show diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 93b985e..6286347 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -443,6 +443,7 @@ data Dirs = Dirs , cacheDir :: FilePath , logsDir :: FilePath , confDir :: FilePath + , dbDir :: FilePath , recycleDir :: FilePath -- mainly used on windows } deriving (Show, GHC.Generic) diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index e142cc9..37f7444 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} @@ -71,7 +72,7 @@ import GHC.IO.Exception import Haskus.Utils.Variant.Excepts import Optics import Safe -import System.Directory hiding ( findFiles ) +import System.Directory hiding ( findFiles, copyFile ) import System.FilePath import System.IO.Error import Text.Regex.Posix @@ -86,6 +87,9 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as E import qualified Text.Megaparsec as MP import qualified Data.List.NonEmpty as NE +import Text.PrettyPrint.HughesPJClass (prettyShow) +import Control.DeepSeq (force) +import GHC.IO (evaluate) -- $setup @@ -1051,14 +1055,11 @@ runBuildAction :: ( MonadReader env m , MonadCatch m ) => 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 -runBuildAction bdir instdir action = do +runBuildAction bdir action = do Settings {..} <- lift getSettings let exAction = do - forM_ instdir $ \dir -> - hideError doesNotExistErrorType $ recyclePathForcibly dir when (keepDirs == Never) $ rmBDir bdir v <- @@ -1089,6 +1090,26 @@ cleanUpOnError bdir action = do 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 -- printing other errors without crashing. @@ -1194,7 +1215,7 @@ createLink link exe rmLink exe logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe - liftIO $ copyFile shimGen exe + liftIO $ copyFile shimGen exe False liftIO $ writeFile shim shimContents | otherwise = do logDebug $ "rm -f " <> T.pack exe @@ -1234,7 +1255,7 @@ ensureGlobalTools -- | Ensure ghcup directory structure exists. 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 "ghc") createDirRecursive' binDir @@ -1242,6 +1263,7 @@ ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir) = do createDirRecursive' logsDir createDirRecursive' confDir createDirRecursive' trashDir + createDirRecursive' dbDir pure () @@ -1272,3 +1294,52 @@ installDestSanityCheck (IsolateDirResolved isoDir) = do contents <- liftIO $ getDirectoryContentsRecursive isoDir unless (null contents) (throwE $ DirNotEmpty isoDir) 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')) + + diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs index b2fb7eb..6a060b0 100644 --- a/lib/GHCup/Utils/Dirs.hs +++ b/lib/GHCup/Utils/Dirs.hs @@ -53,8 +53,8 @@ import Data.Versions import GHC.IO.Exception ( IOErrorType(NoSuchThing) ) import Haskus.Utils.Variant.Excepts import Optics -import System.Directory -import System.DiskSpace +import System.Directory +import System.DiskSpace import System.Environment import System.FilePath import System.IO.Temp @@ -180,6 +180,26 @@ ghcupLogsDir 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'. -- Mainly used on windows to improve file removal operations ghcupRecycleDir :: IO FilePath @@ -195,6 +215,7 @@ getAllDirs = do logsDir <- ghcupLogsDir confDir <- ghcupConfigDir recycleDir <- ghcupRecycleDir + dbDir <- ghcupDbDir pure Dirs { .. } diff --git a/lib/GHCup/Utils/File.hs b/lib/GHCup/Utils/File.hs index 9f74867..a08c981 100644 --- a/lib/GHCup/Utils/File.hs +++ b/lib/GHCup/Utils/File.hs @@ -1,6 +1,16 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module GHCup.Utils.File ( + mergeFileTree, + mergeFileTreeAll, + copyFileE, module GHCup.Utils.File.Common, #if IS_WINDOWS module GHCup.Utils.File.Windows @@ -15,3 +25,79 @@ import GHCup.Utils.File.Windows #else import GHCup.Utils.File.Posix #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 diff --git a/lib/GHCup/Utils/File/Common.hs b/lib/GHCup/Utils/File/Common.hs index 4818fa9..f72e38c 100644 --- a/lib/GHCup/Utils/File/Common.hs +++ b/lib/GHCup/Utils/File/Common.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} @@ -15,14 +16,11 @@ import Data.Maybe import Data.Text ( Text ) import Data.Void import GHC.IO.Exception -import Optics hiding ((<|), (|>)) -import System.Directory hiding (findFiles) +import System.Directory hiding (findFiles, copyFile) import System.FilePath -import Text.PrettyPrint.HughesPJClass hiding ( (<>) ) import Text.Regex.Posix import qualified Data.Text as T -import qualified Data.ByteString.Lazy as BL import qualified Text.Megaparsec as MP @@ -109,3 +107,5 @@ findFiles' path parser = do checkFileAlreadyExists :: (MonadIO m) => FilePath -> m Bool checkFileAlreadyExists fp = liftIO $ doesFileExist fp + + diff --git a/lib/GHCup/Utils/File/Posix.hs b/lib/GHCup/Utils/File/Posix.hs index ac60b3c..94c023b 100644 --- a/lib/GHCup/Utils/File/Posix.hs +++ b/lib/GHCup/Utils/File/Posix.hs @@ -34,12 +34,16 @@ import Data.IORef import Data.Sequence ( Seq, (|>) ) import Data.List import Data.Word8 +import Foreign.C.String +import Foreign.C.Types import GHC.IO.Exception -import System.IO ( stderr ) +import System.IO ( stderr, hClose, hSetBinaryMode ) import System.IO.Error import System.FilePath -import System.Directory +import System.Directory hiding ( copyFile ) import System.Posix.Directory +import System.Posix.Error ( throwErrnoPathIfMinus1Retry ) +import System.Posix.Internals ( withFilePath ) import System.Posix.Files import System.Posix.IO import System.Posix.Process ( ProcessStatus(..) ) @@ -50,12 +54,20 @@ import qualified Control.Exception as EX import qualified Data.Sequence as Sq import qualified Data.Text as T 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.IO as SPI import qualified System.Console.Terminal.Size as TP +import qualified System.Posix as Posix import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import qualified "unix-bytestring" System.Posix.IO.ByteString 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 Left e | isDoesNotExistError e -> pure False | 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) diff --git a/lib/GHCup/Utils/File/Posix/Foreign.hsc b/lib/GHCup/Utils/File/Posix/Foreign.hsc new file mode 100644 index 0000000..59cbe74 --- /dev/null +++ b/lib/GHCup/Utils/File/Posix/Foreign.hsc @@ -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 +#include +#include +#include +#include +#include + +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 #-} diff --git a/lib/GHCup/Utils/File/Windows.hs b/lib/GHCup/Utils/File/Windows.hs index 5942531..4d70422 100644 --- a/lib/GHCup/Utils/File/Windows.hs +++ b/lib/GHCup/Utils/File/Windows.hs @@ -31,12 +31,13 @@ import Data.List import Foreign.C.Error import GHC.IO.Exception import GHC.IO.Handle -import System.Directory +import System.Directory hiding ( copyFile ) import System.Environment import System.FilePath import System.IO import System.Process - + +import qualified System.Win32.File as WS import qualified Control.Exception as EX import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL @@ -269,3 +270,16 @@ isBrokenSymlink fp = do -- this drops 'symDir' if 'tfp' is absolute (takeDirectory fp tfp) 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 diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Utils/Prelude.hs index db2fbdc..40ae60d 100644 --- a/lib/GHCup/Utils/Prelude.hs +++ b/lib/GHCup/Utils/Prelude.hs @@ -58,7 +58,7 @@ import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty ) import System.IO.Error import System.IO.Temp import System.IO.Unsafe -import System.Directory +import System.Directory hiding ( copyFile ) import System.FilePath import Control.Retry @@ -412,7 +412,7 @@ copyDirectoryRecursive srcDir destDir doCopy = do copyFilesWith targetDir srcFiles = do -- 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 -- 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 -- the source directory structure changes before the list is used. -- +-- TODO: use streamly getDirectoryContentsRecursive :: FilePath -> IO [FilePath] getDirectoryContentsRecursive topdir = recurseDirectories [""] where @@ -549,10 +550,6 @@ recover 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 -- -- >>> traverseFold (pure . (:["0"])) ["1","2"] @@ -763,3 +760,20 @@ breakOn needle haystack | needle `isPrefixOf` haystack = ([], haystack) breakOn _ [] = ([], []) 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 diff --git a/lib/GHCup/Utils/Prelude/Posix.hs b/lib/GHCup/Utils/Prelude/Posix.hs index 22ae3cb..f677a68 100644 --- a/lib/GHCup/Utils/Prelude/Posix.hs +++ b/lib/GHCup/Utils/Prelude/Posix.hs @@ -17,4 +17,4 @@ moveFilePortable :: FilePath -> FilePath -> IO () moveFilePortable from to = do copyFile from to removeFile from - + diff --git a/stack.yaml b/stack.yaml index 14c8bbf..6357d4f 100644 --- a/stack.yaml +++ b/stack.yaml @@ -26,7 +26,7 @@ extra-deps: - hspec-golden-aeson-0.9.0.0@sha256:aa17274114026661ba4dfc9c60c230673c8f408bd86482fd611d2d5cb6aff996,2179 - http-io-streams-0.1.6.0@sha256:53f5bab177efb52cd65ec396fd04ed59b93e5f919fb3700cd7dacd6cfce6f06d,3582 - libarchive-3.0.3.0 - - libyaml-streamly-0.2.0 + - libyaml-streamly-0.2.1 - lzma-static-5.2.5.3@sha256:2758ee58c35992fcf7db78e98684c357a16a82fa2a4e7c352a6c210c08c555d8,7308 - optics-0.4@sha256:9fb69bf0195b8d8f1f8cd0098000946868b8a3c3ffb51e5b64f79fc600c3eb4c,6568 - optics-core-0.4@sha256:59e04aebca536bd011ae50c781937f45af4c1456af1eb9fb578f9a69eee293cd,4995 @@ -35,10 +35,11 @@ extra-deps: - os-release-1.0.1@sha256:1281c62081f438fc3f0874d3bae6a4887d5964ac25261ba06e29d368ab173467,2716 - primitive-0.7.1.0@sha256:29de6bfd0cf8ba023ceb806203dfbec0e51e3524e75ffe41056f70b4229c6f0f,2728 - 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 - xor-0.0.1.0@sha256:f8362b4a68562b9afbcd727ff64c1a303970df3a032e0033d2f4c094c3501df3,2243 - - yaml-streamly-0.12.0 + - yaml-streamly-0.12.1 flags: http-io-streams: From db4e411dfdcce87f2f793a8c6af860b5104de244 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 13 May 2022 11:58:01 +0200 Subject: [PATCH 02/20] Fix darwin binaries after copying --- lib/GHCup.hs | 8 ++++-- lib/GHCup/Utils.hs | 2 ++ lib/GHCup/Utils/File/Posix.hs | 45 ++++++++++++--------------------- lib/GHCup/Utils/File/Windows.hs | 1 + lib/GHCup/Utils/Prelude.hs | 18 ------------- 5 files changed, 25 insertions(+), 49 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index c8c6c4a..d6fae22 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -359,7 +359,8 @@ installUnpackedGHC path inst ver forceInstall 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)) + (\f t -> liftIO (install f t (not forceInstall))) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromInstallDir inst) case inst of IsolateDirResolved _ -> pure () _ -> recordInstalledFiles fs GHC (mkTVer ver) @@ -659,6 +660,7 @@ installHLSUnpacked :: ( MonadMask m , MonadCatch m , MonadIO m , MonadResource m + , HasPlatformReq env ) => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) -> InstallDirResolved -- ^ Path to install to @@ -666,12 +668,14 @@ installHLSUnpacked :: ( MonadMask m -> Bool -> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled] m () installHLSUnpacked path inst ver forceInstall = do + PlatformRequest { .. } <- lift getPlatformReq lift $ logInfo "Installing HLS" tmpInstallDest <- lift withGHCupTmpDir 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)) + (\f t -> liftIO (install f t (not forceInstall))) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromInstallDir inst) case inst of IsolateDirResolved _ -> pure () _ -> recordInstalledFiles fs HLS (mkTVer ver) diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 37f7444..4e31b09 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -1033,6 +1033,8 @@ darwinNotarization Darwin path = exec darwinNotarization _ _ = pure $ Right () + + getChangeLog :: GHCupDownloads -> Tool -> Either Version Tag -> Maybe URI getChangeLog dls tool (Left v') = preview (ix tool % ix v' % viChangeLog % _Just) dls diff --git a/lib/GHCup/Utils/File/Posix.hs b/lib/GHCup/Utils/File/Posix.hs index 94c023b..24069a0 100644 --- a/lib/GHCup/Utils/File/Posix.hs +++ b/lib/GHCup/Utils/File/Posix.hs @@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiWayIf #-} {-| Module : GHCup.Utils.File.Posix @@ -418,41 +420,25 @@ copyFile :: FilePath -- ^ source file -> 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') + (openFdHandle from SPI.ReadOnly [FD.oNofollow] Nothing) + (hClose . snd) $ \(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 () - ) + sourceFileMode <- fileMode <$> getFdStatus fromFd + let dflags = [ FD.oNofollow + , if fail' then FD.oExcl else FD.oTrunc + ] + bracket + (openFdHandle to SPI.WriteOnly dflags $ Just sourceFileMode) + (hClose . snd) $ \(_, tH) -> do hSetBinaryMode fH True hSetBinaryMode tH True streamlyCopy (fH, tH) where + openFdHandle fp omode flags fM = do + fd <- openFd' fp omode flags fM + handle' <- SPI.fdToHandle fd + pure (fd, handle') streamlyCopy (fH, tH) = S.fold (FH.writeChunks tH) $ IFH.toChunksWithBufferOf (256 * 1024) fH @@ -563,3 +549,4 @@ install from to fail' = do 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) + diff --git a/lib/GHCup/Utils/File/Windows.hs b/lib/GHCup/Utils/File/Windows.hs index 4d70422..36f529f 100644 --- a/lib/GHCup/Utils/File/Windows.hs +++ b/lib/GHCup/Utils/File/Windows.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} {-| Module : GHCup.Utils.File.Windows diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Utils/Prelude.hs index 40ae60d..668fde2 100644 --- a/lib/GHCup/Utils/Prelude.hs +++ b/lib/GHCup/Utils/Prelude.hs @@ -759,21 +759,3 @@ breakOn :: Eq a => [a] -> [a] -> ([a], [a]) breakOn needle haystack | needle `isPrefixOf` haystack = ([], haystack) breakOn _ [] = ([], []) 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 From fa924eac153d1c47c2651c989ae5c36990a48604 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 13 May 2022 10:32:44 +0200 Subject: [PATCH 03/20] Fix CI --- .gitlab-ci.yml | 112 ++++++++++++++++++-------------- .gitlab/ghcup_env | 28 +++++--- .gitlab/script/brew.sh | 19 ++++++ .gitlab/script/ci.sh | 70 ++++++++++++++++++++ .gitlab/script/ghcup_version.sh | 14 ++-- 5 files changed, 181 insertions(+), 62 deletions(-) create mode 100755 .gitlab/script/brew.sh create mode 100755 .gitlab/script/ci.sh diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 0860003..6b43bbf 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -13,7 +13,7 @@ variables: # Sequential version number of all cached things. # Bump to invalidate GitLab CI cache. - CACHE_REV: 0 + CACHE_REV: 1 GIT_SUBMODULE_STRATEGY: recursive @@ -125,6 +125,10 @@ variables: - test/golden - dist-newstyle/cache/ when: on_failure + cache: + key: ghcup-test-$CACHE_REV + paths: + - cabal-cache # .test_ghcup_scoop: # script: @@ -134,72 +138,77 @@ variables: extends: - .test_ghcup_version - .debian - - .root_cleanup before_script: - ./.gitlab/before_script/linux/install_deps.sh + - ./.gitlab/script/ci.sh extract_cabal_cache + after_script: + - ./.gitlab/script/ci.sh save_cabal_cache + - bash ./.gitlab/after_script.sh .test_ghcup_version:linux32: extends: - .test_ghcup_version - .alpine:32bit - - .root_cleanup before_script: - ./.gitlab/before_script/linux/alpine/install_deps.sh + - ./.gitlab/script/ci.sh extract_cabal_cache + after_script: + - ./.gitlab/script/ci.sh save_cabal_cache + - bash ./.gitlab/after_script.sh .test_ghcup_version:armv7: extends: - .test_ghcup_version - .linux:armv7 - - .root_cleanup before_script: - ./.gitlab/before_script/linux/install_deps.sh + - ./.gitlab/script/ci.sh extract_cabal_cache + after_script: + - ./.gitlab/script/ci.sh save_cabal_cache + - bash ./.gitlab/after_script.sh .test_ghcup_version:aarch64: extends: - .test_ghcup_version - .linux:aarch64 - - .root_cleanup before_script: - ./.gitlab/before_script/linux/install_deps.sh + - ./.gitlab/script/ci.sh extract_cabal_cache + after_script: + - ./.gitlab/script/ci.sh save_cabal_cache + - bash ./.gitlab/after_script.sh .test_ghcup_version:darwin: extends: - .test_ghcup_version - .darwin - - .root_cleanup before_script: - ./.gitlab/before_script/darwin/install_deps.sh + - ./.gitlab/script/ci.sh extract_cabal_cache + after_script: + - ./.gitlab/script/ci.sh save_cabal_cache + - bash ./.gitlab/after_script.sh .test_ghcup_version:darwin:aarch64: extends: - .test_ghcup_version - .darwin:aarch64 - - .root_cleanup cache: key: darwin-brew-$CACHE_REV paths: - - .brew - - .brew_cache + - brew_cache + key: ghcup-test-$CACHE_REV + paths: + - cabal-cache before_script: - # Install brew locally in the project dir. Packages will also be installed here. - - '[ -e "$CI_PROJECT_DIR/.brew" ] || git clone --depth=1 https://github.com/Homebrew/brew $CI_PROJECT_DIR/.brew' - - export PATH="$CI_PROJECT_DIR/.brew/bin:$CI_PROJECT_DIR/.brew/sbin:$PATH" - + # extract brew cache + - ./.gitlab/script/ci.sh extract_brew_cache # otherwise we seem to get intel binaries - export HOMEBREW_CHANGE_ARCH_TO_ARM=1 - - # make sure to not pollute the machine with temp files etc - - mkdir -p $CI_PROJECT_DIR/.brew_cache - - export HOMEBREW_CACHE=$CI_PROJECT_DIR/.brew_cache - - mkdir -p $CI_PROJECT_DIR/.brew_logs - - export HOMEBREW_LOGS=$CI_PROJECT_DIR/.brew_logs - - mkdir -p /private/tmp/.brew_tmp - - export HOMEBREW_TEMP=/private/tmp/.brew_tmp - # update and install packages - - brew update - - brew install llvm - - brew install autoconf automake coreutils + - /bin/bash ./.gitlab/script/brew.sh llvm autoconf automake + # extract cabal cache + - ./.gitlab/script/ci.sh extract_cabal_cache script: | export PATH="$CI_PROJECT_DIR/.brew/opt/llvm/bin:$CI_PROJECT_DIR/.brew/bin:$CI_PROJECT_DIR/.brew/sbin:$PATH" export CC=$CI_PROJECT_DIR/.brew/opt/llvm/bin/clang @@ -209,40 +218,51 @@ variables: export RANLIB=$CI_PROJECT_DIR/.brew/opt/llvm/bin/llvm-ranlib ./.gitlab/before_script/darwin/install_deps.sh ./.gitlab/script/ghcup_version.sh + after_script: + - ./.gitlab/script/ci.sh save_cabal_cache + - ./.gitlab/script/ci.sh save_brew_cache + - bash ./.gitlab/after_script.sh .test_ghcup_version:freebsd12: extends: - .test_ghcup_version - .freebsd12 - - .root_cleanup before_script: - ./.gitlab/before_script/freebsd/install_deps.sh + - ./.gitlab/script/ci.sh extract_cabal_cache + after_script: + - ./.gitlab/script/ci.sh save_cabal_cache + - bash ./.gitlab/after_script.sh .test_ghcup_version:freebsd13: extends: - .test_ghcup_version - .freebsd13 - - .root_cleanup before_script: - sudo pkg update - sudo pkg install --yes compat12x-amd64 - sudo ln -s libncurses.so.6 /usr/local/lib/libncurses.so.6.2 - ./.gitlab/before_script/freebsd/install_deps.sh + - ./.gitlab/script/ci.sh extract_cabal_cache + after_script: + - ./.gitlab/script/ci.sh save_cabal_cache + - bash ./.gitlab/after_script.sh .test_ghcup_version:windows: extends: - .test_ghcup_version - .windows - - .root_cleanup before_script: - - set CABAL_DIR="$CI_PROJECT_DIR/cabal" - bash ./.gitlab/before_script/windows/install_deps.sh + - bash ./.gitlab/script/ci.sh extract_cabal_cache + after_script: + - bash ./.gitlab/script/ci.sh save_cabal_cache + - bash ./.gitlab/after_script.sh # .test_ghcup_scoop:windows: # extends: # - .windows # - .test_ghcup_scoop - # - .root_cleanup .release_ghcup: script: @@ -262,9 +282,12 @@ variables: test:linux:stack: stage: test before_script: + - ./.gitlab/script/ci.sh extract_stack_cache - ./.gitlab/before_script/linux/install_deps_minimal.sh script: - ./.gitlab/script/ghcup_stack.sh + after_script: + - ./.gitlab/script/ci.sh save_stack_cache extends: - .debian needs: [] @@ -294,6 +317,7 @@ test:windows:bootstrap_powershell_script: - "[Environment]::SetEnvironmentVariable('GHCUP_MSYS2', $null, [System.EnvironmentVariableTarget]::User)" - "[Environment]::SetEnvironmentVariable('CABAL_DIR', $null, [System.EnvironmentVariableTarget]::User)" - bash ./.gitlab/after_script.sh + - bash ./.gitlab/script/ci.sh save_cabal_cache variables: GHC_VERSION: "8.10.7" CABAL_VERSION: "3.6.2.0" @@ -540,28 +564,17 @@ release:darwin:aarch64: cache: key: darwin-brew-$CACHE_REV paths: - - .brew - - .brew_cache + - brew_cache + key: ghcup-test-$CACHE_REV + paths: + - cabal-cache before_script: - # Install brew locally in the project dir. Packages will also be installed here. - - '[ -e "$CI_PROJECT_DIR/.brew" ] || git clone --depth=1 https://github.com/Homebrew/brew $CI_PROJECT_DIR/.brew' - - export PATH="$CI_PROJECT_DIR/.brew/bin:$CI_PROJECT_DIR/.brew/sbin:$PATH" - + - ./.gitlab/script/ci.sh extract_brew_cache + - ./.gitlab/script/ci.sh extract_cabal_cache # otherwise we seem to get intel binaries - export HOMEBREW_CHANGE_ARCH_TO_ARM=1 - - # make sure to not pollute the machine with temp files etc - - mkdir -p $CI_PROJECT_DIR/.brew_cache - - export HOMEBREW_CACHE=$CI_PROJECT_DIR/.brew_cache - - mkdir -p $CI_PROJECT_DIR/.brew_logs - - export HOMEBREW_LOGS=$CI_PROJECT_DIR/.brew_logs - - mkdir -p /private/tmp/.brew_tmp - - export HOMEBREW_TEMP=/private/tmp/.brew_tmp - # update and install packages - - brew update - - brew install llvm - - brew install autoconf automake + - /bin/bash ./.gitlab/script/brew.sh llvm autoconf automake script: | export PATH="$CI_PROJECT_DIR/.brew/opt/llvm/bin:$CI_PROJECT_DIR/.brew/bin:$CI_PROJECT_DIR/.brew/sbin:$PATH" export CC=$CI_PROJECT_DIR/.brew/opt/llvm/bin/clang @@ -571,6 +584,9 @@ release:darwin:aarch64: export RANLIB=$CI_PROJECT_DIR/.brew/opt/llvm/bin/llvm-ranlib ./.gitlab/before_script/darwin/install_deps.sh ./.gitlab/script/ghcup_release.sh + after_script: + - ./.gitlab/script/ci.sh save_cabal_cache + - ./.gitlab/script/ci.sh save_brew_cache variables: ARTIFACT: "aarch64-apple-darwin-ghcup" GHC_VERSION: "8.10.7" diff --git a/.gitlab/ghcup_env b/.gitlab/ghcup_env index 7a8ecd9..acf120e 100644 --- a/.gitlab/ghcup_env +++ b/.gitlab/ghcup_env @@ -1,11 +1,23 @@ if [ "${OS}" = "WINDOWS" ] ; then - export GHCUP_INSTALL_BASE_PREFIX="$CI_PROJECT_DIR" - export GHCUP_BIN="$CI_PROJECT_DIR/ghcup/bin" - export PATH="$GHCUP_BIN:$CI_PROJECT_DIR/.local/bin:$PATH" - export TMPDIR="$CI_PROJECT_DIR/tmp" + export GHCUP_INSTALL_BASE_PREFIX="$CI_PROJECT_DIR" + export GHCUP_BIN="$CI_PROJECT_DIR/ghcup/bin" + export PATH="$GHCUP_BIN:$CI_PROJECT_DIR/.local/bin:$PATH" + export TMPDIR="$CI_PROJECT_DIR/tmp" + export CABAL_DIR="$CI_PROJECT_DIR/cabal" + export CABAL_CACHE="$CI_PROJECT_DIR/cabal-cache" + export STACK_ROOT="$CI_PROJECT_DIR/stack" + export STACK_CACHE="$CI_PROJECT_DIR/stack-cache" + export BREW_DIR="$CI_PROJECT_DIR/.brew_cache" + export BREW_CACHE="$CI_PROJECT_DIR/brew-cache" else - export GHCUP_INSTALL_BASE_PREFIX="$CI_PROJECT_DIR" - export GHCUP_BIN="$CI_PROJECT_DIR/.ghcup/bin" - export PATH="$GHCUP_BIN:$CI_PROJECT_DIR/.local/bin:$PATH" - export TMPDIR="$CI_PROJECT_DIR/tmp" + export GHCUP_INSTALL_BASE_PREFIX="$CI_PROJECT_DIR" + export GHCUP_BIN="$CI_PROJECT_DIR/.ghcup/bin" + export PATH="$GHCUP_BIN:$CI_PROJECT_DIR/.local/bin:$PATH" + export TMPDIR="$CI_PROJECT_DIR/tmp" + export CABAL_DIR="$CI_PROJECT_DIR/cabal" + export CABAL_CACHE="$CI_PROJECT_DIR/cabal-cache" + export STACK_ROOT="$CI_PROJECT_DIR/stack" + export STACK_CACHE="$CI_PROJECT_DIR/stack-cache" + export BREW_DIR="$CI_PROJECT_DIR/.brew_cache" + export BREW_CACHE="$CI_PROJECT_DIR/brew-cache" fi diff --git a/.gitlab/script/brew.sh b/.gitlab/script/brew.sh new file mode 100755 index 0000000..de76963 --- /dev/null +++ b/.gitlab/script/brew.sh @@ -0,0 +1,19 @@ +#!/usr/bin/env bash + +set -Eeuxo pipefail + +# Install brew locally in the project dir. Packages will also be installed here. +[ -e "$CI_PROJECT_DIR/.brew" ] || git clone --depth=1 https://github.com/Homebrew/brew $CI_PROJECT_DIR/.brew +export PATH="$CI_PROJECT_DIR/.brew/bin:$CI_PROJECT_DIR/.brew/sbin:$PATH" + +# make sure to not pollute the machine with temp files etc +mkdir -p $CI_PROJECT_DIR/.brew_cache +export HOMEBREW_CACHE=$CI_PROJECT_DIR/.brew_cache +mkdir -p $CI_PROJECT_DIR/.brew_logs +export HOMEBREW_LOGS=$CI_PROJECT_DIR/.brew_logs +mkdir -p /private/tmp/.brew_tmp +export HOMEBREW_TEMP=/private/tmp/.brew_tmp + +# update and install packages +brew update +brew install ${1+"$@"} diff --git a/.gitlab/script/ci.sh b/.gitlab/script/ci.sh new file mode 100755 index 0000000..dfebfb8 --- /dev/null +++ b/.gitlab/script/ci.sh @@ -0,0 +1,70 @@ +#!/usr/bin/env bash + +set -Eeuo pipefail + +TOP="$( cd "$(dirname "$0")" ; pwd -P )" +. "${TOP}/../ghcup_env" + +function save_cabal_cache () { + echo "Storing cabal cache from $CABAL_DIR to $CABAL_CACHE..." + rm -Rf "$CABAL_CACHE" + mkdir -p "$CABAL_CACHE" + if [ -d "$CABAL_DIR" ]; then + cp -Rf "$CABAL_DIR" "$CABAL_CACHE/" + fi +} + + +function extract_cabal_cache () { + if [ -d "$CABAL_CACHE" ]; then + echo "Extracting cabal cache from $CABAL_CACHE to $CABAL_DIR..." + mkdir -p "$CABAL_DIR" + cp -Rf "$CABAL_CACHE"/* "$CABAL_DIR" + fi +} + +function save_stack_cache () { + echo "Storing stack cache from $STACK_ROOT to $STACK_CACHE..." + rm -Rf "$STACK_CACHE" + mkdir -p "$STACK_CACHE" + if [ -d "$STACK_ROOT" ]; then + cp -Rf "$STACK_DIR" "$STACK_CACHE" + fi +} + + +function extract_stack_cache () { + if [ -d "$STACK_CACHE" ]; then + echo "Extracting stack cache from $STACK_CACHE to $STACK_ROOT..." + mkdir -p "$STACK_ROOT" + cp -Rf "$STACK_CACHE"/* "$STACK_ROOT" + fi +} + +function save_brew_cache () { + echo "Storing brew cache from $BREW_DIR to $BREW_CACHE..." + rm -Rf "$BREW_CACHE" + mkdir -p "$BREW_CACHE" + if [ -d "$BREW_DIR" ]; then + cp -Rf "$BREW_DIR" "$BREW_CACHE" + fi +} + + +function extract_brew_cache () { + if [ -d "$BREW_CACHE" ]; then + echo "Extracting stack cache from $BREW_CACHE to $BREW_DIR..." + mkdir -p "$BREW_DIR" + cp -Rf "$BREW_CACHE"/* "$BREW_DIR" + fi +} + +case $1 in + extract_cabal_cache) extract_cabal_cache ;; + save_cabal_cache) save_cabal_cache ;; + extract_stack_cache) extract_stack_cache ;; + save_stack_cache) save_stack_cache ;; + extract_brew_cache) extract_brew_cache ;; + save_brew_cache) save_brew_cache ;; + *) echo "unknown mode $1" ; exit 11 ;; +esac diff --git a/.gitlab/script/ghcup_version.sh b/.gitlab/script/ghcup_version.sh index 0c4f3e7..604aaee 100755 --- a/.gitlab/script/ghcup_version.sh +++ b/.gitlab/script/ghcup_version.sh @@ -1,4 +1,4 @@ -#!/bin/sh +#!/usr/bin/env bash set -eux @@ -8,6 +8,7 @@ mkdir -p "$CI_PROJECT_DIR"/.local/bin CI_PROJECT_DIR=$(pwd) + ecabal() { cabal "$@" } @@ -94,16 +95,17 @@ rm -rf "${GHCUP_DIR}" eghcup --numeric-version eghcup install ghc ${GHC_VERSION} -[ `$(eghcup whereis ghc ${GHC_VERSION}) --numeric-version` = "${GHC_VERSION}" ] -[ `eghcup run --ghc ${GHC_VERSION} -- ghc --numeric-version` = "${GHC_VERSION}" ] +ls -lah "$(eghcup whereis -d ghc ${GHC_VERSION})" +[ "`$(eghcup whereis ghc ${GHC_VERSION}) --numeric-version`" = "${GHC_VERSION}" ] +[ "`eghcup run --ghc ${GHC_VERSION} -- ghc --numeric-version`" = "${GHC_VERSION}" ] eghcup set ghc ${GHC_VERSION} eghcup install cabal ${CABAL_VERSION} -[ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ] +[ "`$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version`" = "${CABAL_VERSION}" ] eghcup unset cabal "$GHCUP_BIN"/cabal --version && exit 1 || echo yes eghcup set cabal ${CABAL_VERSION} -[ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ] -[ `eghcup run --cabal ${CABAL_VERSION} -- cabal --numeric-version` = "${CABAL_VERSION}" ] +[ "`$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version`" = "${CABAL_VERSION}" ] +[ "`eghcup run --cabal ${CABAL_VERSION} -- cabal --numeric-version`" = "${CABAL_VERSION}" ] if [ "${OS}" != "FREEBSD" ] ; then if [ "${ARCH}" = "64" ] ; then From c9790e5823979e4f37d813c32b133827ff85df38 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 13 May 2022 21:35:34 +0200 Subject: [PATCH 04/20] Use strongly types `GHCupPath` and restrict destructive operations --- app/ghcup/BrickMain.hs | 1 - app/ghcup/GHCup/OptParse/Common.hs | 1 - app/ghcup/GHCup/OptParse/Compile.hs | 4 +- app/ghcup/GHCup/OptParse/Install.hs | 13 +- app/ghcup/GHCup/OptParse/Run.hs | 1 - app/ghcup/GHCup/OptParse/Whereis.hs | 9 +- app/ghcup/Main.hs | 2 +- lib/GHCup.hs | 192 +++++++++++++------------ lib/GHCup/Download.hs | 9 +- lib/GHCup/Platform.hs | 2 +- lib/GHCup/Types.hs | 21 +-- lib/GHCup/Utils.hs | 66 +++++---- lib/GHCup/Utils/Dirs.hs | 211 ++++++++++++++++++++++------ lib/GHCup/Utils/Dirs.hs-boot | 37 +++++ lib/GHCup/Utils/File.hs | 12 +- lib/GHCup/Utils/File/Common.hs | 9 +- lib/GHCup/Utils/File/Posix.hs | 8 +- lib/GHCup/Utils/File/Windows.hs | 6 +- lib/GHCup/Utils/Logger.hs | 7 +- lib/GHCup/Utils/Prelude.hs | 61 +++----- lib/GHCup/Utils/Prelude/Posix.hs | 6 +- 21 files changed, 421 insertions(+), 257 deletions(-) create mode 100644 lib/GHCup/Utils/Dirs.hs-boot diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 19499ca..e401ee3 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -44,7 +44,6 @@ import Data.Vector ( Vector import Data.Versions hiding ( str ) import Haskus.Utils.Variant.Excepts import Prelude hiding ( appendFile ) -import System.Directory ( canonicalizePath ) import System.FilePath import System.Exit import System.IO.Unsafe diff --git a/app/ghcup/GHCup/OptParse/Common.hs b/app/ghcup/GHCup/OptParse/Common.hs index 35867c7..a12303a 100644 --- a/app/ghcup/GHCup/OptParse/Common.hs +++ b/app/ghcup/GHCup/OptParse/Common.hs @@ -52,7 +52,6 @@ import Haskus.Utils.Variant.Excepts import Options.Applicative hiding ( style ) import Prelude hiding ( appendFile ) import Safe -import System.Directory import System.Process ( readProcess ) import System.FilePath import Text.HTML.TagSoup hiding ( Tag ) diff --git a/app/ghcup/GHCup/OptParse/Compile.hs b/app/ghcup/GHCup/OptParse/Compile.hs index f15793f..6499b38 100644 --- a/app/ghcup/GHCup/OptParse/Compile.hs +++ b/app/ghcup/GHCup/OptParse/Compile.hs @@ -494,7 +494,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do case keepDirs settings of Never -> runLogger $ logError $ T.pack $ prettyShow err _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <> - "Check the logs at " <> T.pack logsDir <> " and the build directory " + "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <> "Make sure to clean up " <> T.pack tmpdir <> " afterwards.") pure $ ExitFailure 9 @@ -553,7 +553,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do case keepDirs settings of Never -> runLogger $ logError $ T.pack $ prettyShow err _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <> - "Check the logs at " <> T.pack logsDir <> " and the build directory " + "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <> "Make sure to clean up " <> T.pack tmpdir <> " afterwards.") pure $ ExitFailure 9 diff --git a/app/ghcup/GHCup/OptParse/Install.hs b/app/ghcup/GHCup/OptParse/Install.hs index 4c3d5b1..f2320a6 100644 --- a/app/ghcup/GHCup/OptParse/Install.hs +++ b/app/ghcup/GHCup/OptParse/Install.hs @@ -18,6 +18,7 @@ import GHCup.OptParse.Common import GHCup import GHCup.Errors import GHCup.Types +import GHCup.Utils.Dirs import GHCup.Utils.Logger import GHCup.Utils.String.QQ @@ -446,21 +447,21 @@ install installCommand settings getAppState' runLogger = case installCommand of case keepDirs settings of Never -> runLogger (logError $ T.pack $ prettyShow err) _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <> - "Check the logs at " <> T.pack logsDir <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <> + "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <> "Make sure to clean up " <> T.pack tmpdir <> " afterwards.") pure $ ExitFailure 3 VLeft err@(V (BuildFailed tmpdir _, ())) -> do case keepDirs settings of Never -> runLogger (logError $ T.pack $ prettyShow err) _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <> - "Check the logs at " <> T.pack logsDir <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <> + "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <> "Make sure to clean up " <> T.pack tmpdir <> " afterwards.") pure $ ExitFailure 3 VLeft e -> do runLogger $ do logError $ T.pack $ prettyShow e - logError $ "Also check the logs in " <> T.pack logsDir + logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir) pure $ ExitFailure 3 @@ -512,7 +513,7 @@ install installCommand settings getAppState' runLogger = case installCommand of VLeft e -> do runLogger $ do logError $ T.pack $ prettyShow e - logError $ "Also check the logs in " <> T.pack logsDir + logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir) pure $ ExitFailure 4 installHLS :: InstallOptions -> IO ExitCode @@ -572,7 +573,7 @@ install installCommand settings getAppState' runLogger = case installCommand of VLeft e -> do runLogger $ do logError $ T.pack $ prettyShow e - logError $ "Also check the logs in " <> T.pack logsDir + logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir) pure $ ExitFailure 4 installStack :: InstallOptions -> IO ExitCode @@ -623,6 +624,6 @@ install installCommand settings getAppState' runLogger = case installCommand of VLeft e -> do runLogger $ do logError $ T.pack $ prettyShow e - logError $ "Also check the logs in " <> T.pack logsDir + logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir) pure $ ExitFailure 4 diff --git a/app/ghcup/GHCup/OptParse/Run.hs b/app/ghcup/GHCup/OptParse/Run.hs index 78393f8..45cfce6 100644 --- a/app/ghcup/GHCup/OptParse/Run.hs +++ b/app/ghcup/GHCup/OptParse/Run.hs @@ -32,7 +32,6 @@ import Data.List ( intercalate ) import Haskus.Utils.Variant.Excepts import Options.Applicative hiding ( style ) import Prelude hiding ( appendFile ) -import System.Directory import System.FilePath import System.Environment import System.Exit diff --git a/app/ghcup/GHCup/OptParse/Whereis.hs b/app/ghcup/GHCup/OptParse/Whereis.hs index 02c27b6..89ef8ed 100644 --- a/app/ghcup/GHCup/OptParse/Whereis.hs +++ b/app/ghcup/GHCup/OptParse/Whereis.hs @@ -17,6 +17,7 @@ import GHCup import GHCup.Errors import GHCup.OptParse.Common import GHCup.Types +import GHCup.Utils import GHCup.Utils.Logger import GHCup.Utils.String.QQ @@ -299,7 +300,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do pure $ ExitFailure 30 (WhereisBaseDir, _) -> do - liftIO $ putStr baseDir + liftIO $ putStr $ fromGHCupPath baseDir pure ExitSuccess (WhereisBinDir, _) -> do @@ -307,13 +308,13 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do pure ExitSuccess (WhereisCacheDir, _) -> do - liftIO $ putStr cacheDir + liftIO $ putStr $ fromGHCupPath cacheDir pure ExitSuccess (WhereisLogsDir, _) -> do - liftIO $ putStr logsDir + liftIO $ putStr $ fromGHCupPath logsDir pure ExitSuccess (WhereisConfDir, _) -> do - liftIO $ putStr confDir + liftIO $ putStr $ fromGHCupPath confDir pure ExitSuccess diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 2dd0f6e..96eabe8 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -220,7 +220,7 @@ Report bugs at |] let s' = AppState settings dirs keybindings ghcupInfo pfreq loggerConfig race_ (liftIO $ runReaderT cleanupTrash s') - (threadDelay 5000000 >> runLogger (logWarn $ "Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in " <> T.pack recycleDir <> " manually")) + (threadDelay 5000000 >> runLogger (logWarn $ "Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in " <> T.pack (fromGHCupPath recycleDir) <> " manually")) case optCommand of Nuke -> pure () diff --git a/lib/GHCup.hs b/lib/GHCup.hs index d6fae22..6ad9e24 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -77,11 +77,9 @@ import Prelude hiding ( abs , writeFile ) import Safe hiding ( at ) -import System.Directory hiding ( findFiles, copyFile ) import System.Environment import System.FilePath import System.IO.Error -import System.IO.Temp import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.Regex.Posix import URI.ByteString @@ -293,8 +291,8 @@ installPackedGHC dl msubdir inst ver forceInstall = do -- unpack tmpUnpack <- lift mkGhcupTmpDir - liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack + liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) -- the subdir of the archive where we do the work workdir <- maybe (pure tmpUnpack) @@ -319,7 +317,7 @@ installUnpackedGHC :: ( MonadReader env m , MonadResource m , MonadFail m ) - => FilePath -- ^ Path to the unpacked GHC bindist (where the configure script resides) + => GHCupPath -- ^ Path to the unpacked GHC bindist (where the configure script resides) -> InstallDirResolved -- ^ Path to install to -> Version -- ^ The GHC version -> Bool -- ^ Force install @@ -351,13 +349,13 @@ installUnpackedGHC path inst ver forceInstall ("./configure" : ("--prefix=" <> fromInstallDir inst) : alpineArgs ) - (Just path) + (Just $ fromGHCupPath path) "ghc-configure" Nothing 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)) + lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "install"] (Just $ fromGHCupPath path) + lift $ logInfo $ "Merging file tree from \"" <> T.pack (fromGHCupPath tmpInstallDest) <> "\" to \"" <> T.pack (fromInstallDir inst) <> "\"" + fs <- mergeFileTreeAll (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst)) (fromInstallDir inst) (\f t -> liftIO (install f t (not forceInstall))) liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromInstallDir inst) @@ -472,11 +470,11 @@ installCabalBindist dlinfo ver installDir forceInstall = do -- unpack tmpUnpack <- lift withGHCupTmpDir - liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack + liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) -- the subdir of the archive where we do the work - workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) + workdir <- fromGHCupPath <$> maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) case installDir of IsolateDir isoDir -> do -- isolated install @@ -484,7 +482,7 @@ installCabalBindist dlinfo ver installDir forceInstall = do liftE $ installCabalUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall GHCupInternal -> do -- regular install - liftE $ installCabalUnpacked workdir (GHCupDir binDir) ver forceInstall + liftE $ installCabalUnpacked workdir (GHCupBinDir binDir) ver forceInstall -- | Install an unpacked cabal distribution.Symbol @@ -501,7 +499,7 @@ installCabalUnpacked path inst ver forceInstall = do let destFileName = cabalFile <> (case inst of IsolateDirResolved _ -> "" - GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver + _ -> ("-" <>) . T.unpack . prettyVer $ ver ) <> exeExt let destPath = fromInstallDir inst destFileName @@ -614,11 +612,11 @@ installHLSBindist dlinfo ver installDir forceInstall = do -- unpack tmpUnpack <- lift withGHCupTmpDir - liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack + liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) -- the subdir of the archive where we do the work - workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) + workdir <- fromGHCupPath <$> maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) legacy <- liftIO $ isLegacyHLSBindist workdir if @@ -636,7 +634,7 @@ installHLSBindist dlinfo ver installDir forceInstall = do GHCupInternal -> do if legacy - then liftE $ installHLSUnpackedLegacy workdir (GHCupDir binDir) ver forceInstall + then liftE $ installHLSUnpackedLegacy workdir (GHCupBinDir binDir) ver forceInstall else do inst <- ghcupHLSDir ver liftE $ runBuildAction tmpUnpack @@ -671,8 +669,8 @@ installHLSUnpacked path inst ver forceInstall = do PlatformRequest { .. } <- lift getPlatformReq lift $ logInfo "Installing HLS" tmpInstallDest <- lift withGHCupTmpDir - lEM $ make ["DESTDIR=" <> tmpInstallDest, "PREFIX=" <> fromInstallDir inst, "install"] (Just path) - fs <- mergeFileTreeAll (tmpInstallDest dropDrive (fromInstallDir inst)) + lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "PREFIX=" <> fromInstallDir inst, "install"] (Just path) + fs <- mergeFileTreeAll (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst)) (fromInstallDir inst) (\f t -> liftIO (install f t (not forceInstall))) liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromInstallDir inst) @@ -702,7 +700,7 @@ installHLSUnpackedLegacy path installDir ver forceInstall = do let toF = dropSuffix exeExt f <> (case installDir of IsolateDirResolved _ -> "" - GHCupDir _ -> ("~" <>) . T.unpack . prettyVer $ ver + _ -> ("~" <>) . T.unpack . prettyVer $ ver ) <> exeExt @@ -720,7 +718,7 @@ installHLSUnpackedLegacy path installDir ver forceInstall = do toF = wrapper <> (case installDir of IsolateDirResolved _ -> "" - GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver + _ -> ("-" <>) . T.unpack . prettyVer $ ver ) <> exeExt srcWrapperPath = path wrapper <> exeExt @@ -827,8 +825,8 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc -- unpack tmpUnpack <- lift mkGhcupTmpDir - liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack + liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) @@ -839,7 +837,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc -- clone from git Right GitBranch{..} -> do tmpUnpack <- lift mkGhcupTmpDir - let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing + let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do let rep = fromMaybe "https://github.com/haskell/haskell-language-server.git" repo lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)" @@ -859,7 +857,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc lEM $ git fetch_args lEM $ git [ "checkout", "FETCH_HEAD" ] - (Just gpd) <- parseGenericPackageDescriptionMaybe <$> liftIO (B.readFile (tmpUnpack "haskell-language-server.cabal")) + (Just gpd) <- parseGenericPackageDescriptionMaybe <$> liftIO (B.readFile (fromGHCupPath tmpUnpack "haskell-language-server.cabal")) pure . (\c -> Version Nothing c [] Nothing) . NE.fromList . fmap (NE.fromList . (:[]) . digits . fromIntegral) . versionNumbers @@ -868,7 +866,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc . packageDescription $ gpd - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to HLS version " <> prettyVer tver pure (tmpUnpack, tver) @@ -879,30 +877,30 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc liftE $ runBuildAction workdir - (reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed workdir) $ do - let tmpInstallDir = workdir "out" + (reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed $ fromGHCupPath workdir) $ do + let tmpInstallDir = fromGHCupPath workdir "out" liftIO $ createDirRecursive' tmpInstallDir -- apply patches - liftE $ applyAnyPatch patches workdir + liftE $ applyAnyPatch patches (fromGHCupPath workdir) -- set up project files cp <- case cabalProject of Just (Left cp) | isAbsolute cp -> do - copyFileE cp (workdir "cabal.project") False + copyFileE cp (fromGHCupPath workdir "cabal.project") False pure "cabal.project" | otherwise -> pure (takeFileName cp) Just (Right uri) -> do tmpUnpack <- lift withGHCupTmpDir - cp <- liftE $ download uri Nothing Nothing tmpUnpack (Just "cabal.project") False - copyFileE cp (workdir "cabal.project") False + cp <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack) (Just "cabal.project") False + copyFileE cp (fromGHCupPath workdir "cabal.project") False pure "cabal.project" Nothing -> pure "cabal.project" forM_ cabalProjectLocal $ \uri -> do tmpUnpack <- lift withGHCupTmpDir - cpl <- liftE $ download uri Nothing Nothing tmpUnpack (Just (cp <.> "local")) False - copyFileE cpl (workdir cp <.> "local") False + cpl <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack) (Just (cp <.> "local")) False + copyFileE cpl (fromGHCupPath workdir cp <.> "local") False artifacts <- forM (sort ghcs) $ \ghc -> do let ghcInstallDir = tmpInstallDir T.unpack (prettyVer ghc) liftIO $ createDirRecursive' tmpInstallDir @@ -923,7 +921,9 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc "exe:haskell-language-server" , "exe:haskell-language-server-wrapper"] ) - (Just workdir) "cabal" Nothing + (Just $ fromGHCupPath workdir) + "cabal" + Nothing pure ghcInstallDir forM_ artifacts $ \artifact -> do @@ -931,14 +931,14 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc (tmpInstallDir "haskell-language-server-" <> takeFileName artifact <.> exeExt) liftIO $ renameFile (artifact "haskell-language-server-wrapper" <.> exeExt) (tmpInstallDir "haskell-language-server-wrapper" <.> exeExt) - liftIO $ rmPathForcibly artifact + liftIO $ hideError NoSuchThing $ rmFile artifact case installDir of IsolateDir isoDir -> do lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir liftE $ installHLSUnpackedLegacy tmpInstallDir (IsolateDirResolved isoDir) installVer True GHCupInternal -> do - liftE $ installHLSUnpackedLegacy tmpInstallDir (GHCupDir binDir) installVer True + liftE $ installHLSUnpackedLegacy tmpInstallDir (GHCupBinDir binDir) installVer True ) pure installVer @@ -1044,8 +1044,8 @@ installStackBindist dlinfo ver installDir forceInstall = do -- unpack tmpUnpack <- lift withGHCupTmpDir - liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack + liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) -- the subdir of the archive where we do the work workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) @@ -1055,12 +1055,12 @@ installStackBindist dlinfo ver installDir forceInstall = do lift $ logInfo $ "isolated installing Stack to " <> T.pack isoDir liftE $ installStackUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall GHCupInternal -> do -- regular install - liftE $ installStackUnpacked workdir (GHCupDir binDir) ver forceInstall + liftE $ installStackUnpacked workdir (GHCupBinDir binDir) ver forceInstall -- | Install an unpacked stack distribution. installStackUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m) - => FilePath -- ^ Path to the unpacked stack bindist (where the executable resides) + => GHCupPath -- ^ Path to the unpacked stack bindist (where the executable resides) -> InstallDirResolved -> Version -> Bool -- ^ Force install @@ -1072,13 +1072,13 @@ installStackUnpacked path installDir ver forceInstall = do let destFileName = stackFile <> (case installDir of IsolateDirResolved _ -> "" - GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver + _ -> ("-" <>) . T.unpack . prettyVer $ ver ) <> exeExt destPath = fromInstallDir installDir destFileName copyFileE - (path stackFile <> exeExt) + (fromGHCupPath path stackFile <> exeExt) destPath (not forceInstall) lift $ chmod_755 destPath @@ -1160,7 +1160,7 @@ setGHC ver sghc mBinDir = do when (isNothing mBinDir) $ do -- create symlink for share dir - when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verS + when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir (fromGHCupPath ghcdir) verS when (sghc == SetGHCOnly) $ lift warnAboutHlsCompatibility @@ -1180,7 +1180,7 @@ setGHC ver sghc mBinDir = do -> m () symlinkShareDir ghcdir ver' = do Dirs {..} <- getDirs - let destdir = baseDir + let destdir = fromGHCupPath baseDir case sghc of SetGHCOnly -> do let sharedir = "share" @@ -1799,19 +1799,20 @@ rmGHCVer ver = do handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorGHCSymlinks ver -- then fix them (e.g. with an earlier version) - dir <- lift $ ghcupGHCDir ver + dir' <- lift $ ghcupGHCDir ver + let dir = fromGHCupPath 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 + liftIO $ hideError doesNotExistErrorType $ 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 + lift $ recyclePathForcibly dir' v' <- handle @@ -1823,7 +1824,7 @@ rmGHCVer ver = do Dirs {..} <- lift getDirs - lift $ hideError doesNotExistErrorType $ rmDirectoryLink (baseDir "share") + lift $ hideError doesNotExistErrorType $ rmDirectoryLink (fromGHCupPath baseDir "share") -- | Delete a cabal version. Will try to fix the @cabal@ symlink @@ -1882,7 +1883,8 @@ rmHLSVer ver = do -- delete all set symlinks liftE rmPlainHLS - hlsDir <- ghcupHLSDir ver + hlsDir' <- ghcupHLSDir ver + let hlsDir = fromGHCupPath hlsDir' lift (getInstalledFiles HLS (mkTVer ver)) >>= \case Just files -> do lift $ logInfo $ "Removing files safely from: " <> T.pack hlsDir @@ -1894,7 +1896,7 @@ rmHLSVer ver = do when (not (null survivors)) $ throwE $ UninstallFailed hlsDir survivors Nothing -> do lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack hlsDir - recyclePathForcibly hlsDir + recyclePathForcibly hlsDir' when (Just ver == isHlsSet) $ do -- set latest hls @@ -1974,7 +1976,7 @@ rmGhcup = do tempFilepath <- mkGhcupTmpDir hideError UnsupportedOperation $ liftIO $ hideError NoSuchThing $ - moveFile ghcupFilepath (tempFilepath "ghcup") + moveFile ghcupFilepath (fromGHCupPath tempFilepath "ghcup") else -- delete it. hideError doesNotExistErrorType $ rmFile ghcupFilepath @@ -2024,7 +2026,7 @@ rmGhcupDirs = do , recycleDir } <- getDirs - let envFilePath = baseDir "env" + let envFilePath = fromGHCupPath baseDir "env" confFilePath <- getConfigFilePath @@ -2038,14 +2040,14 @@ rmGhcupDirs = do handleRm $ rmBinDir binDir handleRm $ rmDir recycleDir when isWindows $ do - logInfo $ "removing " <> T.pack (baseDir "msys64") - handleRm $ rmPathForcibly (baseDir "msys64") + logInfo $ "removing " <> T.pack (fromGHCupPath baseDir "msys64") + handleRm $ rmPathForcibly (baseDir `appendGHCupPath` "msys64") - handleRm $ removeEmptyDirsRecursive baseDir + handleRm $ removeEmptyDirsRecursive (fromGHCupPath baseDir) -- report files in baseDir that are left-over after -- the standard location deletions above - hideErrorDef [doesNotExistErrorType] [] $ reportRemainingFiles baseDir + hideErrorDef [doesNotExistErrorType] [] $ reportRemainingFiles (fromGHCupPath baseDir) where handleRm :: (MonadReader env m, MonadCatch m, HasLog env, MonadIO m) => m () -> m () @@ -2062,15 +2064,15 @@ rmGhcupDirs = do logInfo "removing Ghcup Config File" 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) => GHCupPath -> m () rmDir dir = -- 'getDirectoryContentsRecursive' is lazy IO. In case -- an error leaks through, we catch it here as well, -- althought 'deleteFile' should already handle it. hideErrorDef [doesNotExistErrorType] () $ do - logInfo $ "removing " <> T.pack dir + logInfo $ "removing " <> T.pack (fromGHCupPath dir) contents <- liftIO $ getDirectoryContentsRecursive dir - forM_ contents (deleteFile' . (dir )) + forM_ contents (deleteFile' . (fromGHCupPath dir )) rmBinDir :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m () rmBinDir binDir @@ -2085,7 +2087,7 @@ rmGhcupDirs = do reportRemainingFiles dir = do -- force the files so the errors don't leak (force -> !remainingFiles) <- liftIO - (getDirectoryContentsRecursive dir >>= evaluate) + (getDirectoryContentsRecursiveUnsafe dir >>= evaluate) let normalizedFilePaths = fmap normalise remainingFiles let sortedByDepthRemainingFiles = sortBy (flip compareFn) normalizedFilePaths let remainingFilesAbsolute = fmap (dir ) sortedByDepthRemainingFiles @@ -2113,7 +2115,7 @@ removeDirIfEmptyOrIsSymlink filepath = hideError UnsatisfiedConstraints $ handleIO' InappropriateType (handleIfSym filepath) - (liftIO $ rmDirectory filepath) + (liftIO $ removeEmptyDirectory filepath) where handleIfSym fp e = do isSym <- liftIO $ pathIsSymbolicLink fp @@ -2147,10 +2149,10 @@ getDebugInfo :: ( Alternative m DebugInfo getDebugInfo = do Dirs {..} <- lift getDirs - let diBaseDir = baseDir + let diBaseDir = fromGHCupPath baseDir let diBinDir = binDir - diGHCDir <- lift ghcupGHCBaseDir - let diCacheDir = cacheDir + diGHCDir <- fromGHCupPath <$> lift ghcupGHCBaseDir + let diCacheDir = fromGHCupPath cacheDir diArch <- lE getArchitecture diPlatform <- liftE getPlatform pure $ DebugInfo { .. } @@ -2231,20 +2233,20 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr -- unpack tmpUnpack <- lift mkGhcupTmpDir - liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack + liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform $ fromGHCupPath tmpUnpack workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlInfo) - liftE $ applyAnyPatch patches workdir + liftE $ applyAnyPatch patches (fromGHCupPath workdir) pure (workdir, tmpUnpack, tver) -- clone from git Right GitBranch{..} -> do tmpUnpack <- lift mkGhcupTmpDir - let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing + let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] DownloadFailed $ do let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)" @@ -2265,16 +2267,16 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr lEM $ git [ "checkout", "FETCH_HEAD" ] lEM $ git [ "submodule", "update", "--init", "--depth", "1" ] - liftE $ applyAnyPatch patches tmpUnpack - lEM $ execWithGhcEnv "python3" ["./boot"] (Just tmpUnpack) "ghc-bootstrap" - lEM $ execWithGhcEnv "sh" ["./configure"] (Just tmpUnpack) "ghc-bootstrap" + liftE $ applyAnyPatch patches (fromGHCupPath tmpUnpack) + lEM $ execWithGhcEnv "python3" ["./boot"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" + lEM $ execWithGhcEnv "sh" ["./configure"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" CapturedProcess {..} <- lift $ makeOut - ["show!", "--quiet", "VALUE=ProjectVersion" ] (Just tmpUnpack) + ["show!", "--quiet", "VALUE=ProjectVersion" ] (Just $ fromGHCupPath tmpUnpack) case _exitCode of ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . decUTF8Safe' $ _stdOut ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr)) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to GHC version " <> prettyVer tver pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver) @@ -2303,9 +2305,9 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr tmpUnpack (do b <- if hadrian - then compileHadrianBindist tver workdir ghcdir - else compileMakeBindist tver workdir ghcdir - bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk workdir) + then compileHadrianBindist tver (fromGHCupPath workdir) ghcdir + else compileMakeBindist tver (fromGHCupPath workdir) ghcdir + bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk $ fromGHCupPath workdir) pure (b, bmk) ) @@ -2500,7 +2502,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr <> T.unpack cDigest <> ".tar" <> takeExtension tar) - let tarPath = cacheDir tarName + let tarPath = fromGHCupPath cacheDir tarName copyFileE (workdir tar) tarPath False lift $ logInfo $ "Copied bindist to " <> T.pack tarPath pure tarPath @@ -2674,7 +2676,7 @@ upgradeGHCup mtarget force' fatal = do (Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer "" when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate dli <- liftE $ getDownloadInfo GHCup latestVer - tmp <- lift withGHCupTmpDir + tmp <- fromGHCupPath <$> lift withGHCupTmpDir let fn = "ghcup" <> exeExt p <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmp (Just fn) False let destDir = takeDirectory destFile @@ -2768,7 +2770,7 @@ whereIsTool tool ver@GHCTargetVersion {..} = do GHC -> do whenM (lift $ fmap not $ ghcInstalled ver) $ throwE (NotInstalled GHC ver) - bdir <- lift $ ghcupGHCDir ver + bdir <- fromGHCupPath <$> lift (ghcupGHCDir ver) pure (bdir "bin" ghcBinaryName ver) Cabal -> do whenM (lift $ fmap not $ cabalInstalled _tvVersion) @@ -2780,7 +2782,7 @@ whereIsTool tool ver@GHCTargetVersion {..} = do ifM (lift $ isLegacyHLS _tvVersion) (pure (binDir dirs "haskell-language-server-wrapper-" <> T.unpack (prettyVer _tvVersion) <> exeExt)) $ do - bdir <- lift $ ghcupHLSDir _tvVersion + bdir <- fromGHCupPath <$> lift (ghcupHLSDir _tvVersion) pure (bdir "bin" "haskell-language-server-wrapper" <> exeExt) Stack -> do @@ -2866,6 +2868,7 @@ rmProfilingLibs = do forM_ regexes $ \regex -> forM_ ghcs $ \ghc -> do d <- ghcupGHCDir ghc + -- TODO: audit findFilesDeep matches <- liftIO $ handleIO (\_ -> pure []) $ findFilesDeep d (makeRegexOpts compExtended @@ -2873,7 +2876,7 @@ rmProfilingLibs = do regex ) forM_ matches $ \m -> do - let p = d m + let p = fromGHCupPath d m logDebug $ "rm " <> T.pack p rmFile p @@ -2892,8 +2895,8 @@ rmShareDir = do ghcs <- fmap rights getInstalledGHCs forM_ ghcs $ \ghc -> do d <- ghcupGHCDir ghc - let p = d "share" - logDebug $ "rm -rf " <> T.pack p + let p = d `appendGHCupPath` "share" + logDebug $ "rm -rf " <> T.pack (fromGHCupPath p) rmPathForcibly p @@ -2938,9 +2941,9 @@ rmCache :: ( MonadReader env m => m () rmCache = do Dirs {..} <- getDirs - contents <- liftIO $ listDirectory cacheDir + contents <- liftIO $ listDirectory (fromGHCupPath cacheDir) forM_ contents $ \f -> do - let p = cacheDir f + let p = fromGHCupPath cacheDir f logDebug $ "rm " <> T.pack p rmFile p @@ -2953,17 +2956,10 @@ rmTmp :: ( MonadReader env m ) => m () rmTmp = do - tmpdir <- liftIO getCanonicalTemporaryDirectory - ghcup_dirs <- liftIO $ handleIO (\_ -> pure []) $ findFiles - tmpdir - (makeRegexOpts compExtended - execBlank - ([s|^ghcup-.*$|] :: ByteString) - ) + ghcup_dirs <- liftIO getGHCupTmpDirs forM_ ghcup_dirs $ \f -> do - let p = tmpdir f - logDebug $ "rm -rf " <> T.pack p - rmPathForcibly p + logDebug $ "rm -rf " <> T.pack (fromGHCupPath f) + rmPathForcibly f applyAnyPatch :: ( MonadReader env m @@ -2982,7 +2978,7 @@ applyAnyPatch :: ( MonadReader env m applyAnyPatch Nothing _ = pure () applyAnyPatch (Just (Left pdir)) workdir = liftE $ applyPatches pdir workdir applyAnyPatch (Just (Right uris)) workdir = do - tmpUnpack <- lift withGHCupTmpDir + tmpUnpack <- fromGHCupPath <$> lift withGHCupTmpDir forM_ uris $ \uri -> do patch <- liftE $ download uri Nothing Nothing tmpUnpack Nothing False liftE $ applyPatch patch workdir diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 8327c76..c768a47 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -69,7 +69,6 @@ import Prelude hiding ( abs , writeFile ) import Safe -import System.Directory import System.Environment import System.Exit import System.FilePath @@ -145,7 +144,7 @@ getDownloadsF = do yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath yamlFromCache uri = do Dirs{..} <- getDirs - pure (cacheDir (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri)) + pure (fromGHCupPath cacheDir (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri)) etagsFile :: FilePath -> FilePath @@ -242,7 +241,7 @@ getBase uri = do Settings { metaCache } <- lift getSettings -- for local files, let's short-circuit and ignore access time - if | scheme == "file" -> liftE $ download uri' Nothing Nothing cacheDir Nothing True + if | scheme == "file" -> liftE $ download uri' Nothing Nothing (fromGHCupPath cacheDir) Nothing True | e -> do accessTime <- fmap utcTimeToPOSIXSeconds $ liftIO $ getAccessTime json_file let sinceLastAccess = utcTimeToPOSIXSeconds currentTime - accessTime @@ -581,7 +580,7 @@ downloadCached dli mfn = do True -> downloadCached' dli mfn Nothing False -> do tmp <- lift withGHCupTmpDir - liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmp mfn False + liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (fromGHCupPath tmp) mfn False downloadCached' :: ( MonadReader env m @@ -599,7 +598,7 @@ downloadCached' :: ( MonadReader env m -> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath downloadCached' dli mfn mDestDir = do Dirs { cacheDir } <- lift getDirs - let destDir = fromMaybe cacheDir mDestDir + let destDir = fromMaybe (fromGHCupPath cacheDir) mDestDir let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn let cachfile = destDir fn fileExists <- liftIO $ doesFileExist cachfile diff --git a/lib/GHCup/Platform.hs b/lib/GHCup/Platform.hs index 62cf01f..ec1e7c8 100644 --- a/lib/GHCup/Platform.hs +++ b/lib/GHCup/Platform.hs @@ -23,6 +23,7 @@ import GHCup.Errors import GHCup.Types import GHCup.Types.Optics import GHCup.Types.JSON ( ) +import GHCup.Utils.Dirs import GHCup.Utils.File import GHCup.Utils.Logger import GHCup.Utils.Prelude @@ -46,7 +47,6 @@ import Prelude hiding ( abs , writeFile ) import System.Info -import System.Directory import System.OsRelease import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.Regex.Posix diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 6286347..609834f 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -26,6 +26,9 @@ module GHCup.Types ) where +import {-# SOURCE #-} GHCup.Utils.Dirs ( fromGHCupPath ) +import {-# SOURCE #-} GHCup.Utils.Dirs ( GHCupPath ) + import Control.DeepSeq ( NFData, rnf ) import Data.Map.Strict ( Map ) import Data.List.NonEmpty ( NonEmpty (..) ) @@ -438,13 +441,13 @@ defaultSettings = Settings False defaultMetaCache False Never Curl False GHCupUR instance NFData Settings data Dirs = Dirs - { baseDir :: FilePath + { baseDir :: GHCupPath , binDir :: FilePath - , cacheDir :: FilePath - , logsDir :: FilePath - , confDir :: FilePath - , dbDir :: FilePath - , recycleDir :: FilePath -- mainly used on windows + , cacheDir :: GHCupPath + , logsDir :: GHCupPath + , confDir :: GHCupPath + , dbDir :: GHCupPath + , recycleDir :: GHCupPath -- mainly used on windows } deriving (Show, GHC.Generic) @@ -636,9 +639,11 @@ data InstallDir = IsolateDir FilePath deriving (Eq, Show) data InstallDirResolved = IsolateDirResolved FilePath - | GHCupDir FilePath + | GHCupDir GHCupPath + | GHCupBinDir FilePath deriving (Eq, Show) fromInstallDir :: InstallDirResolved -> FilePath fromInstallDir (IsolateDirResolved fp) = fp -fromInstallDir (GHCupDir fp) = fp +fromInstallDir (GHCupDir fp) = fromGHCupPath fp +fromInstallDir (GHCupBinDir fp) = fp diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 4e31b09..386dcb7 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -72,7 +72,6 @@ import GHC.IO.Exception import Haskus.Utils.Variant.Excepts import Optics import Safe -import System.Directory hiding ( findFiles, copyFile ) import System.FilePath import System.IO.Error import Text.Regex.Posix @@ -281,14 +280,14 @@ rmPlainHLS = do ghcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool ghcInstalled ver = do ghcdir <- ghcupGHCDir ver - liftIO $ doesDirectoryExist ghcdir + liftIO $ doesDirectoryExist (fromGHCupPath ghcdir) -- | Whether the given GHC version is installed from source. ghcSrcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool ghcSrcInstalled ver = do ghcdir <- ghcupGHCDir ver - liftIO $ doesFileExist (ghcdir ghcUpSrcBuiltFile) + liftIO $ doesFileExist (fromGHCupPath ghcdir ghcUpSrcBuiltFile) -- | Whether the given GHC version is set as the current. @@ -331,7 +330,7 @@ ghcSet mtarget = do getInstalledGHCs :: (MonadReader env m, HasDirs env, MonadIO m) => m [Either FilePath GHCTargetVersion] getInstalledGHCs = do ghcdir <- ghcupGHCBaseDir - fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory ghcdir + fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory (fromGHCupPath ghcdir) forM fs $ \f -> case parseGHCupGHCDir f of Right r -> pure $ Right r Left _ -> pure $ Left f @@ -434,7 +433,7 @@ getInstalledHLSs = do Nothing -> pure $ Left f hlsdir <- ghcupHLSBaseDir - fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory hlsdir + fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory (fromGHCupPath hlsdir) new <- forM fs $ \f -> case parseGHCupHLSDir f of Right r -> pure $ Right r Left _ -> pure $ Left f @@ -519,7 +518,7 @@ hlsInstalled ver = do isLegacyHLS :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool isLegacyHLS ver = do bdir <- ghcupHLSDir ver - not <$> liftIO (doesDirectoryExist bdir) + not <$> liftIO (doesDirectoryExist $ fromGHCupPath bdir) -- Return the currently set hls version, if any. @@ -620,7 +619,7 @@ hlsInternalServerScripts :: (MonadReader env m, HasDirs env, MonadIO m, MonadThr -> m [FilePath] hlsInternalServerScripts ver mghcVer = do dir <- ghcupHLSDir ver - let bdir = dir "bin" + let bdir = fromGHCupPath dir "bin" fmap (bdir ) . filter (\f -> maybe True (\gv -> ("-" <> T.unpack (prettyVer gv)) `isSuffixOf` f) mghcVer) <$> liftIO (listDirectory bdir) @@ -631,7 +630,7 @@ hlsInternalServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadTh -> Maybe Version -- ^ optional GHC version -> m [FilePath] hlsInternalServerBinaries ver mghcVer = do - dir <- ghcupHLSDir ver + dir <- fromGHCupPath <$> ghcupHLSDir ver let regex = makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString) (Just bdir) <- fmap headMay $ liftIO $ expandFilePath [Left (dir "lib"), Right regex, Left "bin"] fmap (bdir ) . filter (\f -> maybe True (\gv -> ("-" <> T.unpack (prettyVer gv)) `isSuffixOf` f) mghcVer) @@ -645,7 +644,7 @@ hlsInternalServerLibs :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow -> Version -- ^ GHC version -> m [FilePath] hlsInternalServerLibs ver ghcVer = do - dir <- ghcupHLSDir ver + dir <- fromGHCupPath <$> ghcupHLSDir ver let regex = makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString) (Just bdir) <- fmap headMay $ liftIO $ expandFilePath [Left (dir "lib"), Right regex, Left ("lib" T.unpack (prettyVer ghcVer))] fmap (bdir ) <$> liftIO (listDirectory bdir) @@ -849,21 +848,21 @@ getArchiveFiles av = do intoSubdir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m, MonadCatch m) - => FilePath -- ^ unpacked tar dir + => GHCupPath -- ^ unpacked tar dir -> TarDir -- ^ how to descend - -> Excepts '[TarDirDoesNotExist] m FilePath + -> Excepts '[TarDirDoesNotExist] m GHCupPath intoSubdir bdir tardir = case tardir of RealDir pr -> do - whenM (fmap not . liftIO . doesDirectoryExist $ (bdir pr)) + whenM (fmap not . liftIO . doesDirectoryExist $ (fromGHCupPath (bdir `appendGHCupPath` pr))) (throwE $ TarDirDoesNotExist tardir) - pure (bdir pr) + pure (bdir `appendGHCupPath` pr) RegexDir r -> do let rs = split (`elem` pathSeparators) r foldlM (\y x -> - (handleIO (\_ -> pure []) . liftIO . findFiles y . regex $ x) >>= (\case + (handleIO (\_ -> pure []) . liftIO . findFiles (fromGHCupPath y) . regex $ x) >>= (\case [] -> throwE $ TarDirDoesNotExist tardir - (p : _) -> pure (y p)) . sort + (p : _) -> pure (y `appendGHCupPath` p)) . sort ) bdir rs @@ -909,7 +908,7 @@ ghcInternalBinDir :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, => GHCTargetVersion -> m FilePath ghcInternalBinDir ver = do - ghcdir <- ghcupGHCDir ver + ghcdir <- fromGHCupPath <$> ghcupGHCDir ver pure (ghcdir "bin") @@ -1045,7 +1044,6 @@ getChangeLog dls tool (Right tag) = -- | Execute a build action while potentially cleaning up: -- -- 1. the build directory, depending on the KeepDirs setting --- 2. the install destination, depending on whether the build failed runBuildAction :: ( MonadReader env m , HasDirs env , HasSettings env @@ -1056,7 +1054,7 @@ runBuildAction :: ( MonadReader env m , MonadFail m , MonadCatch m ) - => FilePath -- ^ build directory (cleaned up depending on Settings) + => GHCupPath -- ^ build directory (cleaned up depending on Settings) -> Excepts e m a -> Excepts e m a runBuildAction bdir action = do @@ -1083,7 +1081,7 @@ cleanUpOnError :: ( MonadReader env m , MonadFail m , MonadCatch m ) - => FilePath -- ^ build directory (cleaned up depending on Settings) + => GHCupPath -- ^ build directory (cleaned up depending on Settings) -> Excepts e m a -> Excepts e m a cleanUpOnError bdir action = do @@ -1104,7 +1102,7 @@ cleanFinally :: ( MonadReader env m , MonadFail m , MonadCatch m ) - => FilePath -- ^ build directory (cleaned up depending on Settings) + => GHCupPath -- ^ build directory (cleaned up depending on Settings) -> Excepts e m a -> Excepts e m a cleanFinally bdir action = do @@ -1115,10 +1113,10 @@ cleanFinally bdir action = do -- | Remove a build directory, ignoring if it doesn't exist and gracefully -- printing other errors without crashing. -rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => FilePath -> m () +rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => GHCupPath -> m () rmBDir dir = withRunInIO (\run -> run $ liftIO $ handleIO (\e -> run $ logWarn $ - "Couldn't remove build dir " <> T.pack dir <> ", error was: " <> T.pack (displayException e)) + "Couldn't remove build dir " <> T.pack (fromGHCupPath dir) <> ", error was: " <> T.pack (displayException e)) $ hideError doesNotExistErrorType $ rmPathForcibly dir) @@ -1204,7 +1202,7 @@ createLink :: ( MonadMask m createLink link exe | isWindows = do dirs <- getDirs - let shimGen = cacheDir dirs "gs.exe" + let shimGen = fromGHCupPath (cacheDir dirs) "gs.exe" let shim = dropExtension exe <.> "shim" -- For hardlinks, link needs to be absolute. @@ -1248,8 +1246,8 @@ ensureGlobalTools let dl = downloadCached' shimDownload (Just "gs.exe") Nothing void $ (\DigestError{} -> do lift $ logWarn "Digest doesn't match, redownloading gs.exe..." - lift $ logDebug ("rm -f " <> T.pack (cacheDir dirs "gs.exe")) - lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs "gs.exe") + lift $ logDebug ("rm -f " <> T.pack (fromGHCupPath (cacheDir dirs) "gs.exe")) + lift $ hideError doesNotExistErrorType $ recycleFile (fromGHCupPath (cacheDir dirs) "gs.exe") liftE @'[GPGError, DigestError , DownloadFailed] $ dl ) `catchE` liftE @'[GPGError, DigestError , DownloadFailed] dl | otherwise = pure () @@ -1258,14 +1256,14 @@ ensureGlobalTools -- | Ensure ghcup directory structure exists. ensureDirectories :: Dirs -> IO () ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir dbDir) = do - createDirRecursive' baseDir - createDirRecursive' (baseDir "ghc") + createDirRecursive' (fromGHCupPath baseDir) + createDirRecursive' (fromGHCupPath baseDir "ghc") createDirRecursive' binDir - createDirRecursive' cacheDir - createDirRecursive' logsDir - createDirRecursive' confDir - createDirRecursive' trashDir - createDirRecursive' dbDir + createDirRecursive' (fromGHCupPath cacheDir) + createDirRecursive' (fromGHCupPath logsDir) + createDirRecursive' (fromGHCupPath confDir) + createDirRecursive' (fromGHCupPath trashDir) + createDirRecursive' (fromGHCupPath dbDir) pure () @@ -1293,7 +1291,7 @@ installDestSanityCheck :: ( MonadIO m Excepts '[DirNotEmpty] m () installDestSanityCheck (IsolateDirResolved isoDir) = do hideErrorDef [doesNotExistErrorType] () $ do - contents <- liftIO $ getDirectoryContentsRecursive isoDir + contents <- liftIO $ getDirectoryContentsRecursiveUnsafe isoDir unless (null contents) (throwE $ DirNotEmpty isoDir) installDestSanityCheck _ = pure () @@ -1342,6 +1340,6 @@ recordedInstallationFile :: ( MonadReader env m -> m FilePath recordedInstallationFile t v' = do Dirs {..} <- getDirs - pure (dbDir prettyShow t T.unpack (tVerToText v')) + pure (fromGHCupPath dbDir prettyShow t T.unpack (tVerToText v')) diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs index 6a060b0..7f9ffb0 100644 --- a/lib/GHCup/Utils/Dirs.hs +++ b/lib/GHCup/Utils/Dirs.hs @@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE QuasiQuotes #-} {-| Module : GHCup.Utils.Dirs @@ -30,6 +31,74 @@ module GHCup.Utils.Dirs , getConfigFilePath , useXDG , cleanupTrash + + , GHCupPath + , appendGHCupPath + , fromGHCupPath + , createTempGHCupDirectory + , getGHCupTmpDirs + + , removeDirectory + , removeDirectoryRecursive + , removePathForcibly + + -- System.Directory re-exports + , createDirectory + , createDirectoryIfMissing + , renameDirectory + , listDirectory + , getDirectoryContents + , getCurrentDirectory + , setCurrentDirectory + , withCurrentDirectory + , getHomeDirectory + , XdgDirectory(..) + , getXdgDirectory + , XdgDirectoryList(..) + , getXdgDirectoryList + , getAppUserDataDirectory + , getUserDocumentsDirectory + , getTemporaryDirectory + , removeFile + , renameFile + , renamePath + , getFileSize + , canonicalizePath + , makeAbsolute + , makeRelativeToCurrentDirectory + , doesPathExist + , doesFileExist + , doesDirectoryExist + , findExecutable + , findExecutables + , findExecutablesInDirectories + , findFile + , findFileWith + , findFilesWith + , exeExtension + , createFileLink + , createDirectoryLink + , removeDirectoryLink + , pathIsSymbolicLink + , getSymbolicLinkTarget + , Permissions + , emptyPermissions + , readable + , writable + , executable + , searchable + , setOwnerReadable + , setOwnerWritable + , setOwnerExecutable + , setOwnerSearchable + , getPermissions + , setPermissions + , copyPermissions + , getAccessTime + , getModificationTime + , setAccessTime + , setModificationTime + , isSymbolicLink ) where @@ -41,23 +110,35 @@ import GHCup.Types.Optics import GHCup.Utils.MegaParsec import GHCup.Utils.Logger import GHCup.Utils.Prelude +import GHCup.Utils.File.Common +import GHCup.Utils.String.QQ +import Control.DeepSeq (NFData, rnf) import Control.Exception.Safe import Control.Monad import Control.Monad.IO.Unlift import Control.Monad.Reader import Control.Monad.Trans.Resource hiding (throwM) +import Data.List +import Data.ByteString ( ByteString ) import Data.Bifunctor import Data.Maybe import Data.Versions import GHC.IO.Exception ( IOErrorType(NoSuchThing) ) import Haskus.Utils.Variant.Excepts import Optics -import System.Directory +import System.Directory hiding ( removeDirectory + , removeDirectoryRecursive + , removePathForcibly + , findFiles + ) +import qualified System.Directory as SD + import System.DiskSpace import System.Environment import System.FilePath import System.IO.Temp +import Text.Regex.Posix import qualified Data.ByteString as BS import qualified Data.Text as T @@ -67,6 +148,41 @@ import Control.Concurrent (threadDelay) + --------------------------- + --[ GHCupPath utilities ]-- + --------------------------- + +-- | A 'GHCupPath' is a safe sub-path that can be recursively deleted. +-- +-- The constructor is not exported. +newtype GHCupPath = GHCupPath FilePath + deriving (Show, Eq, Ord) + +instance NFData GHCupPath where + rnf (GHCupPath fp) = rnf fp + +appendGHCupPath :: GHCupPath -> FilePath -> GHCupPath +appendGHCupPath (GHCupPath gp) fp = GHCupPath (gp fp) + +fromGHCupPath :: GHCupPath -> FilePath +fromGHCupPath (GHCupPath gp) = gp + +createTempGHCupDirectory :: GHCupPath -> FilePath -> IO GHCupPath +createTempGHCupDirectory (GHCupPath gp) d = GHCupPath <$> createTempDirectory gp d + + +getGHCupTmpDirs :: IO [GHCupPath] +getGHCupTmpDirs = do + tmpdir <- getCanonicalTemporaryDirectory + ghcup_dirs <- handleIO (\_ -> pure []) $ findFiles + tmpdir + (makeRegexOpts compExtended + execBlank + ([s|^ghcup-.*$|] :: ByteString) + ) + pure (fmap (\p -> GHCupPath (tmpdir p)) $ filter (("ghcup-" `isPrefixOf`) . takeDirectory) $ ghcup_dirs) + + ------------------------------ --[ GHCup base directories ]-- ------------------------------ @@ -76,11 +192,11 @@ import Control.Concurrent (threadDelay) -- -- If 'GHCUP_USE_XDG_DIRS' is set (to anything), -- then uses 'XDG_DATA_HOME/ghcup' as per xdg spec. -ghcupBaseDir :: IO FilePath +ghcupBaseDir :: IO GHCupPath ghcupBaseDir | isWindows = do bdir <- fromMaybe "C:\\" <$> lookupEnv "GHCUP_INSTALL_BASE_PREFIX" - pure (bdir "ghcup") + pure (GHCupPath (bdir "ghcup")) | otherwise = do xdg <- useXDG if xdg @@ -90,19 +206,19 @@ ghcupBaseDir Nothing -> do home <- liftIO getHomeDirectory pure (home ".local" "share") - pure (bdir "ghcup") + pure (GHCupPath (bdir "ghcup")) else do bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case Just r -> pure r Nothing -> liftIO getHomeDirectory - pure (bdir ".ghcup") + pure (GHCupPath (bdir ".ghcup")) -- | ~/.ghcup by default -- -- If 'GHCUP_USE_XDG_DIRS' is set (to anything), -- then uses 'XDG_CONFIG_HOME/ghcup' as per xdg spec. -ghcupConfigDir :: IO FilePath +ghcupConfigDir :: IO GHCupPath ghcupConfigDir | isWindows = ghcupBaseDir | otherwise = do @@ -114,12 +230,12 @@ ghcupConfigDir Nothing -> do home <- liftIO getHomeDirectory pure (home ".config") - pure (bdir "ghcup") + pure (GHCupPath (bdir "ghcup")) else do bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case Just r -> pure r Nothing -> liftIO getHomeDirectory - pure (bdir ".ghcup") + pure (GHCupPath (bdir ".ghcup")) -- | If 'GHCUP_USE_XDG_DIRS' is set (to anything), @@ -127,7 +243,7 @@ ghcupConfigDir -- (which, sadly is not strictly xdg spec). ghcupBinDir :: IO FilePath ghcupBinDir - | isWindows = ghcupBaseDir <&> ( "bin") + | isWindows = (fromGHCupPath <$> ghcupBaseDir) <&> ( "bin") | otherwise = do xdg <- useXDG if xdg @@ -137,16 +253,16 @@ ghcupBinDir Nothing -> do home <- liftIO getHomeDirectory pure (home ".local" "bin") - else ghcupBaseDir <&> ( "bin") + else (fromGHCupPath <$> ghcupBaseDir) <&> ( "bin") -- | Defaults to '~/.ghcup/cache'. -- -- If 'GHCUP_USE_XDG_DIRS' is set (to anything), -- then uses 'XDG_CACHE_HOME/ghcup' as per xdg spec. -ghcupCacheDir :: IO FilePath +ghcupCacheDir :: IO GHCupPath ghcupCacheDir - | isWindows = ghcupBaseDir <&> ( "cache") + | isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp "cache")) | otherwise = do xdg <- useXDG if xdg @@ -156,17 +272,17 @@ ghcupCacheDir Nothing -> do home <- liftIO getHomeDirectory pure (home ".cache") - pure (bdir "ghcup") - else ghcupBaseDir <&> ( "cache") + pure (GHCupPath (bdir "ghcup")) + else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp "cache")) -- | Defaults to '~/.ghcup/logs'. -- -- If 'GHCUP_USE_XDG_DIRS' is set (to anything), -- then uses 'XDG_CACHE_HOME/ghcup/logs' as per xdg spec. -ghcupLogsDir :: IO FilePath +ghcupLogsDir :: IO GHCupPath ghcupLogsDir - | isWindows = ghcupBaseDir <&> ( "logs") + | isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp "logs")) | otherwise = do xdg <- useXDG if xdg @@ -176,17 +292,17 @@ ghcupLogsDir Nothing -> do home <- liftIO getHomeDirectory pure (home ".cache") - pure (bdir "ghcup" "logs") - else ghcupBaseDir <&> ( "logs") + pure (GHCupPath (bdir "ghcup" "logs")) + else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp "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 :: IO GHCupPath ghcupDbDir - | isWindows = ghcupBaseDir <&> ( "db") + | isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp "db")) | otherwise = do xdg <- useXDG if xdg @@ -196,14 +312,14 @@ ghcupDbDir Nothing -> do home <- liftIO getHomeDirectory pure (home ".cache") - pure (bdir "ghcup" "db") - else ghcupBaseDir <&> ( "db") + pure (GHCupPath (bdir "ghcup" "db")) + else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp "db")) -- | '~/.ghcup/trash'. -- Mainly used on windows to improve file removal operations -ghcupRecycleDir :: IO FilePath -ghcupRecycleDir = ghcupBaseDir <&> ( "trash") +ghcupRecycleDir :: IO GHCupPath +ghcupRecycleDir = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp "trash")) @@ -227,7 +343,7 @@ getAllDirs = do getConfigFilePath :: (MonadIO m) => m FilePath getConfigFilePath = do confDir <- liftIO ghcupConfigDir - pure $ confDir "config.yaml" + pure $ fromGHCupPath confDir "config.yaml" ghcupConfigFile :: (MonadIO m) => Excepts '[JSONError] m UserSettings @@ -245,10 +361,10 @@ ghcupConfigFile = do -- | ~/.ghcup/ghc by default. -ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m FilePath +ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath ghcupGHCBaseDir = do Dirs {..} <- getDirs - pure (baseDir "ghc") + pure (baseDir `appendGHCupPath` "ghc") -- | Gets '~/.ghcup/ghc/'. @@ -257,11 +373,11 @@ ghcupGHCBaseDir = do -- * 8.8.4 ghcupGHCDir :: (MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion - -> m FilePath + -> m GHCupPath ghcupGHCDir ver = do ghcbasedir <- ghcupGHCBaseDir let verdir = T.unpack $ tVerToText ver - pure (ghcbasedir verdir) + pure (ghcbasedir `appendGHCupPath` verdir) -- | See 'ghcupToolParser'. @@ -274,19 +390,19 @@ parseGHCupHLSDir (T.pack -> fp) = throwEither $ MP.parse version' "" fp -- | ~/.ghcup/hls by default, for new-style installs. -ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m FilePath +ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath ghcupHLSBaseDir = do Dirs {..} <- getDirs - pure (baseDir "hls") + pure (baseDir `appendGHCupPath` "hls") -- | Gets '~/.ghcup/hls/' for new-style installs. ghcupHLSDir :: (MonadReader env m, HasDirs env, MonadThrow m) => Version - -> m FilePath + -> m GHCupPath ghcupHLSDir ver = do basedir <- ghcupHLSBaseDir let verdir = T.unpack $ prettyVer ver - pure (basedir verdir) + pure (basedir `appendGHCupPath` verdir) mkGhcupTmpDir :: ( MonadReader env m , HasDirs env @@ -296,8 +412,8 @@ mkGhcupTmpDir :: ( MonadReader env m , MonadThrow m , MonadMask m , MonadIO m) - => m FilePath -mkGhcupTmpDir = do + => m GHCupPath +mkGhcupTmpDir = GHCupPath <$> do tmpdir <- liftIO getCanonicalTemporaryDirectory let minSpace = 5000 -- a rough guess, aight? @@ -333,14 +449,14 @@ withGHCupTmpDir :: ( MonadReader env m , MonadThrow m , MonadMask m , MonadIO m) - => m FilePath + => m GHCupPath withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir) (\fp -> handleIO (\e -> run - $ logDebug ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e))) + $ logDebug ("Resource cleanup failed for " <> T.pack (fromGHCupPath fp) <> ", error was: " <> T.pack (displayException e))) . rmPathForcibly $ fp)) @@ -381,12 +497,27 @@ cleanupTrash :: ( MonadIO m => m () cleanupTrash = do Dirs { recycleDir } <- getDirs - contents <- liftIO $ listDirectory recycleDir + contents <- liftIO $ listDirectory (fromGHCupPath recycleDir) if null contents then pure () else do - logWarn ("Removing leftover files in " <> T.pack recycleDir) + logWarn ("Removing leftover files in " <> T.pack (fromGHCupPath recycleDir)) forM_ contents (\fp -> handleIO (\e -> logDebug ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e)) - ) $ liftIO $ removePathForcibly (recycleDir fp)) + ) $ liftIO $ removePathForcibly (recycleDir `appendGHCupPath` fp)) + + + +-- System.Directory re-exports with GHCupPath + +removeDirectory :: GHCupPath -> IO () +removeDirectory (GHCupPath fp) = SD.removeDirectory fp + +removeDirectoryRecursive :: GHCupPath -> IO () +removeDirectoryRecursive (GHCupPath fp) = SD.removeDirectoryRecursive fp + +removePathForcibly :: GHCupPath -> IO () +removePathForcibly (GHCupPath fp) = SD.removePathForcibly fp + + diff --git a/lib/GHCup/Utils/Dirs.hs-boot b/lib/GHCup/Utils/Dirs.hs-boot new file mode 100644 index 0000000..bf19c91 --- /dev/null +++ b/lib/GHCup/Utils/Dirs.hs-boot @@ -0,0 +1,37 @@ +module GHCup.Utils.Dirs + ( GHCupPath + , appendGHCupPath + , fromGHCupPath + , createTempGHCupDirectory + , removeDirectory + , removeDirectoryRecursive + , removePathForcibly + ) + where + +import Control.DeepSeq (NFData) + + +-- | A 'GHCupPath' is a safe sub-path that can be recursively deleted. +newtype GHCupPath = GHCupPath FilePath + +instance Show GHCupPath where + +instance Eq GHCupPath where + +instance Ord GHCupPath where + +instance NFData GHCupPath where + +appendGHCupPath :: GHCupPath -> FilePath -> GHCupPath + +fromGHCupPath :: GHCupPath -> FilePath + +createTempGHCupDirectory :: GHCupPath -> FilePath -> IO GHCupPath + +removeDirectory :: GHCupPath -> IO () + +removeDirectoryRecursive :: GHCupPath -> IO () + +removePathForcibly :: GHCupPath -> IO () + diff --git a/lib/GHCup/Utils/File.hs b/lib/GHCup/Utils/File.hs index a08c981..a26438e 100644 --- a/lib/GHCup/Utils/File.hs +++ b/lib/GHCup/Utils/File.hs @@ -19,6 +19,7 @@ module GHCup.Utils.File ( #endif ) where +import GHCup.Utils.Dirs import GHCup.Utils.File.Common #if IS_WINDOWS import GHCup.Utils.File.Windows @@ -32,7 +33,6 @@ 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) @@ -42,9 +42,9 @@ 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 + => GHCupPath -- ^ source base directory from which to install findFiles -> FilePath -- ^ destination base dir - -> (FilePath -> FilePath -> m ()) -- ^ file copy operation + -> (FilePath -> FilePath -> m ()) -- ^ file copy operation -> m [FilePath] mergeFileTreeAll sourceBase destBase copyOp = do (force -> !sourceFiles) <- liftIO @@ -54,12 +54,12 @@ mergeFileTreeAll sourceBase destBase copyOp = do mergeFileTree :: MonadIO m - => FilePath -- ^ source base directory from which to install findFiles + => GHCupPath -- ^ 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 + -> (FilePath -> FilePath -> m ()) -- ^ file copy operation -> m () -mergeFileTree sourceBase sources destBase copyOp = do +mergeFileTree (fromGHCupPath -> sourceBase) sources destBase copyOp = do -- These checks are not atomic, but we perform them to have -- the opportunity to abort before copying has started. -- diff --git a/lib/GHCup/Utils/File/Common.hs b/lib/GHCup/Utils/File/Common.hs index f72e38c..51405a4 100644 --- a/lib/GHCup/Utils/File/Common.hs +++ b/lib/GHCup/Utils/File/Common.hs @@ -9,6 +9,7 @@ module GHCup.Utils.File.Common ( ) where import GHCup.Utils.Prelude +import {-# SOURCE #-} GHCup.Utils.Dirs ( GHCupPath ) import GHCup.Types(ProcessError(..), CapturedProcess(..)) import Control.Monad.Reader @@ -16,7 +17,11 @@ import Data.Maybe import Data.Text ( Text ) import Data.Void import GHC.IO.Exception -import System.Directory hiding (findFiles, copyFile) +import System.Directory hiding ( removeDirectory + , removeDirectoryRecursive + , removePathForcibly + , findFiles + ) import System.FilePath import Text.Regex.Posix @@ -94,7 +99,7 @@ findFiles path regex = do contents <- listDirectory path pure $ filter (match regex) contents -findFilesDeep :: FilePath -> Regex -> IO [FilePath] +findFilesDeep :: GHCupPath -> Regex -> IO [FilePath] findFilesDeep path regex = do contents <- getDirectoryContentsRecursive path pure $ filter (match regex) contents diff --git a/lib/GHCup/Utils/File/Posix.hs b/lib/GHCup/Utils/File/Posix.hs index 24069a0..c309ea4 100644 --- a/lib/GHCup/Utils/File/Posix.hs +++ b/lib/GHCup/Utils/File/Posix.hs @@ -17,6 +17,7 @@ Some of these functions use sophisticated logging. -} module GHCup.Utils.File.Posix where +import GHCup.Utils.Dirs import GHCup.Utils.File.Common import GHCup.Utils.Prelude import GHCup.Utils.Logger @@ -42,7 +43,6 @@ import GHC.IO.Exception import System.IO ( stderr, hClose, hSetBinaryMode ) import System.IO.Error import System.FilePath -import System.Directory hiding ( copyFile ) import System.Posix.Directory import System.Posix.Error ( throwErrnoPathIfMinus1Retry ) import System.Posix.Internals ( withFilePath ) @@ -56,6 +56,7 @@ import qualified Control.Exception as EX import qualified Data.Sequence as Sq import qualified Data.Text as T import qualified Data.Text.Encoding as E +import qualified System.Posix.Directory as PD import qualified System.Posix.Files as PF import qualified System.Posix.Process as SPP import qualified System.Posix.IO as SPI @@ -101,7 +102,7 @@ execLogged exe args chdir lfile env = do Settings {..} <- getSettings Dirs {..} <- getDirs logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args - let logfile = logsDir lfile <> ".log" + let logfile = fromGHCupPath logsDir lfile <> ".log" liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True }) closeFd (action verbose noColor) @@ -550,3 +551,6 @@ install from to fail' = do | PF.isSymbolicLink fs = recreateSymlink from to fail' | otherwise = ioError $ mkIOError illegalOperationErrorType "install: not a regular file or symlink" Nothing (Just from) + +removeEmptyDirectory :: FilePath -> IO () +removeEmptyDirectory = PD.removeDirectory diff --git a/lib/GHCup/Utils/File/Windows.hs b/lib/GHCup/Utils/File/Windows.hs index 36f529f..0199193 100644 --- a/lib/GHCup/Utils/File/Windows.hs +++ b/lib/GHCup/Utils/File/Windows.hs @@ -17,7 +17,7 @@ Some of these functions use sophisticated logging. module GHCup.Utils.File.Windows where import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink ) -import GHCup.Utils.Dirs +import GHCup.Utils.Dirs hiding ( copyFile ) import GHCup.Utils.File.Common import GHCup.Utils.Logger import GHCup.Types @@ -32,7 +32,6 @@ import Data.List import Foreign.C.Error import GHC.IO.Exception import GHC.IO.Handle -import System.Directory hiding ( copyFile ) import System.Environment import System.FilePath import System.IO @@ -284,3 +283,6 @@ deleteFile = WS.deleteFile install :: FilePath -> FilePath -> Bool -> IO () install = copyFile + +removeEmptyDirectory :: FilePath -> IO () +removeEmptyDirectory = WS.removeDirectory diff --git a/lib/GHCup/Utils/Logger.hs b/lib/GHCup/Utils/Logger.hs index a30c697..3763e07 100644 --- a/lib/GHCup/Utils/Logger.hs +++ b/lib/GHCup/Utils/Logger.hs @@ -17,6 +17,7 @@ module GHCup.Utils.Logger where import GHCup.Types import GHCup.Types.Optics +import {-# SOURCE #-} GHCup.Utils.Dirs (fromGHCupPath) import {-# SOURCE #-} GHCup.Utils.File.Common (findFiles) import GHCup.Utils.String.QQ @@ -117,14 +118,14 @@ initGHCupFileLogging :: ( MonadReader env m ) => m FilePath initGHCupFileLogging = do Dirs { logsDir } <- getDirs - let logfile = logsDir "ghcup.log" + let logfile = fromGHCupPath logsDir "ghcup.log" logFiles <- liftIO $ findFiles - logsDir + (fromGHCupPath logsDir) (makeRegexOpts compExtended execBlank ([s|^.*\.log$|] :: B.ByteString) ) - forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (logsDir ) + forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (fromGHCupPath logsDir ) liftIO $ writeFile logfile "" pure logfile diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Utils/Prelude.hs index 668fde2..b47e4f8 100644 --- a/lib/GHCup/Utils/Prelude.hs +++ b/lib/GHCup/Utils/Prelude.hs @@ -27,6 +27,7 @@ module GHCup.Utils.Prelude ) where +import {-# SOURCE #-} GHCup.Utils.Dirs (GHCupPath, fromGHCupPath, createTempGHCupDirectory, appendGHCupPath, removePathForcibly, removeDirectory) import GHCup.Types import GHCup.Errors import GHCup.Types.Optics @@ -44,9 +45,8 @@ import Control.Monad.IO.Class import Control.Monad.Reader import Data.Bifunctor import Data.ByteString ( ByteString ) -import Data.List ( nub, intercalate, stripPrefix, isPrefixOf, dropWhileEnd, intersperse ) +import Data.List ( intercalate, stripPrefix, isPrefixOf, dropWhileEnd, intersperse ) import Data.Maybe -import Data.Foldable import Data.List.NonEmpty ( NonEmpty( (:|) )) import Data.String import Data.Text ( Text ) @@ -56,9 +56,12 @@ import Haskus.Utils.Types.List import Haskus.Utils.Variant.Excepts import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty ) import System.IO.Error -import System.IO.Temp import System.IO.Unsafe -import System.Directory hiding ( copyFile ) +import System.Directory hiding ( removeDirectory + , removeDirectoryRecursive + , removePathForcibly + , copyFile + ) import System.FilePath import Control.Retry @@ -397,30 +400,6 @@ createDirRecursive' p = _ -> throwIO e --- | Recursively copy the contents of one directory to another path. --- --- This is a rip-off of Cabal library. -copyDirectoryRecursive :: FilePath -> FilePath -> (FilePath -> FilePath -> IO ()) -> IO () -copyDirectoryRecursive srcDir destDir doCopy = do - srcFiles <- getDirectoryContentsRecursive srcDir - copyFilesWith destDir [ (srcDir, f) - | f <- srcFiles ] - where - -- | Common implementation of 'copyFiles', 'installOrdinaryFiles', - -- 'installExecutableFiles' and 'installMaybeExecutableFiles'. - copyFilesWith :: FilePath -> [(FilePath, FilePath)] -> IO () - copyFilesWith targetDir srcFiles = do - - -- Create parent directories for everything - let dirs = map (targetDir ) . nub . map takeDirectory $ fmap snd srcFiles - traverse_ (createDirectoryIfMissing True) dirs - - -- Copy all the files - sequence_ [ let src = srcBase srcFile - dest = targetDir srcFile - in doCopy src dest - | (srcBase, srcFile) <- srcFiles ] - -- | List all the files in a directory and all subdirectories. -- @@ -429,8 +408,12 @@ copyDirectoryRecursive srcDir destDir doCopy = do -- the source directory structure changes before the list is used. -- -- TODO: use streamly -getDirectoryContentsRecursive :: FilePath -> IO [FilePath] -getDirectoryContentsRecursive topdir = recurseDirectories [""] +getDirectoryContentsRecursive :: GHCupPath -> IO [FilePath] +getDirectoryContentsRecursive (fromGHCupPath -> topdir) = getDirectoryContentsRecursiveUnsafe topdir + + +getDirectoryContentsRecursiveUnsafe :: FilePath -> IO [FilePath] +getDirectoryContentsRecursiveUnsafe topdir = recurseDirectories [""] where recurseDirectories :: [FilePath] -> IO [FilePath] recurseDirectories [] = return [] @@ -464,14 +447,14 @@ recyclePathForcibly :: ( MonadIO m , HasDirs env , MonadMask m ) - => FilePath + => GHCupPath -> m () recyclePathForcibly fp | isWindows = do Dirs { recycleDir } <- getDirs - tmp <- liftIO $ createTempDirectory recycleDir "recyclePathForcibly" - let dest = tmp takeFileName fp - liftIO (moveFile fp dest) + tmp <- liftIO $ createTempGHCupDirectory recycleDir "recyclePathForcibly" + let dest = tmp `appendGHCupPath` takeFileName (fromGHCupPath fp) + liftIO (moveFile (fromGHCupPath fp) (fromGHCupPath dest)) `catch` (\e -> if | isDoesNotExistError e -> pure () | isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} -> recover (liftIO $ removePathForcibly fp) @@ -484,7 +467,7 @@ recyclePathForcibly fp rmPathForcibly :: ( MonadIO m , MonadMask m ) - => FilePath + => GHCupPath -> m () rmPathForcibly fp | isWindows = recover (liftIO $ removePathForcibly fp) @@ -492,7 +475,7 @@ rmPathForcibly fp rmDirectory :: (MonadIO m, MonadMask m) - => FilePath + => GHCupPath -> m () rmDirectory fp | isWindows = recover (liftIO $ removeDirectory fp) @@ -512,11 +495,11 @@ recycleFile fp | isWindows = do Dirs { recycleDir } <- getDirs liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "recycleFile" "" Nothing (Just fp)) - tmp <- liftIO $ createTempDirectory recycleDir "recycleFile" - let dest = tmp takeFileName fp + tmp <- liftIO $ createTempGHCupDirectory recycleDir "recycleFile" + let dest = fromGHCupPath tmp takeFileName fp liftIO (moveFile fp dest) `catch` - (\e -> if isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e) + (\e -> if isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} then recover (liftIO $ rmFile fp) else throwIO e) `finally` liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp) | otherwise = liftIO $ removeFile fp diff --git a/lib/GHCup/Utils/Prelude/Posix.hs b/lib/GHCup/Utils/Prelude/Posix.hs index f677a68..e092320 100644 --- a/lib/GHCup/Utils/Prelude/Posix.hs +++ b/lib/GHCup/Utils/Prelude/Posix.hs @@ -1,6 +1,10 @@ module GHCup.Utils.Prelude.Posix where -import System.Directory +import System.Directory hiding ( removeDirectory + , removeDirectoryRecursive + , removePathForcibly + , findFiles + ) import System.Posix.Files From 55fdc41137b5afd22f2b3612d230f395eabe1dd2 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sat, 14 May 2022 17:58:11 +0200 Subject: [PATCH 05/20] WIP --- .gitlab/script/ghcup_version.sh | 2 + cabal.project | 3 + cbits/dirutils.c | 7 + cbits/dirutils.h | 15 ++ ghcup.cabal | 9 +- lib/GHCup.hs | 58 +++--- lib/GHCup/Utils.hs | 39 +--- lib/GHCup/Utils/Dirs.hs | 3 +- lib/GHCup/Utils/File.hs | 171 +++++++++++------ lib/GHCup/Utils/File/Common.hs | 6 +- lib/GHCup/Utils/File/Posix.hs | 69 ++++++- lib/GHCup/Utils/File/Posix/Foreign.hsc | 19 -- lib/GHCup/Utils/File/Posix/Traversals.hs | 92 +++++++++ lib/GHCup/Utils/File/Windows.hs | 232 ++++++++++++++++++++++- lib/GHCup/Utils/Prelude.hs | 41 +--- test/GHCup/Utils/FileSpec.hs | 58 ++++++ test/Main.hs | 3 +- 17 files changed, 626 insertions(+), 201 deletions(-) create mode 100644 cbits/dirutils.c create mode 100644 cbits/dirutils.h create mode 100644 lib/GHCup/Utils/File/Posix/Traversals.hs create mode 100644 test/GHCup/Utils/FileSpec.hs diff --git a/.gitlab/script/ghcup_version.sh b/.gitlab/script/ghcup_version.sh index 604aaee..137388f 100755 --- a/.gitlab/script/ghcup_version.sh +++ b/.gitlab/script/ghcup_version.sh @@ -35,6 +35,8 @@ git describe --always ### build +rm -rf "${GHCUP_DIR}"/share + ecabal update if [ "${OS}" = "DARWIN" ] ; then diff --git a/cabal.project b/cabal.project index 8751e9c..3c3e419 100644 --- a/cabal.project +++ b/cabal.project @@ -31,4 +31,7 @@ package cabal-plan package aeson flags: +ordered-keymap +package streamly + flags: +use-unliftio + allow-newer: base, ghc-prim, template-haskell, language-c diff --git a/cbits/dirutils.c b/cbits/dirutils.c new file mode 100644 index 0000000..2ba92ab --- /dev/null +++ b/cbits/dirutils.c @@ -0,0 +1,7 @@ +#include "dirutils.h" + +unsigned int + __posixdir_d_type(struct dirent* d) + { + return(d -> d_type); + } diff --git a/cbits/dirutils.h b/cbits/dirutils.h new file mode 100644 index 0000000..e2d7498 --- /dev/null +++ b/cbits/dirutils.h @@ -0,0 +1,15 @@ +#ifndef POSIXPATHS_CBITS_DIRUTILS_H +#define POSIXPATHS_CBITS_DIRUTILS_H + +#include +#include +#include +#include +#include + + +extern unsigned int + __posixdir_d_type(struct dirent* d) + ; + +#endif diff --git a/ghcup.cabal b/ghcup.cabal index 6a12eca..1b8ae3e 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -126,8 +126,8 @@ library , safe ^>=0.3.18 , safe-exceptions ^>=0.1 , split ^>=0.2.3.4 - , strict-base ^>=0.4 , streamly ^>=0.8.2 + , strict-base ^>=0.4 , template-haskell >=2.7 && <2.18 , temporary ^>=1.3 , text ^>=1.2.4.0 @@ -167,9 +167,11 @@ library other-modules: GHCup.Utils.File.Posix GHCup.Utils.File.Posix.Foreign + GHCup.Utils.File.Posix.Traversals GHCup.Utils.Posix GHCup.Utils.Prelude.Posix + c-sources: cbits/dirutils.c build-depends: , bz2 >=0.5.0.5 && <1.1 , terminal-size ^>=0.3.2.1 @@ -273,7 +275,6 @@ executable ghcup if flag(no-exe) buildable: False - test-suite ghcup-test type: exitcode-stdio-1.0 main-is: Main.hs @@ -282,6 +283,7 @@ test-suite ghcup-test other-modules: GHCup.ArbitraryTypes GHCup.Types.JSONSpec + GHCup.Utils.FileSpec Spec default-language: Haskell2010 @@ -301,12 +303,15 @@ test-suite ghcup-test , base >=4.12 && <5 , bytestring ^>=0.10 , containers ^>=0.6 + , directory ^>=1.3.6.0 + , filepath ^>=1.4.2.1 , generic-arbitrary >=0.1.0 && <0.3 , ghcup , hspec >=2.7.10 && <2.10 , hspec-golden-aeson ^>=0.9 , QuickCheck ^>=2.14.1 , quickcheck-arbitrary-adt ^>=0.3.1.0 + , streamly ^>=0.8.2 , text ^>=1.2.4.0 , uri-bytestring ^>=0.3.2.2 , versions >=4.0.1 && <5.1 diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 6ad9e24..dddf78f 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -42,8 +42,6 @@ import GHCup.Version import Codec.Archive ( ArchiveResult ) import Control.Applicative -import Control.DeepSeq ( force ) -import Control.Exception ( evaluate ) import Control.Exception.Safe import Control.Monad #if !MIN_VERSION_base(4,13,0) @@ -52,7 +50,6 @@ import Control.Monad.Fail ( MonadFail ) import Control.Monad.Reader import Control.Monad.Trans.Resource hiding ( throwM ) -import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) ) import Data.ByteString ( ByteString ) import Data.Either import Data.List @@ -94,6 +91,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Encoding as E import qualified Text.Megaparsec as MP +import qualified Streamly.Prelude as S import GHCup.Utils.MegaParsec import Control.Concurrent (threadDelay) @@ -328,13 +326,10 @@ installUnpackedGHC path inst ver forceInstall -- Windows bindists are relocatable and don't need -- to run configure. -- We also must make sure to preserve mtime to not confuse ghc-pkg. - fs <- lift $ withRunInIO $ \_ -> mergeFileTreeAll path (fromInstallDir inst) $ \source dest -> do + lift $ mergeFileTree path inst GHC (mkTVer ver) $ \source dest -> liftIO $ do mtime <- getModificationTime source moveFilePortable source dest setModificationTime dest mtime - case inst of - IsolateDirResolved _ -> pure () - _ -> recordInstalledFiles fs GHC (mkTVer ver) | otherwise = do PlatformRequest {..} <- lift getPlatformReq @@ -355,13 +350,12 @@ installUnpackedGHC path inst ver forceInstall tmpInstallDest <- lift withGHCupTmpDir lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "install"] (Just $ fromGHCupPath path) lift $ logInfo $ "Merging file tree from \"" <> T.pack (fromGHCupPath tmpInstallDest) <> "\" to \"" <> T.pack (fromInstallDir inst) <> "\"" - fs <- mergeFileTreeAll (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst)) - (fromInstallDir inst) - (\f t -> liftIO (install f t (not forceInstall))) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromInstallDir inst) - case inst of - IsolateDirResolved _ -> pure () - _ -> recordInstalledFiles fs GHC (mkTVer ver) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpInstallDest) + lift $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst)) + inst + GHC + (mkTVer ver) + (\f t -> liftIO $ install f t (not forceInstall)) pure () @@ -670,13 +664,12 @@ installHLSUnpacked path inst ver forceInstall = do lift $ logInfo "Installing HLS" tmpInstallDest <- lift withGHCupTmpDir lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "PREFIX=" <> fromInstallDir inst, "install"] (Just path) - fs <- mergeFileTreeAll (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst)) - (fromInstallDir inst) - (\f t -> liftIO (install f t (not forceInstall))) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromInstallDir inst) - case inst of - IsolateDirResolved _ -> pure () - _ -> recordInstalledFiles fs HLS (mkTVer ver) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpInstallDest) + lift $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst)) + inst + HLS + (mkTVer ver) + (\f t -> liftIO $ install f t (not forceInstall)) -- | Install an unpacked hls distribution (legacy). installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m) @@ -1804,11 +1797,11 @@ rmGHCVer ver = do 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 $ hideError doesNotExistErrorType $ deleteFile f + forM_ files (lift . recycleFile . (\f -> dir dropDrive f)) removeEmptyDirsRecursive dir survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory dir + f <- recordedInstallationFile GHC ver + lift $ recycleFile f when (not (null survivors)) $ throwE $ UninstallFailed dir survivors Nothing -> do lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack dir @@ -1888,11 +1881,11 @@ rmHLSVer ver = do 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 + forM_ files (lift . recycleFile . (\f -> hlsDir dropDrive f)) removeEmptyDirsRecursive hlsDir survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory hlsDir + f <- recordedInstallationFile HLS (mkTVer ver) + lift $ recycleFile f when (not (null survivors)) $ throwE $ UninstallFailed hlsDir survivors Nothing -> do lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack hlsDir @@ -2071,8 +2064,7 @@ rmGhcupDirs = do -- althought 'deleteFile' should already handle it. hideErrorDef [doesNotExistErrorType] () $ do logInfo $ "removing " <> T.pack (fromGHCupPath dir) - contents <- liftIO $ getDirectoryContentsRecursive dir - forM_ contents (deleteFile' . (fromGHCupPath dir )) + liftIO $ flip S.mapM_ (getDirectoryContentsRecursive dir) $ deleteFile' . (fromGHCupPath dir ) rmBinDir :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m () rmBinDir binDir @@ -2083,11 +2075,9 @@ rmGhcupDirs = do then removeDirIfEmptyOrIsSymlink binDir else pure () - reportRemainingFiles :: MonadIO m => FilePath -> m [FilePath] + reportRemainingFiles :: (MonadMask m, MonadIO m) => FilePath -> m [FilePath] reportRemainingFiles dir = do - -- force the files so the errors don't leak - (force -> !remainingFiles) <- liftIO - (getDirectoryContentsRecursiveUnsafe dir >>= evaluate) + remainingFiles <- liftIO $ S.toList (getDirectoryContentsRecursiveUnsafe dir) let normalizedFilePaths = fmap normalise remainingFiles let sortedByDepthRemainingFiles = sortBy (flip compareFn) normalizedFilePaths let remainingFilesAbsolute = fmap (dir ) sortedByDepthRemainingFiles @@ -2105,7 +2095,7 @@ rmGhcupDirs = do -- we report remaining files/dirs later, -- hence the force/quiet mode in these delete functions below. -deleteFile' :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m) => FilePath -> m () +deleteFile' :: (MonadMask m, MonadIO m) => FilePath -> m () deleteFile' filepath = do hideError doesNotExistErrorType $ hideError InappropriateType $ rmFile filepath diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 386dcb7..e227885 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -86,7 +86,7 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as E import qualified Text.Megaparsec as MP import qualified Data.List.NonEmpty as NE -import Text.PrettyPrint.HughesPJClass (prettyShow) +import qualified Streamly.Prelude as S import Control.DeepSeq (force) import GHC.IO (evaluate) @@ -853,7 +853,7 @@ intoSubdir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m, MonadCatc -> Excepts '[TarDirDoesNotExist] m GHCupPath intoSubdir bdir tardir = case tardir of RealDir pr -> do - whenM (fmap not . liftIO . doesDirectoryExist $ (fromGHCupPath (bdir `appendGHCupPath` pr))) + whenM (fmap not . liftIO . doesDirectoryExist $ fromGHCupPath (bdir `appendGHCupPath` pr)) (throwE $ TarDirDoesNotExist tardir) pure (bdir `appendGHCupPath` pr) RegexDir r -> do @@ -1286,35 +1286,17 @@ ghcBinaryName (GHCTargetVersion Nothing _) = T.unpack ("ghc" <> T.pack exeExt) -- 3. if it exists and is non-empty -> panic and leave the house installDestSanityCheck :: ( MonadIO m , MonadCatch m + , MonadMask m ) => InstallDirResolved -> Excepts '[DirNotEmpty] m () installDestSanityCheck (IsolateDirResolved isoDir) = do hideErrorDef [doesNotExistErrorType] () $ do - contents <- liftIO $ getDirectoryContentsRecursiveUnsafe isoDir - unless (null contents) (throwE $ DirNotEmpty isoDir) + empty' <- liftIO $ S.null $ getDirectoryContentsRecursiveUnsafe isoDir + when (not empty') (throwE $ DirNotEmpty isoDir) 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 @@ -1332,14 +1314,3 @@ getInstalledFiles t v' = hideErrorDef [doesNotExistErrorType] Nothing $ do pure (Just $ lines c) -recordedInstallationFile :: ( MonadReader env m - , HasDirs env - ) - => Tool - -> GHCTargetVersion - -> m FilePath -recordedInstallationFile t v' = do - Dirs {..} <- getDirs - pure (fromGHCupPath dbDir prettyShow t T.unpack (tVerToText v')) - - diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs index 7f9ffb0..acf8b37 100644 --- a/lib/GHCup/Utils/Dirs.hs +++ b/lib/GHCup/Utils/Dirs.hs @@ -127,6 +127,7 @@ import Data.Versions import GHC.IO.Exception ( IOErrorType(NoSuchThing) ) import Haskus.Utils.Variant.Excepts import Optics +import Safe import System.Directory hiding ( removeDirectory , removeDirectoryRecursive , removePathForcibly @@ -180,7 +181,7 @@ getGHCupTmpDirs = do execBlank ([s|^ghcup-.*$|] :: ByteString) ) - pure (fmap (\p -> GHCupPath (tmpdir p)) $ filter (("ghcup-" `isPrefixOf`) . takeDirectory) $ ghcup_dirs) + pure (fmap (\p -> GHCupPath (tmpdir p)) $ filter (maybe False ("ghcup-" `isPrefixOf`) . lastMay . splitPath) ghcup_dirs) ------------------------------ diff --git a/lib/GHCup/Utils/File.hs b/lib/GHCup/Utils/File.hs index a26438e..649163f 100644 --- a/lib/GHCup/Utils/File.hs +++ b/lib/GHCup/Utils/File.hs @@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -9,14 +8,27 @@ module GHCup.Utils.File ( mergeFileTree, - mergeFileTreeAll, copyFileE, + findFilesDeep, + getDirectoryContentsRecursive, + getDirectoryContentsRecursiveBFS, + getDirectoryContentsRecursiveDFS, + getDirectoryContentsRecursiveUnsafe, + getDirectoryContentsRecursiveBFSUnsafe, + getDirectoryContentsRecursiveDFSUnsafe, + recordedInstallationFile, module GHCup.Utils.File.Common, -#if IS_WINDOWS - module GHCup.Utils.File.Windows -#else - module GHCup.Utils.File.Posix -#endif + + executeOut, + execLogged, + exec, + toProcessError, + chmod_755, + isBrokenSymlink, + copyFile, + deleteFile, + install, + removeEmptyDirectory, ) where import GHCup.Utils.Dirs @@ -27,77 +39,122 @@ import GHCup.Utils.File.Windows import GHCup.Utils.File.Posix #endif import GHCup.Errors +import GHCup.Types +import GHCup.Types.Optics import GHCup.Utils.Prelude -import GHC.IO ( evaluate ) +import Text.Regex.Posix import Control.Exception.Safe import Haskus.Utils.Variant.Excepts import Control.Monad.Reader import System.FilePath +import Text.PrettyPrint.HughesPJClass (prettyShow) -import Data.List (nub) -import Data.Foldable (traverse_) -import Control.DeepSeq (force) +import qualified Data.Text as T +import qualified Streamly.Prelude as S --- | Like 'mergeFileTree', except reads the entire source base dir to determine files to copy recursively. -mergeFileTreeAll :: MonadIO m - => GHCupPath -- ^ 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 +mergeFileTree :: (MonadMask m, S.MonadAsync m, MonadReader env m, HasDirs env) => GHCupPath -- ^ source base directory from which to install findFiles - -> [FilePath] -- ^ relative filepaths from source base directory - -> FilePath -- ^ destination base dir + -> InstallDirResolved -- ^ destination base dir + -> Tool + -> GHCTargetVersion -> (FilePath -> FilePath -> m ()) -- ^ file copy operation -> m () -mergeFileTree (fromGHCupPath -> sourceBase) sources destBase copyOp = do +mergeFileTree sourceBase destBase tool v' 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 + liftIO $ baseCheck (fromGHCupPath sourceBase) + liftIO $ destCheck (fromInstallDir destBase) - -- finally copy - copy + recFile <- recordedInstallationFile tool v' + case destBase of + IsolateDirResolved _ -> pure () + _ -> do + whenM (liftIO $ doesFileExist recFile) $ throwIO $ userError ("mergeFileTree: DB file " <> recFile <> " already exists!") + liftIO $ createDirectoryIfMissing True (takeDirectory recFile) + + flip S.mapM_ (getDirectoryContentsRecursive sourceBase) $ \f -> do + copy f + recordInstalledFile f recFile + pure f where - copy = do - let dirs = map (destBase ) . nub . fmap takeDirectory $ sources - traverse_ (liftIO . createDirectoryIfMissing True) dirs + recordInstalledFile f recFile = do + case destBase of + IsolateDirResolved _ -> pure () + _ -> liftIO $ appendFile recFile (f <> "\n") + + copy source = do + let dest = fromInstallDir destBase source + src = fromGHCupPath sourceBase source + + when (isAbsolute source) + $ throwIO $ userError ("mergeFileTree: source file " <> source <> " is not relative!") + + liftIO . createDirectoryIfMissing True . takeDirectory $ dest + + copyOp src dest + + + baseCheck src = do + when (isRelative src) + $ throwIO $ userError ("mergeFileTree: source base directory " <> src <> " is not absolute!") + whenM (not <$> doesDirectoryExist src) + $ throwIO $ userError ("mergeFileTree: source base directory " <> src <> " does not exist!") + destCheck dest = do + when (isRelative dest) + $ throwIO $ userError ("mergeFileTree: destination base directory " <> dest <> " is not absolute!") - 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 + + +-- | List all the files in a directory and all subdirectories. +-- +-- The order places files in sub-directories after all the files in their +-- parent directories. The list is generated lazily so is not well defined if +-- the source directory structure changes before the list is used. +-- +-- depth first +getDirectoryContentsRecursiveDFS :: (MonadCatch m, S.MonadAsync m, MonadMask m) + => GHCupPath + -> S.SerialT m FilePath +getDirectoryContentsRecursiveDFS (fromGHCupPath -> fp) = getDirectoryContentsRecursiveDFSUnsafe fp + +-- breadth first +getDirectoryContentsRecursiveBFS :: (MonadCatch m, S.MonadAsync m, MonadMask m) + => GHCupPath + -> S.SerialT m FilePath +getDirectoryContentsRecursiveBFS (fromGHCupPath -> fp) = getDirectoryContentsRecursiveBFSUnsafe fp + + +getDirectoryContentsRecursive :: (MonadCatch m, S.MonadAsync m, MonadMask m) + => GHCupPath + -> S.SerialT m FilePath +getDirectoryContentsRecursive = getDirectoryContentsRecursiveBFS + +getDirectoryContentsRecursiveUnsafe :: (MonadCatch m, S.MonadAsync m, MonadMask m) + => FilePath + -> S.SerialT m FilePath +getDirectoryContentsRecursiveUnsafe = getDirectoryContentsRecursiveBFSUnsafe + +findFilesDeep :: GHCupPath -> Regex -> IO [FilePath] +findFilesDeep path regex = + S.toList $ S.filter (match regex) $ getDirectoryContentsRecursive path + + +recordedInstallationFile :: ( MonadReader env m + , HasDirs env + ) + => Tool + -> GHCTargetVersion + -> m FilePath +recordedInstallationFile t v' = do + Dirs {..} <- getDirs + pure (fromGHCupPath dbDir prettyShow t T.unpack (tVerToText v')) + diff --git a/lib/GHCup/Utils/File/Common.hs b/lib/GHCup/Utils/File/Common.hs index 51405a4..3a923e6 100644 --- a/lib/GHCup/Utils/File/Common.hs +++ b/lib/GHCup/Utils/File/Common.hs @@ -9,7 +9,6 @@ module GHCup.Utils.File.Common ( ) where import GHCup.Utils.Prelude -import {-# SOURCE #-} GHCup.Utils.Dirs ( GHCupPath ) import GHCup.Types(ProcessError(..), CapturedProcess(..)) import Control.Monad.Reader @@ -25,6 +24,7 @@ import System.Directory hiding ( removeDirectory import System.FilePath import Text.Regex.Posix + import qualified Data.Text as T import qualified Text.Megaparsec as MP @@ -99,10 +99,6 @@ findFiles path regex = do contents <- listDirectory path pure $ filter (match regex) contents -findFilesDeep :: GHCupPath -> Regex -> IO [FilePath] -findFilesDeep path regex = do - contents <- getDirectoryContentsRecursive path - pure $ filter (match regex) contents findFiles' :: FilePath -> MP.Parsec Void Text a -> IO [FilePath] findFiles' path parser = do diff --git a/lib/GHCup/Utils/File/Posix.hs b/lib/GHCup/Utils/File/Posix.hs index c309ea4..22cc00f 100644 --- a/lib/GHCup/Utils/File/Posix.hs +++ b/lib/GHCup/Utils/File/Posix.hs @@ -23,10 +23,11 @@ import GHCup.Utils.Prelude import GHCup.Utils.Logger import GHCup.Types import GHCup.Types.Optics +import GHCup.Utils.File.Posix.Traversals import Control.Concurrent import Control.Concurrent.Async -import Control.Exception ( evaluate ) +import qualified Control.Exception as E import Control.Exception.Safe import Control.Monad import Control.Monad.Reader @@ -71,6 +72,12 @@ import qualified Streamly.Internal.FileSystem.Handle as IFH import qualified Streamly.Prelude as S import qualified GHCup.Utils.File.Posix.Foreign as FD +import qualified Streamly.Internal.Data.Stream.StreamD.Type + as D +import Streamly.Internal.Data.Unfold.Type +import qualified Streamly.Internal.Data.Unfold as U +import Streamly.Internal.Control.Concurrent ( withRunInIO ) +import Streamly.Internal.Data.IOFinalizer ( newIOFinalizer, runIOFinalizer ) @@ -277,7 +284,7 @@ captureOutStreams action = do -- execute the action a <- action - void $ evaluate a + void $ E.evaluate a -- close everything we don't need closeFd childStdoutWrite @@ -554,3 +561,61 @@ install from to fail' = do removeEmptyDirectory :: FilePath -> IO () removeEmptyDirectory = PD.removeDirectory + + +-- | Create an 'Unfold' of directory contents. +unfoldDirContents :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath (FD.DirType, FilePath) +unfoldDirContents = U.bracket (liftIO . openDirStream) (liftIO . closeDirStream) (Unfold step return) + where + {-# INLINE [0] step #-} + step dirstream = do + (typ, e) <- liftIO $ readDirEnt dirstream + return $ if + | null e -> D.Stop + | "." == e -> D.Skip dirstream + | ".." == e -> D.Skip dirstream + | otherwise -> D.Yield (typ, e) dirstream + + +getDirectoryContentsRecursiveDFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m) + => FilePath + -> S.SerialT m FilePath +getDirectoryContentsRecursiveDFSUnsafe fp = go "" + where + go cd = flip S.concatMap (S.unfold unfoldDirContents (fp cd)) $ \(t, f) -> + if | t == FD.dtDir -> go (cd f) + | otherwise -> pure (cd f) + + +getDirectoryContentsRecursiveUnfold :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath FilePath +getDirectoryContentsRecursiveUnfold = Unfold step (\s -> return (s, Nothing, [""])) + where + {-# INLINE [0] step #-} + step (_, Nothing, []) = return D.Stop + + step (topdir, Just (cdir, dirstream, finalizer), dirs) = flip onException (runIOFinalizer finalizer) $ do + (dt, f) <- liftIO $ readDirEnt dirstream + if | FD.dtUnknown == dt -> do + runIOFinalizer finalizer + return $ D.Skip (topdir, Nothing, dirs) + | f == "." || f == ".." + -> return $ D.Skip (topdir, Just (cdir, dirstream, finalizer), dirs) + | FD.dtDir == dt -> return $ D.Skip (topdir, Just (cdir, dirstream, finalizer), (cdir f):dirs) + | otherwise -> return $ D.Yield (cdir f) (topdir, Just (cdir, dirstream, finalizer), dirs) + + step (topdir, Nothing, dir:dirs) = do + (s, f) <- acquire (topdir dir) + return $ D.Skip (topdir, Just (dir, s, f), dirs) + + acquire dir = + withRunInIO $ \run -> mask_ $ run $ do + dirstream <- liftIO $ openDirStream dir + ref <- newIOFinalizer (liftIO $ closeDirStream dirstream) + return (dirstream, ref) + +getDirectoryContentsRecursiveBFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m) + => FilePath + -> S.SerialT m FilePath +getDirectoryContentsRecursiveBFSUnsafe = S.unfold getDirectoryContentsRecursiveUnfold + + diff --git a/lib/GHCup/Utils/File/Posix/Foreign.hsc b/lib/GHCup/Utils/File/Posix/Foreign.hsc index 59cbe74..445b311 100644 --- a/lib/GHCup/Utils/File/Posix/Foreign.hsc +++ b/lib/GHCup/Utils/File/Posix/Foreign.hsc @@ -56,22 +56,3 @@ 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 #-} diff --git a/lib/GHCup/Utils/File/Posix/Traversals.hs b/lib/GHCup/Utils/File/Posix/Traversals.hs new file mode 100644 index 0000000..1c1a241 --- /dev/null +++ b/lib/GHCup/Utils/File/Posix/Traversals.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE CApiFFI #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wall #-} + + +module GHCup.Utils.File.Posix.Traversals ( +-- lower-level stuff + readDirEnt +, unpackDirStream +) where + + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>)) +#endif +import GHCup.Utils.File.Posix.Foreign + +import Unsafe.Coerce (unsafeCoerce) +import Foreign.C.Error +import Foreign.C.String +import Foreign.C.Types +import Foreign.Ptr +import Foreign.Storable +import System.Posix +import Foreign (alloca) +import System.Posix.Internals (peekFilePath) + + + + + +---------------------------------------------------------- +-- dodgy stuff + +type CDir = () +type CDirent = () + +-- Posix doesn't export DirStream, so to re-use that type we need to use +-- unsafeCoerce. It's just a newtype, so this is a legitimate usage. +-- ugly trick. +unpackDirStream :: DirStream -> Ptr CDir +unpackDirStream = unsafeCoerce + +-- the __hscore_* functions are defined in the unix package. We can import them and let +-- the linker figure it out. +foreign import ccall unsafe "__hscore_readdir" + c_readdir :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt + +foreign import ccall unsafe "__hscore_free_dirent" + c_freeDirEnt :: Ptr CDirent -> IO () + +foreign import ccall unsafe "__hscore_d_name" + c_name :: Ptr CDirent -> IO CString + +foreign import ccall unsafe "__posixdir_d_type" + c_type :: Ptr CDirent -> IO DirType + +---------------------------------------------------------- +-- less dodgy but still lower-level + + +readDirEnt :: DirStream -> IO (DirType, FilePath) +readDirEnt (unpackDirStream -> dirp) = + alloca $ \ptr_dEnt -> loop ptr_dEnt + where + loop ptr_dEnt = do + resetErrno + r <- c_readdir dirp ptr_dEnt + if r == 0 + then do + dEnt <- peek ptr_dEnt + if dEnt == nullPtr + then return (dtUnknown, mempty) + else do + dName <- c_name dEnt >>= peekFilePath + dType <- c_type dEnt + c_freeDirEnt dEnt + return (dType, dName) + else do + errno <- getErrno + if errno == eINTR + then loop ptr_dEnt + else do + let (Errno eo) = errno + if eo == 0 + then return (dtUnknown, mempty) + else throwErrno "readDirEnt" + diff --git a/lib/GHCup/Utils/File/Windows.hs b/lib/GHCup/Utils/File/Windows.hs index 0199193..fea543a 100644 --- a/lib/GHCup/Utils/File/Windows.hs +++ b/lib/GHCup/Utils/File/Windows.hs @@ -17,7 +17,7 @@ Some of these functions use sophisticated logging. module GHCup.Utils.File.Windows where import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink ) -import GHCup.Utils.Dirs hiding ( copyFile ) +import GHCup.Utils.Dirs import GHCup.Utils.File.Common import GHCup.Utils.Logger import GHCup.Types @@ -32,11 +32,14 @@ import Data.List import Foreign.C.Error import GHC.IO.Exception import GHC.IO.Handle +import qualified GHC.Unicode as U import System.Environment import System.FilePath import System.IO +import qualified System.IO.Error as IOE import System.Process +import qualified System.Win32.Info as WS import qualified System.Win32.File as WS import qualified Control.Exception as EX import qualified Data.ByteString as BS @@ -44,6 +47,15 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.Map.Strict as Map import qualified Data.Text as T +import qualified Streamly.Internal.Data.Stream.StreamD.Type + as D +import Streamly.Internal.Data.Unfold.Type hiding ( concatMap ) +import Data.Bits ((.&.)) +import qualified Streamly.Prelude as S +import qualified Streamly.Internal.Data.Unfold as U +import Streamly.Internal.Control.Concurrent ( withRunInIO ) +import Streamly.Internal.Data.IOFinalizer ( newIOFinalizer, runIOFinalizer ) + toProcessError :: FilePath @@ -165,8 +177,8 @@ execLogged :: ( MonadReader env m execLogged exe args chdir lfile env = do Dirs {..} <- getDirs logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args - let stdoutLogfile = logsDir lfile <> ".stdout.log" - stderrLogfile = logsDir lfile <> ".stderr.log" + let stdoutLogfile = fromGHCupPath logsDir lfile <> ".stdout.log" + stderrLogfile = fromGHCupPath logsDir lfile <> ".stderr.log" cp <- createProcessWithMingwPath ((proc exe args) { cwd = chdir , env = env @@ -200,7 +212,7 @@ execLogged exe args chdir lfile env = do -- subprocess stdout also goes to stderr for logging void $ BS.hPut stderr some go - + -- | Thin wrapper around `executeFile`. exec :: MonadIO m @@ -257,7 +269,7 @@ ghcupMsys2Dir = Just fp -> pure fp Nothing -> do baseDir <- liftIO ghcupBaseDir - pure (baseDir "msys64") + pure (fromGHCupPath baseDir "msys64") -- | Checks whether the binary is a broken link. isBrokenSymlink :: FilePath -> IO Bool @@ -286,3 +298,213 @@ install = copyFile removeEmptyDirectory :: FilePath -> IO () removeEmptyDirectory = WS.removeDirectory + + +unfoldDirContents :: (S.MonadAsync m, MonadIO m, MonadCatch m, MonadMask m) => Unfold m FilePath (WS.FileAttributeOrFlag, FilePath) +unfoldDirContents = U.bracket alloc dealloc (Unfold step return) + where + {-# INLINE [0] step #-} + step (_, False, _, _) = return D.Stop + step (topdir, True, h, fd) = flip onException (liftIO $ WS.findClose h) $ do + f <- liftIO $ WS.getFindDataFileName fd + more <- liftIO $ WS.findNextFile h fd + + -- can't get file attribute from FindData yet (needs Win32 PR) + fattr <- liftIO $ WS.getFileAttributes (topdir f) + + if | f == "." || f == ".." -> return $ D.Skip (topdir, more, h, fd) + | otherwise -> return $ D.Yield (fattr, f) (topdir, more, h, fd) + + alloc topdir = do + query <- liftIO $ furnishPath (topdir "*") + (h, fd) <- liftIO $ WS.findFirstFile query + pure (topdir, True, h, fd) + + dealloc (_, _, fd, _) = liftIO $ WS.findClose fd + + +getDirectoryContentsRecursiveDFSUnsafe :: (MonadCatch m, S.MonadAsync m, MonadMask m, S.IsStream t) + => FilePath + -> t m FilePath +getDirectoryContentsRecursiveDFSUnsafe fp = go "" + where + isDir attrs = attrs .&. WS.fILE_ATTRIBUTE_DIRECTORY /= 0 + + go cd = flip S.concatMap (S.unfold unfoldDirContents (fp cd)) $ \(t, f) -> + if | isDir t -> go (cd f) + | otherwise -> pure (cd f) + + +getDirectoryContentsRecursiveUnfold :: (MonadCatch m, S.MonadAsync m, MonadMask m) => Unfold m FilePath FilePath +getDirectoryContentsRecursiveUnfold = Unfold step init' + where + {-# INLINE [0] step #-} + step (_, Nothing, []) = return D.Stop + + step (topdir, state@(Just (cdir, (h, findData, ref))), dirs) = flip onException (runIOFinalizer ref) $ do + f <- liftIO $ WS.getFindDataFileName findData + + more <- liftIO $ WS.findNextFile h findData + when (not more) $ runIOFinalizer ref + let nextState = if more then state else Nothing + + -- can't get file attribute from FindData yet (needs Win32 PR) + fattr <- liftIO $ WS.getFileAttributes (topdir cdir f) + + if | f == "." || f == ".." -> return $ D.Skip (topdir, nextState, dirs) + | isDir fattr -> return $ D.Skip (topdir, nextState, (cdir f):dirs) + | otherwise -> return $ D.Yield (cdir f) (topdir, nextState, dirs) + + step (topdir, Nothing, dir:dirs) = do + (h, findData, ref) <- acquire (topdir dir) + return $ D.Skip (topdir, Just (dir, (h, findData, ref)), dirs) + + init' topdir = do + (h, findData, ref) <- acquire topdir + return (topdir, Just ("", (h, findData, ref)), []) + + isDir attrs = attrs .&. WS.fILE_ATTRIBUTE_DIRECTORY /= 0 + + acquire dir = do + query <- liftIO $ furnishPath (dir "*") + withRunInIO $ \run -> mask_ $ run $ do + (h, findData) <- liftIO $ WS.findFirstFile query + ref <- newIOFinalizer (liftIO $ WS.findClose h) + return (h, findData, ref) + + +getDirectoryContentsRecursiveBFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m) + => FilePath + -> S.SerialT m FilePath +getDirectoryContentsRecursiveBFSUnsafe = S.unfold getDirectoryContentsRecursiveUnfold + + + + -------------------------------------- + --[ Inlined from directory package ]-- + -------------------------------------- + + +furnishPath :: FilePath -> IO FilePath +furnishPath path = + (toExtendedLengthPath <$> rawPrependCurrentDirectory path) + `IOE.catchIOError` \ _ -> + pure path + + +toExtendedLengthPath :: FilePath -> FilePath +toExtendedLengthPath path + | isRelative path = simplifiedPath + | otherwise = + case simplifiedPath of + '\\' : '?' : '?' : '\\' : _ -> simplifiedPath + '\\' : '\\' : '?' : '\\' : _ -> simplifiedPath + '\\' : '\\' : '.' : '\\' : _ -> simplifiedPath + '\\' : subpath@('\\' : _) -> "\\\\?\\UNC" <> subpath + _ -> "\\\\?\\" <> simplifiedPath + where simplifiedPath = simplify path + + +simplify :: FilePath -> FilePath +simplify = simplifyWindows + +simplifyWindows :: FilePath -> FilePath +simplifyWindows "" = "" +simplifyWindows path = + case drive' of + "\\\\?\\" -> drive' <> subpath + _ -> simplifiedPath + where + simplifiedPath = joinDrive drive' subpath' + (drive, subpath) = splitDrive path + drive' = upperDrive (normaliseTrailingSep (normalisePathSeps drive)) + subpath' = appendSep . avoidEmpty . prependSep . joinPath . + stripPardirs . expandDots . skipSeps . + splitDirectories $ subpath + + upperDrive d = case d of + c : ':' : s | U.isAlpha c && all isPathSeparator s -> U.toUpper c : ':' : s + _ -> d + skipSeps = filter (not . (`elem` (pure <$> pathSeparators))) + stripPardirs | pathIsAbsolute || subpathIsAbsolute = dropWhile (== "..") + | otherwise = id + prependSep | subpathIsAbsolute = (pathSeparator :) + | otherwise = id + avoidEmpty | not pathIsAbsolute + && (null drive || hasTrailingPathSep) -- prefer "C:" over "C:." + = emptyToCurDir + | otherwise = id + appendSep p | hasTrailingPathSep + && not (pathIsAbsolute && null p) + = addTrailingPathSeparator p + | otherwise = p + pathIsAbsolute = not (isRelative path) + subpathIsAbsolute = any isPathSeparator (take 1 subpath) + hasTrailingPathSep = hasTrailingPathSeparator subpath + +emptyToCurDir :: FilePath -> FilePath +emptyToCurDir "" = "." +emptyToCurDir path = path + +normaliseTrailingSep :: FilePath -> FilePath +normaliseTrailingSep path = do + let path' = reverse path + let (sep, path'') = span isPathSeparator path' + let addSep = if null sep then id else (pathSeparator :) + reverse (addSep path'') + +normalisePathSeps :: FilePath -> FilePath +normalisePathSeps p = (\ c -> if isPathSeparator c then pathSeparator else c) <$> p + +expandDots :: [FilePath] -> [FilePath] +expandDots = reverse . go [] + where + go ys' xs' = + case xs' of + [] -> ys' + x : xs -> + case x of + "." -> go ys' xs + ".." -> + case ys' of + [] -> go (x : ys') xs + ".." : _ -> go (x : ys') xs + _ : ys -> go ys xs + _ -> go (x : ys') xs + +rawPrependCurrentDirectory :: FilePath -> IO FilePath +rawPrependCurrentDirectory path + | isRelative path = + ((`ioeAddLocation` "prependCurrentDirectory") . + (`IOE.ioeSetFileName` path)) `IOE.modifyIOError` do + getFullPathName path + | otherwise = pure path + +ioeAddLocation :: IOError -> String -> IOError +ioeAddLocation e loc = do + IOE.ioeSetLocation e newLoc + where + newLoc = loc <> if null oldLoc then "" else ":" <> oldLoc + oldLoc = IOE.ioeGetLocation e + +getFullPathName :: FilePath -> IO FilePath +getFullPathName path = + fromExtendedLengthPath <$> WS.getFullPathName (toExtendedLengthPath path) + +fromExtendedLengthPath :: FilePath -> FilePath +fromExtendedLengthPath ePath = + case ePath of + '\\' : '\\' : '?' : '\\' : path -> + case path of + 'U' : 'N' : 'C' : subpath@('\\' : _) -> "\\" <> subpath + drive : ':' : subpath + -- if the path is not "regular", then the prefix is necessary + -- to ensure the path is interpreted literally + | U.isAlpha drive && U.isAscii drive && isPathRegular subpath -> path + _ -> ePath + _ -> ePath + where + isPathRegular path = + not ('/' `elem` path || + "." `elem` splitDirectories path || + ".." `elem` splitDirectories path) diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Utils/Prelude.hs index b47e4f8..c2486a6 100644 --- a/lib/GHCup/Utils/Prelude.hs +++ b/lib/GHCup/Utils/Prelude.hs @@ -56,7 +56,6 @@ import Haskus.Utils.Types.List import Haskus.Utils.Variant.Excepts import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty ) import System.IO.Error -import System.IO.Unsafe import System.Directory hiding ( removeDirectory , removeDirectoryRecursive , removePathForcibly @@ -81,6 +80,7 @@ import qualified Data.Text.Lazy.Builder.Int as B import qualified Data.Text.Lazy.Encoding as TLE + -- $setup -- >>> import Data.ByteString.Internal (c2w, w2c) -- >>> import Test.QuickCheck @@ -400,45 +400,6 @@ createDirRecursive' p = _ -> throwIO e - --- | List all the files in a directory and all subdirectories. --- --- The order places files in sub-directories after all the files in their --- parent directories. The list is generated lazily so is not well defined if --- the source directory structure changes before the list is used. --- --- TODO: use streamly -getDirectoryContentsRecursive :: GHCupPath -> IO [FilePath] -getDirectoryContentsRecursive (fromGHCupPath -> topdir) = getDirectoryContentsRecursiveUnsafe topdir - - -getDirectoryContentsRecursiveUnsafe :: FilePath -> IO [FilePath] -getDirectoryContentsRecursiveUnsafe topdir = recurseDirectories [""] - where - recurseDirectories :: [FilePath] -> IO [FilePath] - recurseDirectories [] = return [] - recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do - (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir dir) - files' <- recurseDirectories (dirs' ++ dirs) - return (files ++ files') - - where - collect files dirs' [] = return (reverse files - ,reverse dirs') - collect files dirs' (entry:entries) | ignore entry - = collect files dirs' entries - collect files dirs' (entry:entries) = do - let dirEntry = dir entry - isDirectory <- doesDirectoryExist (topdir dirEntry) - if isDirectory - then collect files (dirEntry:dirs') entries - else collect (dirEntry:files) dirs' entries - - ignore ['.'] = True - ignore ['.', '.'] = True - ignore _ = False - - -- https://github.com/haskell/directory/issues/110 -- https://github.com/haskell/directory/issues/96 -- https://www.sqlite.org/src/info/89f1848d7f diff --git a/test/GHCup/Utils/FileSpec.hs b/test/GHCup/Utils/FileSpec.hs new file mode 100644 index 0000000..fb186d6 --- /dev/null +++ b/test/GHCup/Utils/FileSpec.hs @@ -0,0 +1,58 @@ +module GHCup.Utils.FileSpec where + +import GHCup.Utils.File + +import Data.List +import System.Directory +import System.FilePath +import System.IO.Unsafe +import qualified Streamly.Prelude as S + +import Test.Hspec + + + +spec :: Spec +spec = do + describe "GHCup.Utils.File" $ do + it "getDirectoryContentsRecursiveBFS" $ do + l1 <- sort <$> S.toList (getDirectoryContentsRecursiveBFSUnsafe ".") + l2 <- sort <$> getDirectoryContentsRecursiveLazy "." + not (null l1) `shouldBe` True + not (null l2) `shouldBe` True + l1 `shouldBe` l2 + it "getDirectoryContentsRecursiveDFS" $ do + l1 <- sort <$> S.toList (getDirectoryContentsRecursiveDFSUnsafe ".") + l2 <- sort <$> getDirectoryContentsRecursiveLazy "." + not (null l1) `shouldBe` True + not (null l2) `shouldBe` True + l1 `shouldBe` l2 + + +getDirectoryContentsRecursiveLazy :: FilePath -> IO [FilePath] +getDirectoryContentsRecursiveLazy topdir = recurseDirectories [""] + where + recurseDirectories :: [FilePath] -> IO [FilePath] + recurseDirectories [] = return [] + recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do + (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir dir) + files' <- recurseDirectories (dirs' ++ dirs) + return (files ++ files') + + where + collect files dirs' [] = return (reverse files + ,reverse dirs') + collect files dirs' (entry:entries) | ignore entry + = collect files dirs' entries + collect files dirs' (entry:entries) = do + let dirEntry = dir entry + isDirectory <- doesDirectoryExist (topdir dirEntry) + if isDirectory + then collect files (dirEntry:dirs') entries + else collect (dirEntry:files) dirs' entries + + ignore ['.'] = True + ignore ['.', '.'] = True + ignore _ = False + + diff --git a/test/Main.hs b/test/Main.hs index ef4a513..dda9536 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,10 +1,9 @@ import Test.Hspec.Runner -import Test.Hspec.Formatters import qualified Spec main :: IO () main = hspecWith - defaultConfig { configFormatter = Just progress } + defaultConfig Spec.spec From b9aba98cd504fc569659e7a32a8f42a418285cb1 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Mon, 16 May 2022 17:14:40 +0200 Subject: [PATCH 06/20] Fix recursive deletion in `ghcup nuke` --- .gitlab/script/ghcup_version.sh | 12 ++++++++++++ lib/GHCup.hs | 17 +++++------------ 2 files changed, 17 insertions(+), 12 deletions(-) diff --git a/.gitlab/script/ghcup_version.sh b/.gitlab/script/ghcup_version.sh index 137388f..5dc547a 100755 --- a/.gitlab/script/ghcup_version.sh +++ b/.gitlab/script/ghcup_version.sh @@ -289,7 +289,19 @@ fi eghcup upgrade eghcup upgrade -f +mkdir no_nuke/ +mkdir no_nuke/bar +echo 'foo' > no_nuke/file +echo 'bar' > no_nuke/bar/file +ln -s "$CI_PROJECT_DIR"/no_nuke/ "${GHCUP_DIR}"/cache/no_nuke +ln -s "$CI_PROJECT_DIR"/no_nuke/ "${GHCUP_DIR}"/logs/no_nuke # nuke eghcup nuke [ ! -e "${GHCUP_DIR}" ] + +# make sure nuke doesn't resolve symlinks +[ -e "$CI_PROJECT_DIR"/no_nuke/file ] +[ -e "$CI_PROJECT_DIR"/no_nuke/bar/file ] + + diff --git a/lib/GHCup.hs b/lib/GHCup.hs index dddf78f..359bce7 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -2017,6 +2017,7 @@ rmGhcupDirs = do , logsDir , cacheDir , recycleDir + , dbDir } <- getDirs let envFilePath = fromGHCupPath baseDir "env" @@ -2027,11 +2028,12 @@ rmGhcupDirs = do handleRm $ rmConfFile confFilePath -- for xdg dirs, the order matters here - handleRm $ rmDir logsDir - handleRm $ rmDir cacheDir + handleRm $ rmPathForcibly logsDir + handleRm $ rmPathForcibly cacheDir handleRm $ rmBinDir binDir - handleRm $ rmDir recycleDir + handleRm $ rmPathForcibly recycleDir + handleRm $ rmPathForcibly dbDir when isWindows $ do logInfo $ "removing " <> T.pack (fromGHCupPath baseDir "msys64") handleRm $ rmPathForcibly (baseDir `appendGHCupPath` "msys64") @@ -2057,15 +2059,6 @@ rmGhcupDirs = do logInfo "removing Ghcup Config File" hideErrorDef [permissionErrorType] () $ deleteFile' confFilePath - rmDir :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => GHCupPath -> m () - rmDir dir = - -- 'getDirectoryContentsRecursive' is lazy IO. In case - -- an error leaks through, we catch it here as well, - -- althought 'deleteFile' should already handle it. - hideErrorDef [doesNotExistErrorType] () $ do - logInfo $ "removing " <> T.pack (fromGHCupPath dir) - liftIO $ flip S.mapM_ (getDirectoryContentsRecursive dir) $ deleteFile' . (fromGHCupPath dir ) - rmBinDir :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m () rmBinDir binDir | isWindows = removeDirIfEmptyOrIsSymlink binDir From 3318c30cee112a1bd2cde63bb1ad74e4368c3205 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Mon, 16 May 2022 17:38:46 +0200 Subject: [PATCH 07/20] Fix stack.yaml --- stack.yaml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/stack.yaml b/stack.yaml index 6357d4f..ae66e8d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -57,6 +57,9 @@ flags: cabal-plan: exe: false + streamly: + use-unliftio: true + ghc-options: "$locals": -O2 streamly: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16 From e4b8c9748ad530f1c0a5c8926a2ae3fdbcffaf3f Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Mon, 16 May 2022 18:03:19 +0200 Subject: [PATCH 08/20] Fix oleg url --- .gitlab/script/ghcup_version.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitlab/script/ghcup_version.sh b/.gitlab/script/ghcup_version.sh index 5dc547a..1be748e 100755 --- a/.gitlab/script/ghcup_version.sh +++ b/.gitlab/script/ghcup_version.sh @@ -216,7 +216,7 @@ eghcup rm $(ghc --numeric-version) # https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/116 if [ "${OS}" = "LINUX" ] ; then if [ "${ARCH}" = "64" ] ; then - eghcup install cabal -u https://oleg.fi/cabal-install-3.4.0.0-rc4/cabal-install-3.4.0.0-x86_64-ubuntu-16.04.tar.xz 3.4.0.0-rc4 + eghcup install cabal -u https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal/3.7.0.0-pre20220407/cabal-install-3.7-x86_64-linux-alpine.tar.xz 3.4.0.0-rc4 eghcup rm cabal 3.4.0.0-rc4 fi fi From 65f02a5a7a0390b1b1deb8cd09194d218b5c8fd8 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Mon, 16 May 2022 23:04:49 +0200 Subject: [PATCH 09/20] Fix test --- test/GHCup/Utils/FileSpec.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/test/GHCup/Utils/FileSpec.hs b/test/GHCup/Utils/FileSpec.hs index fb186d6..8bcc53c 100644 --- a/test/GHCup/Utils/FileSpec.hs +++ b/test/GHCup/Utils/FileSpec.hs @@ -16,14 +16,14 @@ spec :: Spec spec = do describe "GHCup.Utils.File" $ do it "getDirectoryContentsRecursiveBFS" $ do - l1 <- sort <$> S.toList (getDirectoryContentsRecursiveBFSUnsafe ".") - l2 <- sort <$> getDirectoryContentsRecursiveLazy "." + l1 <- sort <$> S.toList (getDirectoryContentsRecursiveBFSUnsafe "lib") + l2 <- sort <$> getDirectoryContentsRecursiveLazy "lib" not (null l1) `shouldBe` True not (null l2) `shouldBe` True l1 `shouldBe` l2 it "getDirectoryContentsRecursiveDFS" $ do - l1 <- sort <$> S.toList (getDirectoryContentsRecursiveDFSUnsafe ".") - l2 <- sort <$> getDirectoryContentsRecursiveLazy "." + l1 <- sort <$> S.toList (getDirectoryContentsRecursiveDFSUnsafe "lib") + l2 <- sort <$> getDirectoryContentsRecursiveLazy "lib" not (null l1) `shouldBe` True not (null l2) `shouldBe` True l1 `shouldBe` l2 From ca89112a8e1f8b6b05485211859588b2d4a1f494 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Tue, 17 May 2022 01:55:56 +0200 Subject: [PATCH 10/20] Fix for darwin M1 --- lib/GHCup/Utils/File/Posix.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/GHCup/Utils/File/Posix.hs b/lib/GHCup/Utils/File/Posix.hs index 22cc00f..51b1cb1 100644 --- a/lib/GHCup/Utils/File/Posix.hs +++ b/lib/GHCup/Utils/File/Posix.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE CApiFFI #-} {-| Module : GHCup.Utils.File.Posix @@ -450,7 +451,7 @@ copyFile from to fail' = do streamlyCopy (fH, tH) = S.fold (FH.writeChunks tH) $ IFH.toChunksWithBufferOf (256 * 1024) fH -foreign import ccall unsafe "open" +foreign import capi unsafe "fcntl.h open" c_open :: CString -> CInt -> Posix.CMode -> IO CInt From 1cffa358b860eb2e9141ec8e81dcf1e782719591 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 19 May 2022 21:01:48 +0200 Subject: [PATCH 11/20] Fix M1 CI --- .gitlab-ci.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 6b43bbf..9e089cc 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -206,7 +206,7 @@ variables: # otherwise we seem to get intel binaries - export HOMEBREW_CHANGE_ARCH_TO_ARM=1 # update and install packages - - /bin/bash ./.gitlab/script/brew.sh llvm autoconf automake + - /bin/bash ./.gitlab/script/brew.sh llvm autoconf automake coreutils # extract cabal cache - ./.gitlab/script/ci.sh extract_cabal_cache script: | @@ -574,7 +574,7 @@ release:darwin:aarch64: # otherwise we seem to get intel binaries - export HOMEBREW_CHANGE_ARCH_TO_ARM=1 # update and install packages - - /bin/bash ./.gitlab/script/brew.sh llvm autoconf automake + - /bin/bash ./.gitlab/script/brew.sh llvm autoconf automake coreutils script: | export PATH="$CI_PROJECT_DIR/.brew/opt/llvm/bin:$CI_PROJECT_DIR/.brew/bin:$CI_PROJECT_DIR/.brew/sbin:$PATH" export CC=$CI_PROJECT_DIR/.brew/opt/llvm/bin/clang From 430b6557852a6e9d07904e3dae7547e398c9d5cc Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 19 May 2022 23:17:58 +0200 Subject: [PATCH 12/20] Improve error handling for mergeFileTree --- app/ghcup/BrickMain.hs | 1 + app/ghcup/GHCup/OptParse/Compile.hs | 2 + app/ghcup/GHCup/OptParse/Install.hs | 6 ++ app/ghcup/GHCup/OptParse/Run.hs | 2 + lib/GHCup.hs | 53 ++++-------- lib/GHCup/Errors.hs | 9 +++ lib/GHCup/Types.hs | 14 ++++ lib/GHCup/Utils/File.hs | 121 +++++++++++++++++++++++----- 8 files changed, 149 insertions(+), 59 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index e401ee3..aae119f 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -438,6 +438,7 @@ install' _ (_, ListResult {..}) = do , ProcessError , GHCupShadowed , UninstallFailed + , MergeFileTreeError ] run (do diff --git a/app/ghcup/GHCup/OptParse/Compile.hs b/app/ghcup/GHCup/OptParse/Compile.hs index 6499b38..f578c46 100644 --- a/app/ghcup/GHCup/OptParse/Compile.hs +++ b/app/ghcup/GHCup/OptParse/Compile.hs @@ -389,6 +389,7 @@ type GHCEffects = '[ AlreadyInstalled , CopyError , BuildFailed , UninstallFailed + , MergeFileTreeError ] type HLSEffects = '[ AlreadyInstalled , BuildFailed @@ -408,6 +409,7 @@ type HLSEffects = '[ AlreadyInstalled , DirNotEmpty , ArchiveResult , UninstallFailed + , MergeFileTreeError ] diff --git a/app/ghcup/GHCup/OptParse/Install.hs b/app/ghcup/GHCup/OptParse/Install.hs index f2320a6..905ae64 100644 --- a/app/ghcup/GHCup/OptParse/Install.hs +++ b/app/ghcup/GHCup/OptParse/Install.hs @@ -259,6 +259,7 @@ type InstallEffects = '[ AlreadyInstalled , FileAlreadyExistsError , ProcessError , UninstallFailed + , MergeFileTreeError , (AlreadyInstalled, ()) , (UnknownArchive, ()) @@ -267,6 +268,7 @@ type InstallEffects = '[ AlreadyInstalled , (CopyError, ()) , (NotInstalled, ()) , (UninstallFailed, ()) + , (MergeFileTreeError, ()) , (DirNotEmpty, ()) , (NoDownload, ()) , (BuildFailed, ()) @@ -290,6 +292,7 @@ type InstallEffects = '[ AlreadyInstalled , (NoDownload, NotInstalled) , (NotInstalled, NotInstalled) , (UninstallFailed, NotInstalled) + , (MergeFileTreeError, NotInstalled) , (BuildFailed, NotInstalled) , (TagNotFound, NotInstalled) , (DigestError, NotInstalled) @@ -323,6 +326,7 @@ type InstallGHCEffects = '[ TagNotFound , DirNotEmpty , AlreadyInstalled , UninstallFailed + , MergeFileTreeError , (AlreadyInstalled, NotInstalled) , (UnknownArchive, NotInstalled) @@ -333,6 +337,7 @@ type InstallGHCEffects = '[ TagNotFound , (DirNotEmpty, NotInstalled) , (NoDownload, NotInstalled) , (UninstallFailed, NotInstalled) + , (MergeFileTreeError, NotInstalled) , (BuildFailed, NotInstalled) , (TagNotFound, NotInstalled) , (DigestError, NotInstalled) @@ -353,6 +358,7 @@ type InstallGHCEffects = '[ TagNotFound , (DirNotEmpty, ()) , (NoDownload, ()) , (UninstallFailed, ()) + , (MergeFileTreeError, ()) , (BuildFailed, ()) , (TagNotFound, ()) , (DigestError, ()) diff --git a/app/ghcup/GHCup/OptParse/Run.hs b/app/ghcup/GHCup/OptParse/Run.hs index 45cfce6..c5bc1ac 100644 --- a/app/ghcup/GHCup/OptParse/Run.hs +++ b/app/ghcup/GHCup/OptParse/Run.hs @@ -176,6 +176,7 @@ type RunEffects = '[ AlreadyInstalled , FileAlreadyExistsError , ProcessError , UninstallFailed + , MergeFileTreeError ] runLeanRUN :: (MonadUnliftIO m, MonadIO m) @@ -340,6 +341,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do , FileAlreadyExistsError , CopyError , UninstallFailed + , MergeFileTreeError ] (ResourceT (ReaderT AppState m)) () installToolChainFull Toolchain{..} tmp = do forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 359bce7..36fdee5 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -199,6 +199,7 @@ installGHCBindist :: ( MonadFail m , ArchiveResult , ProcessError , UninstallFailed + , MergeFileTreeError ] m () @@ -280,6 +281,7 @@ installPackedGHC :: ( MonadMask m , DirNotEmpty , ArchiveResult , ProcessError + , MergeFileTreeError ] m () installPackedGHC dl msubdir inst ver forceInstall = do PlatformRequest {..} <- lift getPlatformReq @@ -319,14 +321,14 @@ installUnpackedGHC :: ( MonadReader env m -> InstallDirResolved -- ^ Path to install to -> Version -- ^ The GHC version -> Bool -- ^ Force install - -> Excepts '[ProcessError] m () + -> Excepts '[ProcessError, MergeFileTreeError] m () installUnpackedGHC path inst ver forceInstall | isWindows = do lift $ logInfo "Installing GHC (this may take a while)" -- Windows bindists are relocatable and don't need -- to run configure. -- We also must make sure to preserve mtime to not confuse ghc-pkg. - lift $ mergeFileTree path inst GHC (mkTVer ver) $ \source dest -> liftIO $ do + liftE $ mergeFileTree path inst GHC (mkTVer ver) $ \source dest -> liftIO $ do mtime <- getModificationTime source moveFilePortable source dest setModificationTime dest mtime @@ -349,9 +351,8 @@ installUnpackedGHC path inst ver forceInstall Nothing tmpInstallDest <- lift withGHCupTmpDir lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "install"] (Just $ fromGHCupPath path) - lift $ logInfo $ "Merging file tree from \"" <> T.pack (fromGHCupPath tmpInstallDest) <> "\" to \"" <> T.pack (fromInstallDir inst) <> "\"" liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpInstallDest) - lift $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst)) + liftE $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst)) inst GHC (mkTVer ver) @@ -394,6 +395,7 @@ installGHCBin :: ( MonadFail m , ArchiveResult , ProcessError , UninstallFailed + , MergeFileTreeError ] m () @@ -576,6 +578,7 @@ installHLSBindist :: ( MonadMask m , ProcessError , DirNotEmpty , UninstallFailed + , MergeFileTreeError ] m () @@ -658,14 +661,14 @@ installHLSUnpacked :: ( MonadMask m -> InstallDirResolved -- ^ Path to install to -> Version -> Bool - -> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled] m () + -> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled, MergeFileTreeError] m () installHLSUnpacked path inst ver forceInstall = do PlatformRequest { .. } <- lift getPlatformReq lift $ logInfo "Installing HLS" tmpInstallDest <- lift withGHCupTmpDir lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "PREFIX=" <> fromInstallDir inst, "install"] (Just path) liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpInstallDest) - lift $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst)) + liftE $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst)) inst HLS (mkTVer ver) @@ -759,6 +762,7 @@ installHLSBin :: ( MonadMask m , ProcessError , DirNotEmpty , UninstallFailed + , MergeFileTreeError ] m () @@ -1798,7 +1802,7 @@ rmGHCVer ver = do Just files -> do lift $ logInfo $ "Removing files safely from: " <> T.pack dir forM_ files (lift . recycleFile . (\f -> dir dropDrive f)) - removeEmptyDirsRecursive dir + removeEmptyDirsRecursive (liftIO . removeEmptyDirectory) dir survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory dir f <- recordedInstallationFile GHC ver lift $ recycleFile f @@ -1882,7 +1886,7 @@ rmHLSVer ver = do Just files -> do lift $ logInfo $ "Removing files safely from: " <> T.pack hlsDir forM_ files (lift . recycleFile . (\f -> hlsDir dropDrive f)) - removeEmptyDirsRecursive hlsDir + removeEmptyDirsRecursive (liftIO . removeEmptyDirectory) hlsDir survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory hlsDir f <- recordedInstallationFile HLS (mkTVer ver) lift $ recycleFile f @@ -2038,7 +2042,7 @@ rmGhcupDirs = do logInfo $ "removing " <> T.pack (fromGHCupPath baseDir "msys64") handleRm $ rmPathForcibly (baseDir `appendGHCupPath` "msys64") - handleRm $ removeEmptyDirsRecursive (fromGHCupPath baseDir) + handleRm $ removeEmptyDirsRecursive removeDirIfEmptyOrIsSymlink (fromGHCupPath baseDir) -- report files in baseDir that are left-over after -- the standard location deletions above @@ -2052,12 +2056,12 @@ rmGhcupDirs = do rmEnvFile :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m () rmEnvFile enFilePath = do logInfo "Removing Ghcup Environment File" - hideErrorDef [permissionErrorType] () $ deleteFile' enFilePath + hideErrorDef [permissionErrorType] () $ rmFileForce enFilePath rmConfFile :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m () rmConfFile confFilePath = do logInfo "removing Ghcup Config File" - hideErrorDef [permissionErrorType] () $ deleteFile' confFilePath + hideErrorDef [permissionErrorType] () $ rmFileForce confFilePath rmBinDir :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m () rmBinDir binDir @@ -2084,33 +2088,7 @@ rmGhcupDirs = do compareFn :: FilePath -> FilePath -> Ordering compareFn fp1 fp2 = compare (calcDepth fp1) (calcDepth fp2) --- we expect only files inside cache/log dir --- we report remaining files/dirs later, --- hence the force/quiet mode in these delete functions below. -deleteFile' :: (MonadMask m, MonadIO m) => FilePath -> m () -deleteFile' filepath = do - hideError doesNotExistErrorType - $ hideError InappropriateType $ rmFile filepath - -removeDirIfEmptyOrIsSymlink :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m () -removeDirIfEmptyOrIsSymlink filepath = - hideError UnsatisfiedConstraints $ - handleIO' InappropriateType - (handleIfSym filepath) - (liftIO $ removeEmptyDirectory 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 ------------------ @@ -2195,6 +2173,7 @@ compileGHC :: ( MonadMask m , CopyError , BuildFailed , UninstallFailed + , MergeFileTreeError ] m GHCTargetVersion diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index 33c8332..6dd405f 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -105,6 +105,15 @@ instance Pretty CopyError where pPrint (CopyError reason) = text ("Unable to copy a file. Reason was: " ++ reason) +-- | Unable to merge file trees. +data MergeFileTreeError = MergeFileTreeError IOException FilePath FilePath + deriving Show + +instance Pretty MergeFileTreeError where + pPrint (MergeFileTreeError e from to) = + text "Failed to merge file tree from" <+> text from <+> text "to" <+> text to <+> text "\nexception was:" <+> text (displayException e) + <+> text "\n...tried to clean up" <+> text to <+> text ". Make sure it's gone." + -- | Unable to find a tag of a tool. data TagNotFound = TagNotFound Tag Tool deriving Show diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 609834f..7b22698 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -647,3 +647,17 @@ fromInstallDir :: InstallDirResolved -> FilePath fromInstallDir (IsolateDirResolved fp) = fp fromInstallDir (GHCupDir fp) = fromGHCupPath fp fromInstallDir (GHCupBinDir fp) = fp + + +isSafeDir :: InstallDirResolved -> Bool +isSafeDir (IsolateDirResolved _) = False +isSafeDir (GHCupDir _) = True +isSafeDir (GHCupBinDir _) = False + + + + + + + + diff --git a/lib/GHCup/Utils/File.hs b/lib/GHCup/Utils/File.hs index 649163f..4aeec14 100644 --- a/lib/GHCup/Utils/File.hs +++ b/lib/GHCup/Utils/File.hs @@ -1,8 +1,10 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -29,6 +31,9 @@ module GHCup.Utils.File ( deleteFile, install, removeEmptyDirectory, + removeDirIfEmptyOrIsSymlink, + removeEmptyDirsRecursive, + rmFileForce ) where import GHCup.Utils.Dirs @@ -52,40 +57,87 @@ import Text.PrettyPrint.HughesPJClass (prettyShow) import qualified Data.Text as T import qualified Streamly.Prelude as S +import Control.DeepSeq (force) +import Control.Exception (evaluate) +import GHC.IO.Exception +import System.IO.Error +import GHCup.Utils.Logger -mergeFileTree :: (MonadMask m, S.MonadAsync m, MonadReader env m, HasDirs env) +-- | Merge one file tree to another given a copy operation. +-- +-- Records every successfully installed file into the destination +-- returned by 'recordedInstallationFile'. +-- +-- If any copy operation fails, the record file is deleted, as well +-- as the partially installed files. +mergeFileTree :: ( MonadMask m + , S.MonadAsync m + , MonadReader env m + , HasDirs env + , HasLog env + , MonadCatch m + ) => GHCupPath -- ^ source base directory from which to install findFiles -> InstallDirResolved -- ^ destination base dir -> Tool -> GHCTargetVersion -> (FilePath -> FilePath -> m ()) -- ^ file copy operation - -> m () + -> Excepts '[MergeFileTreeError] m () +mergeFileTree _ (GHCupBinDir fp) _ _ _ = + throwIO $ userError ("mergeFileTree: internal error, called on " <> fp) mergeFileTree sourceBase destBase tool v' 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 (fromGHCupPath sourceBase) - liftIO $ destCheck (fromInstallDir destBase) - + lift $ logInfo $ "Merging file tree from \"" + <> T.pack (fromGHCupPath sourceBase) + <> "\" to \"" + <> T.pack (fromInstallDir destBase) + <> "\"" recFile <- recordedInstallationFile tool v' - case destBase of - IsolateDirResolved _ -> pure () - _ -> do - whenM (liftIO $ doesFileExist recFile) $ throwIO $ userError ("mergeFileTree: DB file " <> recFile <> " already exists!") + + wrapInExcepts $ 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 (fromGHCupPath sourceBase) + liftIO $ destCheck (fromInstallDir destBase) + + -- we only record for non-isolated installs + when (isSafeDir destBase) $ do + whenM (liftIO $ doesFileExist recFile) + $ throwIO $ userError ("mergeFileTree: DB file " <> recFile <> " already exists!") liftIO $ createDirectoryIfMissing True (takeDirectory recFile) - flip S.mapM_ (getDirectoryContentsRecursive sourceBase) $ \f -> do - copy f - recordInstalledFile f recFile - pure f + -- we want the cleanup action to leak through in case of exception + onE_ (cleanupOnPartialInstall recFile) $ wrapInExcepts $ do + logDebug "Starting merge" + lift $ flip S.mapM_ (getDirectoryContentsRecursive sourceBase) $ \f -> do + copy f + logDebug $ T.pack "Recording installed file: " <> T.pack f + recordInstalledFile f recFile + pure f where - recordInstalledFile f recFile = do - case destBase of - IsolateDirResolved _ -> pure () - _ -> liftIO $ appendFile recFile (f <> "\n") + wrapInExcepts = handleIO (\e -> throwE $ MergeFileTreeError e (fromGHCupPath sourceBase) (fromInstallDir destBase)) + + cleanupOnPartialInstall recFile = when (isSafeDir destBase) $ do + (force -> !l) <- hideErrorDef [NoSuchThing] [] $ lines <$> liftIO + (readFile recFile >>= evaluate) + logDebug "Deleting recorded files due to partial install" + forM_ l $ \f -> do + let dest = fromInstallDir destBase dropDrive f + logDebug $ "rm -f " <> T.pack f + hideError NoSuchThing $ rmFile dest + pure () + logDebug $ "rm -f " <> T.pack recFile + hideError NoSuchThing $ rmFile recFile + logDebug $ "rm -f " <> T.pack (fromInstallDir destBase) + hideError UnsatisfiedConstraints $ hideError NoSuchThing $ + removeEmptyDirsRecursive (hideError UnsatisfiedConstraints . liftIO . removeEmptyDirectory) (fromInstallDir destBase) + + + recordInstalledFile f recFile = when (isSafeDir destBase) $ + liftIO $ appendFile recFile (f <> "\n") copy source = do let dest = fromInstallDir destBase source @@ -158,3 +210,28 @@ recordedInstallationFile t v' = do Dirs {..} <- getDirs pure (fromGHCupPath dbDir prettyShow t T.unpack (tVerToText v')) +removeDirIfEmptyOrIsSymlink :: (MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m () +removeDirIfEmptyOrIsSymlink filepath = + hideError UnsatisfiedConstraints $ + handleIO' InappropriateType + (handleIfSym filepath) + (liftIO $ removeEmptyDirectory filepath) + where + handleIfSym fp e = do + isSym <- liftIO $ pathIsSymbolicLink fp + if isSym + then rmFileForce fp + else liftIO $ ioError e + +removeEmptyDirsRecursive :: (MonadMask m, MonadIO m, MonadCatch m) => (FilePath -> m ()) -> FilePath -> m () +removeEmptyDirsRecursive rmOpt = go + where + go fp = do + cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp ) + forM_ cs go + hideError InappropriateType $ rmOpt fp + +rmFileForce :: (MonadMask m, MonadIO m) => FilePath -> m () +rmFileForce filepath = do + hideError doesNotExistErrorType + $ hideError InappropriateType $ rmFile filepath From d5efc86d85ee6b3338c64423ccff6751b1cd5dde Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 20 May 2022 00:15:35 +0200 Subject: [PATCH 13/20] Preserve mtime when merging filetrees --- ghcup.cabal | 1 + lib/GHCup.hs | 15 +++++++++++---- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/ghcup.cabal b/ghcup.cabal index 1b8ae3e..8484a50 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -109,6 +109,7 @@ library , deepseq ^>=1.4.4.0 , directory ^>=1.3.6.0 , disk-free-space ^>=0.1.0.1 + , exceptions ^>=0.10 , filepath ^>=1.4.2.1 , haskus-utils-types ^>=1.5 , haskus-utils-variant ^>=3.2.1 diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 36fdee5..05b23e1 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -329,9 +329,9 @@ installUnpackedGHC path inst ver forceInstall -- to run configure. -- We also must make sure to preserve mtime to not confuse ghc-pkg. liftE $ mergeFileTree path inst GHC (mkTVer ver) $ \source dest -> liftIO $ do - mtime <- getModificationTime source + mtime <- ifM (pathIsSymbolicLink source) (pure Nothing) (Just <$> getModificationTime source) moveFilePortable source dest - setModificationTime dest mtime + forM_ mtime $ setModificationTime dest | otherwise = do PlatformRequest {..} <- lift getPlatformReq @@ -356,7 +356,11 @@ installUnpackedGHC path inst ver forceInstall inst GHC (mkTVer ver) - (\f t -> liftIO $ install f t (not forceInstall)) + (\f t -> liftIO $ do + mtime <- ifM (pathIsSymbolicLink f) (pure Nothing) (Just <$> getModificationTime f) + install f t (not forceInstall) + forM_ mtime $ setModificationTime t) + pure () @@ -672,7 +676,10 @@ installHLSUnpacked path inst ver forceInstall = do inst HLS (mkTVer ver) - (\f t -> liftIO $ install f t (not forceInstall)) + (\f t -> liftIO $ do + mtime <- ifM (pathIsSymbolicLink f) (pure Nothing) (Just <$> getModificationTime f) + install f t (not forceInstall) + forM_ mtime $ setModificationTime t) -- | Install an unpacked hls distribution (legacy). installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m) From c9e1261af2cca49f81c01fa4fe4a31d38b2e86e1 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 20 May 2022 00:46:50 +0200 Subject: [PATCH 14/20] Some fixes --- .gitlab/script/ghcup_version.sh | 1 + lib/GHCup.hs | 6 +++--- lib/GHCup/Utils/File.hs | 8 ++++---- 3 files changed, 8 insertions(+), 7 deletions(-) diff --git a/.gitlab/script/ghcup_version.sh b/.gitlab/script/ghcup_version.sh index 1be748e..6cabc69 100755 --- a/.gitlab/script/ghcup_version.sh +++ b/.gitlab/script/ghcup_version.sh @@ -289,6 +289,7 @@ fi eghcup upgrade eghcup upgrade -f +# test that doing fishy symlinks into GHCup dir doesn't cause weird stuff on 'ghcup nuke' mkdir no_nuke/ mkdir no_nuke/bar echo 'foo' > no_nuke/file diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 05b23e1..505ea2b 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -1809,7 +1809,7 @@ rmGHCVer ver = do Just files -> do lift $ logInfo $ "Removing files safely from: " <> T.pack dir forM_ files (lift . recycleFile . (\f -> dir dropDrive f)) - removeEmptyDirsRecursive (liftIO . removeEmptyDirectory) dir + removeEmptyDirsRecursive dir survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory dir f <- recordedInstallationFile GHC ver lift $ recycleFile f @@ -1893,7 +1893,7 @@ rmHLSVer ver = do Just files -> do lift $ logInfo $ "Removing files safely from: " <> T.pack hlsDir forM_ files (lift . recycleFile . (\f -> hlsDir dropDrive f)) - removeEmptyDirsRecursive (liftIO . removeEmptyDirectory) hlsDir + removeEmptyDirsRecursive hlsDir survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory hlsDir f <- recordedInstallationFile HLS (mkTVer ver) lift $ recycleFile f @@ -2049,7 +2049,7 @@ rmGhcupDirs = do logInfo $ "removing " <> T.pack (fromGHCupPath baseDir "msys64") handleRm $ rmPathForcibly (baseDir `appendGHCupPath` "msys64") - handleRm $ removeEmptyDirsRecursive removeDirIfEmptyOrIsSymlink (fromGHCupPath baseDir) + handleRm $ removeEmptyDirsRecursive (fromGHCupPath baseDir) -- report files in baseDir that are left-over after -- the standard location deletions above diff --git a/lib/GHCup/Utils/File.hs b/lib/GHCup/Utils/File.hs index 4aeec14..2bc8a04 100644 --- a/lib/GHCup/Utils/File.hs +++ b/lib/GHCup/Utils/File.hs @@ -133,7 +133,7 @@ mergeFileTree sourceBase destBase tool v' copyOp = do hideError NoSuchThing $ rmFile recFile logDebug $ "rm -f " <> T.pack (fromInstallDir destBase) hideError UnsatisfiedConstraints $ hideError NoSuchThing $ - removeEmptyDirsRecursive (hideError UnsatisfiedConstraints . liftIO . removeEmptyDirectory) (fromInstallDir destBase) + removeEmptyDirsRecursive (fromInstallDir destBase) recordInstalledFile f recFile = when (isSafeDir destBase) $ @@ -223,13 +223,13 @@ removeDirIfEmptyOrIsSymlink filepath = then rmFileForce fp else liftIO $ ioError e -removeEmptyDirsRecursive :: (MonadMask m, MonadIO m, MonadCatch m) => (FilePath -> m ()) -> FilePath -> m () -removeEmptyDirsRecursive rmOpt = go +removeEmptyDirsRecursive :: (MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m () +removeEmptyDirsRecursive = go where go fp = do cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp ) forM_ cs go - hideError InappropriateType $ rmOpt fp + liftIO $ removeEmptyDirectory fp rmFileForce :: (MonadMask m, MonadIO m) => FilePath -> m () rmFileForce filepath = do From df89ddcdf59dbbdbcc91ebb02d955c00e7bff97c Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 20 May 2022 23:19:33 +0200 Subject: [PATCH 15/20] Use internal tmpdir --- app/ghcup/GHCup/OptParse/GC.hs | 14 ++-- app/ghcup/GHCup/OptParse/Prefetch.hs | 2 +- app/ghcup/Main.hs | 1 - docs/guide.md | 1 - lib/GHCup.hs | 2 + lib/GHCup/Types.hs | 13 ++-- lib/GHCup/Utils.hs | 4 +- lib/GHCup/Utils/Dirs.hs | 62 +++++++++------- lib/GHCup/Utils/File.hs | 105 ++++++++++++++++++++++++++- lib/GHCup/Utils/File.hs-boot | 14 ++++ lib/GHCup/Utils/File/Posix.hs | 25 ++++++- lib/GHCup/Utils/File/Windows.hs | 12 ++- lib/GHCup/Utils/Logger.hs | 1 + lib/GHCup/Utils/Prelude.hs | 103 -------------------------- lib/GHCup/Utils/Prelude/Posix.hs | 16 ---- lib/GHCup/Utils/Prelude/Windows.hs | 11 --- 16 files changed, 210 insertions(+), 176 deletions(-) create mode 100644 lib/GHCup/Utils/File.hs-boot diff --git a/app/ghcup/GHCup/OptParse/GC.hs b/app/ghcup/GHCup/OptParse/GC.hs index b3a28f7..e51edbc 100644 --- a/app/ghcup/GHCup/OptParse/GC.hs +++ b/app/ghcup/GHCup/OptParse/GC.hs @@ -56,26 +56,26 @@ data GCOptions = GCOptions --[ Parsers ]-- --------------- - + gcP :: Parser GCOptions gcP = GCOptions - <$> + <$> switch (short 'o' <> long "ghc-old" <> help "Remove GHC versions marked as 'old'") - <*> + <*> switch (short 'p' <> long "profiling-libs" <> help "Remove profiling libs of GHC versions") - <*> + <*> switch (short 's' <> long "share-dir" <> help "Remove GHC share directories (documentation)") - <*> + <*> switch (short 'h' <> long "hls-no-ghc" <> help "Remove HLS versions that don't have a corresponding installed GHC version") - <*> + <*> switch (short 'c' <> long "cache" <> help "GC the GHCup cache") - <*> + <*> switch (short 't' <> long "tmpdirs" <> help "Remove tmpdir leftovers") diff --git a/app/ghcup/GHCup/OptParse/Prefetch.hs b/app/ghcup/GHCup/OptParse/Prefetch.hs index 87f6bdb..7d43c10 100644 --- a/app/ghcup/GHCup/OptParse/Prefetch.hs +++ b/app/ghcup/GHCup/OptParse/Prefetch.hs @@ -14,6 +14,7 @@ module GHCup.OptParse.Prefetch where import GHCup import GHCup.Errors import GHCup.Types +import GHCup.Utils.File import GHCup.Utils.Logger import GHCup.OptParse.Common import GHCup.Utils.String.QQ @@ -33,7 +34,6 @@ import Text.PrettyPrint.HughesPJClass ( prettyShow ) import qualified Data.Text as T import Control.Exception.Safe (MonadMask) -import GHCup.Utils.Prelude import GHCup.Download (getDownloadsF) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 96eabe8..df636d7 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -155,7 +155,6 @@ main = do versions. It maintains a self-contained ~/.ghcup directory. ENV variables: - * TMPDIR: where ghcup does the work (unpacking, building, ...) * GHCUP_INSTALL_BASE_PREFIX: the base of ghcup (default: $HOME) * GHCUP_USE_XDG_DIRS: set to anything to use XDG style directories diff --git a/docs/guide.md b/docs/guide.md index d90a5f9..a273c07 100644 --- a/docs/guide.md +++ b/docs/guide.md @@ -76,7 +76,6 @@ Partial configuration is fine. Command line options always override the config f This is the complete list of env variables that change GHCup behavior: * `GHCUP_USE_XDG_DIRS`: see [XDG support](#xdg-support) above -* `TMPDIR`: where ghcup does the work (unpacking, building, ...) * `GHCUP_INSTALL_BASE_PREFIX`: the base of ghcup (default: `$HOME`) * `GHCUP_CURL_OPTS`: additional options that can be passed to curl * `GHCUP_WGET_OPTS`: additional options that can be passed to wget diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 505ea2b..3e4e0c3 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -2029,6 +2029,7 @@ rmGhcupDirs = do , cacheDir , recycleDir , dbDir + , tmpDir } <- getDirs let envFilePath = fromGHCupPath baseDir "env" @@ -2040,6 +2041,7 @@ rmGhcupDirs = do -- for xdg dirs, the order matters here handleRm $ rmPathForcibly logsDir + handleRm $ rmPathForcibly tmpDir handleRm $ rmPathForcibly cacheDir handleRm $ rmBinDir binDir diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 7b22698..3918de7 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -441,13 +441,14 @@ defaultSettings = Settings False defaultMetaCache False Never Curl False GHCupUR instance NFData Settings data Dirs = Dirs - { baseDir :: GHCupPath - , binDir :: FilePath - , cacheDir :: GHCupPath - , logsDir :: GHCupPath - , confDir :: GHCupPath - , dbDir :: GHCupPath + { baseDir :: GHCupPath + , binDir :: FilePath + , cacheDir :: GHCupPath + , logsDir :: GHCupPath + , confDir :: GHCupPath + , dbDir :: GHCupPath , recycleDir :: GHCupPath -- mainly used on windows + , tmpDir :: GHCupPath } deriving (Show, GHC.Generic) diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index e227885..6a161a2 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -1255,15 +1255,17 @@ ensureGlobalTools -- | Ensure ghcup directory structure exists. ensureDirectories :: Dirs -> IO () -ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir dbDir) = do +ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir dbDir tmpDir) = do createDirRecursive' (fromGHCupPath baseDir) createDirRecursive' (fromGHCupPath baseDir "ghc") + createDirRecursive' (fromGHCupPath baseDir "hls") createDirRecursive' binDir createDirRecursive' (fromGHCupPath cacheDir) createDirRecursive' (fromGHCupPath logsDir) createDirRecursive' (fromGHCupPath confDir) createDirRecursive' (fromGHCupPath trashDir) createDirRecursive' (fromGHCupPath dbDir) + createDirRecursive' (fromGHCupPath tmpDir) pure () diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs index acf8b37..817d2ac 100644 --- a/lib/GHCup/Utils/Dirs.hs +++ b/lib/GHCup/Utils/Dirs.hs @@ -99,6 +99,9 @@ module GHCup.Utils.Dirs , setAccessTime , setModificationTime , isSymbolicLink + + -- uhm + , rmPathForcibly ) where @@ -135,7 +138,6 @@ import System.Directory hiding ( removeDirectory ) import qualified System.Directory as SD -import System.DiskSpace import System.Environment import System.FilePath import System.IO.Temp @@ -145,7 +147,6 @@ import qualified Data.ByteString as BS import qualified Data.Text as T import qualified Data.Yaml.Aeson as Y import qualified Text.Megaparsec as MP -import Control.Concurrent (threadDelay) @@ -174,7 +175,7 @@ createTempGHCupDirectory (GHCupPath gp) d = GHCupPath <$> createTempDirectory gp getGHCupTmpDirs :: IO [GHCupPath] getGHCupTmpDirs = do - tmpdir <- getCanonicalTemporaryDirectory + tmpdir <- fromGHCupPath <$> ghcupTMPDir ghcup_dirs <- handleIO (\_ -> pure []) $ findFiles tmpdir (makeRegexOpts compExtended @@ -323,6 +324,25 @@ ghcupRecycleDir :: IO GHCupPath ghcupRecycleDir = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp "trash")) +-- | Defaults to '~/.ghcup/tmp. +-- +-- If 'GHCUP_USE_XDG_DIRS' is set (to anything), +-- then uses 'XDG_CACHE_HOME/ghcup/tmp as per xdg spec. +ghcupTMPDir :: IO GHCupPath +ghcupTMPDir + | isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp "tmp")) + | 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 (GHCupPath (bdir "ghcup" "tmp")) + else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp "tmp")) + getAllDirs :: IO Dirs getAllDirs = do @@ -332,6 +352,7 @@ getAllDirs = do logsDir <- ghcupLogsDir confDir <- ghcupConfigDir recycleDir <- ghcupRecycleDir + tmpDir <- ghcupTMPDir dbDir <- ghcupDbDir pure Dirs { .. } @@ -405,6 +426,7 @@ ghcupHLSDir ver = do let verdir = T.unpack $ prettyVer ver pure (basedir `appendGHCupPath` verdir) + mkGhcupTmpDir :: ( MonadReader env m , HasDirs env , MonadUnliftIO m @@ -415,29 +437,8 @@ mkGhcupTmpDir :: ( MonadReader env m , MonadIO m) => m GHCupPath mkGhcupTmpDir = GHCupPath <$> do - tmpdir <- liftIO getCanonicalTemporaryDirectory - - let minSpace = 5000 -- a rough guess, aight? - space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace tmpdir - when (maybe False (toBytes minSpace >) space) $ do - logWarn ("Possibly insufficient disk space on " - <> T.pack tmpdir - <> ". At least " - <> T.pack (show minSpace) - <> " MB are recommended, but only " - <> toMB (fromJust space) - <> " are free. Consider freeing up disk space or setting TMPDIR env variable.") - logWarn - "...waiting for 10 seconds before continuing anyway, you can still abort..." - liftIO $ threadDelay 10000000 -- give the user a sec to intervene - - liftIO $ createTempDirectory tmpdir "ghcup" - where - toBytes mb = mb * 1024 * 1024 - toMB b = T.pack $ show (truncate' (fromIntegral b / (1024 * 1024) :: Double) 2) - truncate' :: Double -> Int -> Double - truncate' x n = fromIntegral (floor (x * t) :: Integer) / t - where t = 10^n + Dirs { tmpDir } <- getDirs + liftIO $ createTempDirectory (fromGHCupPath tmpDir) "ghcup" withGHCupTmpDir :: ( MonadReader env m @@ -521,4 +522,13 @@ removePathForcibly :: GHCupPath -> IO () removePathForcibly (GHCupPath fp) = SD.removePathForcibly fp +rmPathForcibly :: ( MonadIO m + , MonadMask m + ) + => GHCupPath + -> m () +rmPathForcibly fp + | isWindows = recover (liftIO $ removePathForcibly fp) + | otherwise = liftIO $ removePathForcibly fp + diff --git a/lib/GHCup/Utils/File.hs b/lib/GHCup/Utils/File.hs index 2bc8a04..493c531 100644 --- a/lib/GHCup/Utils/File.hs +++ b/lib/GHCup/Utils/File.hs @@ -33,7 +33,15 @@ module GHCup.Utils.File ( removeEmptyDirectory, removeDirIfEmptyOrIsSymlink, removeEmptyDirsRecursive, - rmFileForce + rmFileForce, + createDirRecursive', + recyclePathForcibly, + rmDirectory, + recycleFile, + rmFile, + rmDirectoryLink, + moveFilePortable, + moveFile ) where import GHCup.Utils.Dirs @@ -235,3 +243,98 @@ rmFileForce :: (MonadMask m, MonadIO m) => FilePath -> m () rmFileForce filepath = do hideError doesNotExistErrorType $ hideError InappropriateType $ rmFile filepath + +-- | More permissive version of 'createDirRecursive'. This doesn't +-- error when the destination is a symlink to a directory. +createDirRecursive' :: FilePath -> IO () +createDirRecursive' p = + handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e) + . createDirectoryIfMissing True + $ p + + where + isSymlinkDir e = do + ft <- pathIsSymbolicLink p + case ft of + True -> do + rp <- canonicalizePath p + rft <- doesDirectoryExist rp + case rft of + True -> pure () + _ -> throwIO e + _ -> throwIO e + + +-- https://github.com/haskell/directory/issues/110 +-- https://github.com/haskell/directory/issues/96 +-- https://www.sqlite.org/src/info/89f1848d7f +recyclePathForcibly :: ( MonadIO m + , MonadReader env m + , HasDirs env + , MonadMask m + ) + => GHCupPath + -> m () +recyclePathForcibly fp + | isWindows = do + Dirs { recycleDir } <- getDirs + tmp <- liftIO $ createTempGHCupDirectory recycleDir "recyclePathForcibly" + let dest = tmp `appendGHCupPath` takeFileName (fromGHCupPath fp) + liftIO (moveFile (fromGHCupPath fp) (fromGHCupPath dest)) + `catch` + (\e -> if | isDoesNotExistError e -> pure () + | isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} -> recover (liftIO $ removePathForcibly fp) + | otherwise -> throwIO e) + `finally` + liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp) + | otherwise = liftIO $ removePathForcibly fp + + + +rmDirectory :: (MonadIO m, MonadMask m) + => GHCupPath + -> m () +rmDirectory fp + | isWindows = recover (liftIO $ removeDirectory fp) + | otherwise = liftIO $ removeDirectory fp + + +-- https://www.sqlite.org/src/info/89f1848d7f +-- https://github.com/haskell/directory/issues/96 +recycleFile :: ( MonadIO m + , MonadMask m + , MonadReader env m + , HasDirs env + ) + => FilePath + -> m () +recycleFile fp + | isWindows = do + Dirs { recycleDir } <- getDirs + liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "recycleFile" "" Nothing (Just fp)) + tmp <- liftIO $ createTempGHCupDirectory recycleDir "recycleFile" + let dest = fromGHCupPath tmp takeFileName fp + liftIO (moveFile fp dest) + `catch` + (\e -> if isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} then recover (liftIO $ rmFile fp) else throwIO e) + `finally` + liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp) + | otherwise = liftIO $ removeFile fp + + +rmFile :: ( MonadIO m + , MonadMask m + ) + => FilePath + -> m () +rmFile fp + | isWindows = recover (liftIO $ removeFile fp) + | otherwise = liftIO $ removeFile fp + + +rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env) + => FilePath + -> m () +rmDirectoryLink fp + | isWindows = recover (liftIO $ removeDirectoryLink fp) + | otherwise = liftIO $ removeDirectoryLink fp diff --git a/lib/GHCup/Utils/File.hs-boot b/lib/GHCup/Utils/File.hs-boot new file mode 100644 index 0000000..2da9c00 --- /dev/null +++ b/lib/GHCup/Utils/File.hs-boot @@ -0,0 +1,14 @@ +{-# LANGUAGE FlexibleContexts #-} + +module GHCup.Utils.File ( + recycleFile +) where + +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Catch (MonadMask) +import Control.Monad.Reader (MonadReader) +import GHCup.Types.Optics (HasDirs) + + +recycleFile :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env) => FilePath -> m () + diff --git a/lib/GHCup/Utils/File/Posix.hs b/lib/GHCup/Utils/File/Posix.hs index 51b1cb1..1ff0f2f 100644 --- a/lib/GHCup/Utils/File/Posix.hs +++ b/lib/GHCup/Utils/File/Posix.hs @@ -40,10 +40,11 @@ import Data.Sequence ( Seq, (|>) ) import Data.List import Data.Word8 import Foreign.C.String +import Foreign.C.Error import Foreign.C.Types import GHC.IO.Exception import System.IO ( stderr, hClose, hSetBinaryMode ) -import System.IO.Error +import System.IO.Error hiding ( catchIOError ) import System.FilePath import System.Posix.Directory import System.Posix.Error ( throwErrnoPathIfMinus1Retry ) @@ -559,6 +560,28 @@ install from to fail' = do | PF.isSymbolicLink fs = recreateSymlink from to fail' | otherwise = ioError $ mkIOError illegalOperationErrorType "install: not a regular file or symlink" Nothing (Just from) +moveFile :: FilePath -> FilePath -> IO () +moveFile = rename + + +moveFilePortable :: FilePath -> FilePath -> IO () +moveFilePortable from to = do + catchErrno [eXDEV] (moveFile from to) $ do + copyFile from to True + removeFile from + + +catchErrno :: [Errno] -- ^ errno to catch + -> IO a -- ^ action to try, which can raise an IOException + -> IO a -- ^ action to carry out in case of an IOException and + -- if errno matches + -> IO a +catchErrno en a1 a2 = + catchIOError a1 $ \e -> do + errno <- getErrno + if errno `elem` en + then a2 + else ioError e removeEmptyDirectory :: FilePath -> IO () removeEmptyDirectory = PD.removeDirectory diff --git a/lib/GHCup/Utils/File/Windows.hs b/lib/GHCup/Utils/File/Windows.hs index fea543a..5d168cf 100644 --- a/lib/GHCup/Utils/File/Windows.hs +++ b/lib/GHCup/Utils/File/Windows.hs @@ -293,8 +293,18 @@ copyFile = WS.copyFile deleteFile :: FilePath -> IO () deleteFile = WS.deleteFile + install :: FilePath -> FilePath -> Bool -> IO () -install = copyFile +install = moveFile + + +moveFile :: FilePath -> FilePath -> IO () +moveFile from to = Win32.moveFileEx from (Just to) 0 + + +moveFilePortable :: FilePath -> FilePath -> IO () +moveFilePortable = Win32.moveFile + removeEmptyDirectory :: FilePath -> IO () removeEmptyDirectory = WS.removeDirectory diff --git a/lib/GHCup/Utils/Logger.hs b/lib/GHCup/Utils/Logger.hs index 3763e07..2d003b5 100644 --- a/lib/GHCup/Utils/Logger.hs +++ b/lib/GHCup/Utils/Logger.hs @@ -19,6 +19,7 @@ import GHCup.Types import GHCup.Types.Optics import {-# SOURCE #-} GHCup.Utils.Dirs (fromGHCupPath) import {-# SOURCE #-} GHCup.Utils.File.Common (findFiles) +import {-# SOURCE #-} GHCup.Utils.File (recycleFile) import GHCup.Utils.String.QQ import Control.Exception.Safe diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Utils/Prelude.hs index c2486a6..d39d5d0 100644 --- a/lib/GHCup/Utils/Prelude.hs +++ b/lib/GHCup/Utils/Prelude.hs @@ -379,109 +379,6 @@ escapeVerRex = B.pack . go . B.unpack . verToBS go (x : xs) | x == _period = [_backslash, _period] ++ go xs | otherwise = x : go xs --- | More permissive version of 'createDirRecursive'. This doesn't --- error when the destination is a symlink to a directory. -createDirRecursive' :: FilePath -> IO () -createDirRecursive' p = - handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e) - . createDirectoryIfMissing True - $ p - - where - isSymlinkDir e = do - ft <- pathIsSymbolicLink p - case ft of - True -> do - rp <- canonicalizePath p - rft <- doesDirectoryExist rp - case rft of - True -> pure () - _ -> throwIO e - _ -> throwIO e - - --- https://github.com/haskell/directory/issues/110 --- https://github.com/haskell/directory/issues/96 --- https://www.sqlite.org/src/info/89f1848d7f -recyclePathForcibly :: ( MonadIO m - , MonadReader env m - , HasDirs env - , MonadMask m - ) - => GHCupPath - -> m () -recyclePathForcibly fp - | isWindows = do - Dirs { recycleDir } <- getDirs - tmp <- liftIO $ createTempGHCupDirectory recycleDir "recyclePathForcibly" - let dest = tmp `appendGHCupPath` takeFileName (fromGHCupPath fp) - liftIO (moveFile (fromGHCupPath fp) (fromGHCupPath dest)) - `catch` - (\e -> if | isDoesNotExistError e -> pure () - | isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} -> recover (liftIO $ removePathForcibly fp) - | otherwise -> throwIO e) - `finally` - liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp) - | otherwise = liftIO $ removePathForcibly fp - - -rmPathForcibly :: ( MonadIO m - , MonadMask m - ) - => GHCupPath - -> m () -rmPathForcibly fp - | isWindows = recover (liftIO $ removePathForcibly fp) - | otherwise = liftIO $ removePathForcibly fp - - -rmDirectory :: (MonadIO m, MonadMask m) - => GHCupPath - -> m () -rmDirectory fp - | isWindows = recover (liftIO $ removeDirectory fp) - | otherwise = liftIO $ removeDirectory fp - - --- https://www.sqlite.org/src/info/89f1848d7f --- https://github.com/haskell/directory/issues/96 -recycleFile :: ( MonadIO m - , MonadMask m - , MonadReader env m - , HasDirs env - ) - => FilePath - -> m () -recycleFile fp - | isWindows = do - Dirs { recycleDir } <- getDirs - liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "recycleFile" "" Nothing (Just fp)) - tmp <- liftIO $ createTempGHCupDirectory recycleDir "recycleFile" - let dest = fromGHCupPath tmp takeFileName fp - liftIO (moveFile fp dest) - `catch` - (\e -> if isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} then recover (liftIO $ rmFile fp) else throwIO e) - `finally` - liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp) - | otherwise = liftIO $ removeFile fp - - -rmFile :: ( MonadIO m - , MonadMask m - ) - => FilePath - -> m () -rmFile fp - | isWindows = recover (liftIO $ removeFile fp) - | otherwise = liftIO $ removeFile fp - - -rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env) - => FilePath - -> m () -rmDirectoryLink fp - | isWindows = recover (liftIO $ removeDirectoryLink fp) - | otherwise = liftIO $ removeDirectoryLink fp recover :: (MonadIO m, MonadMask m) => m a -> m a diff --git a/lib/GHCup/Utils/Prelude/Posix.hs b/lib/GHCup/Utils/Prelude/Posix.hs index e092320..3945423 100644 --- a/lib/GHCup/Utils/Prelude/Posix.hs +++ b/lib/GHCup/Utils/Prelude/Posix.hs @@ -1,24 +1,8 @@ module GHCup.Utils.Prelude.Posix where -import System.Directory hiding ( removeDirectory - , removeDirectoryRecursive - , removePathForcibly - , findFiles - ) -import System.Posix.Files - isWindows, isNotWindows :: Bool isWindows = False isNotWindows = not isWindows -moveFile :: FilePath -> FilePath -> IO () -moveFile = rename - - -moveFilePortable :: FilePath -> FilePath -> IO () -moveFilePortable from to = do - copyFile from to - removeFile from - diff --git a/lib/GHCup/Utils/Prelude/Windows.hs b/lib/GHCup/Utils/Prelude/Windows.hs index 914b374..bcdeb41 100644 --- a/lib/GHCup/Utils/Prelude/Windows.hs +++ b/lib/GHCup/Utils/Prelude/Windows.hs @@ -1,17 +1,6 @@ module GHCup.Utils.Prelude.Windows where -import qualified System.Win32.File as Win32 - - isWindows, isNotWindows :: Bool isWindows = True isNotWindows = not isWindows - -moveFile :: FilePath -> FilePath -> IO () -moveFile from to = Win32.moveFileEx from (Just to) 0 - - -moveFilePortable :: FilePath -> FilePath -> IO () -moveFilePortable = Win32.moveFile - From 5741e069ad5cbf6599dc70d5b9ab9c2a95be927f Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 20 May 2022 23:28:15 +0200 Subject: [PATCH 16/20] Fix deletion on missing files --- lib/GHCup.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 3e4e0c3..2d09ab7 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -1808,7 +1808,7 @@ rmGHCVer ver = do lift (getInstalledFiles GHC ver) >>= \case Just files -> do lift $ logInfo $ "Removing files safely from: " <> T.pack dir - forM_ files (lift . recycleFile . (\f -> dir dropDrive f)) + forM_ files (lift . hideError NoSuchThing . recycleFile . (\f -> dir dropDrive f)) removeEmptyDirsRecursive dir survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory dir f <- recordedInstallationFile GHC ver @@ -1892,7 +1892,7 @@ rmHLSVer ver = do lift (getInstalledFiles HLS (mkTVer ver)) >>= \case Just files -> do lift $ logInfo $ "Removing files safely from: " <> T.pack hlsDir - forM_ files (lift . recycleFile . (\f -> hlsDir dropDrive f)) + forM_ files (lift . hideError NoSuchThing . recycleFile . (\f -> hlsDir dropDrive f)) removeEmptyDirsRecursive hlsDir survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory hlsDir f <- recordedInstallationFile HLS (mkTVer ver) From b5fb8772fea835961bc94e43d170a7a283addfd1 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sat, 21 May 2022 00:33:01 +0200 Subject: [PATCH 17/20] Fix windows --- lib/GHCup/Utils/File/Windows.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/GHCup/Utils/File/Windows.hs b/lib/GHCup/Utils/File/Windows.hs index 5d168cf..84d979b 100644 --- a/lib/GHCup/Utils/File/Windows.hs +++ b/lib/GHCup/Utils/File/Windows.hs @@ -295,15 +295,15 @@ deleteFile = WS.deleteFile install :: FilePath -> FilePath -> Bool -> IO () -install = moveFile +install = copyFile moveFile :: FilePath -> FilePath -> IO () -moveFile from to = Win32.moveFileEx from (Just to) 0 +moveFile from to = WS.moveFileEx from (Just to) 0 moveFilePortable :: FilePath -> FilePath -> IO () -moveFilePortable = Win32.moveFile +moveFilePortable = WS.moveFile removeEmptyDirectory :: FilePath -> IO () From 68c81577a4a1e208879e206cb4b268d779163a9d Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sat, 21 May 2022 15:03:20 +0200 Subject: [PATCH 18/20] Fix HLS install via compile --- lib/GHCup.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 2d09ab7..d8b2a5c 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -710,6 +710,10 @@ installHLSUnpackedLegacy path installDir ver forceInstall = do let srcPath = path f let destPath = fromInstallDir installDir toF + -- destination could be an existing symlink + -- for new make-based HLSes + liftIO $ rmFileForce destPath + copyFileE srcPath destPath @@ -727,6 +731,7 @@ installHLSUnpackedLegacy path installDir ver forceInstall = do srcWrapperPath = path wrapper <> exeExt destWrapperPath = fromInstallDir installDir toF + liftIO $ rmFileForce destWrapperPath copyFileE srcWrapperPath destWrapperPath @@ -935,7 +940,6 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc (tmpInstallDir "haskell-language-server-" <> takeFileName artifact <.> exeExt) liftIO $ renameFile (artifact "haskell-language-server-wrapper" <.> exeExt) (tmpInstallDir "haskell-language-server-wrapper" <.> exeExt) - liftIO $ hideError NoSuchThing $ rmFile artifact case installDir of IsolateDir isoDir -> do From c56b9ec3ce2912406a063fd0db0dbdebf9f45824 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sat, 21 May 2022 20:51:13 +0200 Subject: [PATCH 19/20] Make windows mergeFileTree more robust --- lib/GHCup.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index d8b2a5c..60a963f 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -328,10 +328,11 @@ installUnpackedGHC path inst ver forceInstall -- Windows bindists are relocatable and don't need -- to run configure. -- We also must make sure to preserve mtime to not confuse ghc-pkg. - liftE $ mergeFileTree path inst GHC (mkTVer ver) $ \source dest -> liftIO $ do - mtime <- ifM (pathIsSymbolicLink source) (pure Nothing) (Just <$> getModificationTime source) - moveFilePortable source dest - forM_ mtime $ setModificationTime dest + liftE $ mergeFileTree path inst GHC (mkTVer ver) $ \source dest -> do + mtime <- liftIO $ ifM (pathIsSymbolicLink source) (pure Nothing) (Just <$> getModificationTime source) + when forceInstall $ hideError doesNotExistErrorType $ hideError InappropriateType $ recycleFile dest + liftIO $ moveFilePortable source dest + forM_ mtime $ liftIO . setModificationTime dest | otherwise = do PlatformRequest {..} <- lift getPlatformReq From 284542509988a54c003c958cf8f638a847cd3631 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sat, 21 May 2022 22:54:18 +0200 Subject: [PATCH 20/20] Restructure modules --- app/ghcup/BrickMain.hs | 7 +- app/ghcup/GHCup/OptParse/ChangeLog.hs | 8 +- app/ghcup/GHCup/OptParse/Common.hs | 8 +- app/ghcup/GHCup/OptParse/Compile.hs | 5 +- app/ghcup/GHCup/OptParse/Config.hs | 7 +- app/ghcup/GHCup/OptParse/DInfo.hs | 6 +- app/ghcup/GHCup/OptParse/GC.hs | 4 +- app/ghcup/GHCup/OptParse/Install.hs | 4 +- app/ghcup/GHCup/OptParse/List.hs | 2 +- app/ghcup/GHCup/OptParse/Nuke.hs | 2 +- app/ghcup/GHCup/OptParse/Prefetch.hs | 6 +- app/ghcup/GHCup/OptParse/Rm.hs | 4 +- app/ghcup/GHCup/OptParse/Run.hs | 11 +- app/ghcup/GHCup/OptParse/Set.hs | 4 +- app/ghcup/GHCup/OptParse/ToolRequirements.hs | 6 +- app/ghcup/GHCup/OptParse/UnSet.hs | 4 +- app/ghcup/GHCup/OptParse/Upgrade.hs | 3 +- app/ghcup/GHCup/OptParse/Whereis.hs | 4 +- app/ghcup/Main.hs | 6 +- ghcup.cabal | 40 +- lib/GHCup.hs | 2508 +---------------- lib/GHCup/Cabal.hs | 279 ++ lib/GHCup/Download.hs | 7 +- lib/GHCup/Download/IOStreams.hs | 2 +- lib/GHCup/Download/Utils.hs | 2 +- lib/GHCup/GHC.hs | 1078 +++++++ lib/GHCup/HLS.hs | 620 ++++ lib/GHCup/List.hs | 410 +++ lib/GHCup/Platform.hs | 8 +- lib/GHCup/Prelude.hs | 54 + lib/GHCup/{Utils => Prelude}/File.hs | 112 +- lib/GHCup/Prelude/File/Posix.hs | 324 +++ .../{Utils => Prelude}/File/Posix/Foreign.hsc | 2 +- .../File/Posix/Traversals.hs | 4 +- .../File/Common.hs => Prelude/File/Search.hs} | 19 +- lib/GHCup/{Utils => Prelude}/File/Windows.hs | 239 +- .../{Utils/Prelude.hs => Prelude/Internal.hs} | 93 +- lib/GHCup/Prelude/Logger.hs | 61 + .../Logger.hs => Prelude/Logger/Internal.hs} | 37 +- lib/GHCup/{Utils => Prelude}/MegaParsec.hs | 2 +- lib/GHCup/{Utils => Prelude}/Posix.hs | 7 +- lib/GHCup/Prelude/Process.hs | 25 + .../{Utils/File => Prelude/Process}/Posix.hs | 297 +- lib/GHCup/Prelude/Process/Windows.hs | 251 ++ lib/GHCup/{Utils => Prelude}/String/QQ.hs | 2 +- lib/GHCup/{Utils => Prelude}/Version/QQ.hs | 2 +- lib/GHCup/{Utils => Prelude}/Windows.hs | 7 +- lib/GHCup/Stack.hs | 278 ++ lib/GHCup/Types.hs | 3 +- lib/GHCup/Types/JSON.hs | 2 +- lib/GHCup/Utils.hs | 163 +- lib/GHCup/Utils.hs-boot | 4 - lib/GHCup/Utils/Dirs.hs | 43 +- lib/GHCup/Utils/File.hs-boot | 14 - lib/GHCup/Utils/File/Common.hs-boot | 5 - lib/GHCup/Utils/Logger.hs-boot | 19 - lib/GHCup/Utils/Prelude/Posix.hs | 8 - lib/GHCup/Utils/Prelude/Windows.hs | 6 - lib/GHCup/Version.hs | 68 +- test/GHCup/Utils/FileSpec.hs | 2 +- 60 files changed, 3857 insertions(+), 3351 deletions(-) create mode 100644 lib/GHCup/Cabal.hs create mode 100644 lib/GHCup/GHC.hs create mode 100644 lib/GHCup/HLS.hs create mode 100644 lib/GHCup/List.hs create mode 100644 lib/GHCup/Prelude.hs rename lib/GHCup/{Utils => Prelude}/File.hs (79%) create mode 100644 lib/GHCup/Prelude/File/Posix.hs rename lib/GHCup/{Utils => Prelude}/File/Posix/Foreign.hsc (97%) rename lib/GHCup/{Utils => Prelude}/File/Posix/Traversals.hs (96%) rename lib/GHCup/{Utils/File/Common.hs => Prelude/File/Search.hs} (86%) rename lib/GHCup/{Utils => Prelude}/File/Windows.hs (52%) rename lib/GHCup/{Utils/Prelude.hs => Prelude/Internal.hs} (80%) create mode 100644 lib/GHCup/Prelude/Logger.hs rename lib/GHCup/{Utils/Logger.hs => Prelude/Logger/Internal.hs} (70%) rename lib/GHCup/{Utils => Prelude}/MegaParsec.hs (98%) rename lib/GHCup/{Utils => Prelude}/Posix.hs (78%) create mode 100644 lib/GHCup/Prelude/Process.hs rename lib/GHCup/{Utils/File => Prelude/Process}/Posix.hs (54%) create mode 100644 lib/GHCup/Prelude/Process/Windows.hs rename lib/GHCup/{Utils => Prelude}/String/QQ.hs (97%) rename lib/GHCup/{Utils => Prelude}/Version/QQ.hs (98%) rename lib/GHCup/{Utils => Prelude}/Windows.hs (93%) create mode 100644 lib/GHCup/Stack.hs delete mode 100644 lib/GHCup/Utils.hs-boot delete mode 100644 lib/GHCup/Utils/File.hs-boot delete mode 100644 lib/GHCup/Utils/File/Common.hs-boot delete mode 100644 lib/GHCup/Utils/Logger.hs-boot delete mode 100644 lib/GHCup/Utils/Prelude/Posix.hs delete mode 100644 lib/GHCup/Utils/Prelude/Windows.hs diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index aae119f..f1fb54d 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -13,9 +13,10 @@ import GHCup.Errors import GHCup.Types.Optics ( getDirs ) import GHCup.Types hiding ( LeanAppState(..) ) import GHCup.Utils -import GHCup.Utils.Logger -import GHCup.Utils.Prelude ( decUTF8Safe ) -import GHCup.Utils.File +import GHCup.Prelude ( decUTF8Safe ) +import GHCup.Prelude.File +import GHCup.Prelude.Logger +import GHCup.Prelude.Process import Brick import Brick.Widgets.Border diff --git a/app/ghcup/GHCup/OptParse/ChangeLog.hs b/app/ghcup/GHCup/OptParse/ChangeLog.hs index 7c8db99..652d850 100644 --- a/app/ghcup/GHCup/OptParse/ChangeLog.hs +++ b/app/ghcup/GHCup/OptParse/ChangeLog.hs @@ -12,9 +12,11 @@ module GHCup.OptParse.ChangeLog where import GHCup.Types -import GHCup.Utils.Logger import GHCup.OptParse.Common -import GHCup.Utils.String.QQ +import GHCup.Prelude +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ +import GHCup.Prelude.Process (exec) #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) @@ -34,8 +36,6 @@ import GHCup.Types.Optics import GHCup.Utils import Data.Versions import URI.ByteString (serializeURIRef') -import GHCup.Utils.Prelude -import GHCup.Utils.File (exec) import Data.Char (toLower) diff --git a/app/ghcup/GHCup/OptParse/Common.hs b/app/ghcup/GHCup/OptParse/Common.hs index a12303a..234fcbb 100644 --- a/app/ghcup/GHCup/OptParse/Common.hs +++ b/app/ghcup/GHCup/OptParse/Common.hs @@ -16,10 +16,10 @@ import GHCup.Platform import GHCup.Types import GHCup.Types.Optics import GHCup.Utils -import GHCup.Utils.File -import GHCup.Utils.Logger -import GHCup.Utils.MegaParsec -import GHCup.Utils.Prelude +import GHCup.Prelude +import GHCup.Prelude.Process +import GHCup.Prelude.Logger +import GHCup.Prelude.MegaParsec import Control.DeepSeq import Control.Concurrent diff --git a/app/ghcup/GHCup/OptParse/Compile.hs b/app/ghcup/GHCup/OptParse/Compile.hs index f578c46..5c2019a 100644 --- a/app/ghcup/GHCup/OptParse/Compile.hs +++ b/app/ghcup/GHCup/OptParse/Compile.hs @@ -13,13 +13,12 @@ module GHCup.OptParse.Compile where import GHCup import GHCup.Errors -import GHCup.Utils.File import GHCup.Types import GHCup.Types.Optics import GHCup.Utils -import GHCup.Utils.Logger +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ import GHCup.OptParse.Common -import GHCup.Utils.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) diff --git a/app/ghcup/GHCup/OptParse/Config.hs b/app/ghcup/GHCup/OptParse/Config.hs index c8072ab..c03b849 100644 --- a/app/ghcup/GHCup/OptParse/Config.hs +++ b/app/ghcup/GHCup/OptParse/Config.hs @@ -7,7 +7,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ExplicitForAll #-} module GHCup.OptParse.Config where @@ -15,9 +14,9 @@ module GHCup.OptParse.Config where import GHCup.Errors import GHCup.Types import GHCup.Utils -import GHCup.Utils.Prelude -import GHCup.Utils.Logger -import GHCup.Utils.String.QQ +import GHCup.Prelude +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ import GHCup.OptParse.Common #if !MIN_VERSION_base(4,13,0) diff --git a/app/ghcup/GHCup/OptParse/DInfo.hs b/app/ghcup/GHCup/OptParse/DInfo.hs index 46c3d3d..23ced6e 100644 --- a/app/ghcup/GHCup/OptParse/DInfo.hs +++ b/app/ghcup/GHCup/OptParse/DInfo.hs @@ -17,9 +17,10 @@ import GHCup import GHCup.Errors import GHCup.Version import GHCup.Types -import GHCup.Utils.Prelude import GHCup.Utils.Dirs -import GHCup.Utils.Logger +import GHCup.Prelude +import GHCup.Prelude.Logger +import GHCup.Prelude.Process #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) @@ -36,7 +37,6 @@ import Text.PrettyPrint.HughesPJClass ( prettyShow ) import qualified Data.Text as T import Control.Exception.Safe (MonadMask) -import GHCup.Utils.File import Language.Haskell.TH diff --git a/app/ghcup/GHCup/OptParse/GC.hs b/app/ghcup/GHCup/OptParse/GC.hs index e51edbc..d74dd8e 100644 --- a/app/ghcup/GHCup/OptParse/GC.hs +++ b/app/ghcup/GHCup/OptParse/GC.hs @@ -14,8 +14,8 @@ module GHCup.OptParse.GC where import GHCup import GHCup.Errors import GHCup.Types -import GHCup.Utils.Logger -import GHCup.Utils.String.QQ +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) diff --git a/app/ghcup/GHCup/OptParse/Install.hs b/app/ghcup/GHCup/OptParse/Install.hs index 905ae64..a67b183 100644 --- a/app/ghcup/GHCup/OptParse/Install.hs +++ b/app/ghcup/GHCup/OptParse/Install.hs @@ -19,8 +19,8 @@ import GHCup import GHCup.Errors import GHCup.Types import GHCup.Utils.Dirs -import GHCup.Utils.Logger -import GHCup.Utils.String.QQ +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ import Codec.Archive #if !MIN_VERSION_base(4,13,0) diff --git a/app/ghcup/GHCup/OptParse/List.hs b/app/ghcup/GHCup/OptParse/List.hs index d1bfc65..72cd2bb 100644 --- a/app/ghcup/GHCup/OptParse/List.hs +++ b/app/ghcup/GHCup/OptParse/List.hs @@ -11,7 +11,7 @@ module GHCup.OptParse.List where import GHCup -import GHCup.Utils.Prelude +import GHCup.Prelude import GHCup.Types import GHCup.OptParse.Common diff --git a/app/ghcup/GHCup/OptParse/Nuke.hs b/app/ghcup/GHCup/OptParse/Nuke.hs index 43bcc7c..84712d4 100644 --- a/app/ghcup/GHCup/OptParse/Nuke.hs +++ b/app/ghcup/GHCup/OptParse/Nuke.hs @@ -14,7 +14,7 @@ module GHCup.OptParse.Nuke where import GHCup import GHCup.Errors import GHCup.Types -import GHCup.Utils.Logger +import GHCup.Prelude.Logger #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) diff --git a/app/ghcup/GHCup/OptParse/Prefetch.hs b/app/ghcup/GHCup/OptParse/Prefetch.hs index 7d43c10..221ecef 100644 --- a/app/ghcup/GHCup/OptParse/Prefetch.hs +++ b/app/ghcup/GHCup/OptParse/Prefetch.hs @@ -14,10 +14,10 @@ module GHCup.OptParse.Prefetch where import GHCup import GHCup.Errors import GHCup.Types -import GHCup.Utils.File -import GHCup.Utils.Logger +import GHCup.Prelude.File +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ import GHCup.OptParse.Common -import GHCup.Utils.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) diff --git a/app/ghcup/GHCup/OptParse/Rm.hs b/app/ghcup/GHCup/OptParse/Rm.hs index d91faef..26d7471 100644 --- a/app/ghcup/GHCup/OptParse/Rm.hs +++ b/app/ghcup/GHCup/OptParse/Rm.hs @@ -18,9 +18,9 @@ import GHCup.Errors import GHCup.Types import GHCup.Types.Optics import GHCup.Utils -import GHCup.Utils.Logger +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ import GHCup.OptParse.Common -import GHCup.Utils.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) diff --git a/app/ghcup/GHCup/OptParse/Run.hs b/app/ghcup/GHCup/OptParse/Run.hs index c5bc1ac..90938f6 100644 --- a/app/ghcup/GHCup/OptParse/Run.hs +++ b/app/ghcup/GHCup/OptParse/Run.hs @@ -10,14 +10,17 @@ module GHCup.OptParse.Run where import GHCup import GHCup.Utils -import GHCup.Utils.Prelude -import GHCup.Utils.File import GHCup.OptParse.Common import GHCup.Errors import GHCup.Types import GHCup.Types.Optics -import GHCup.Utils.Logger -import GHCup.Utils.String.QQ +import GHCup.Prelude +import GHCup.Prelude.File +#ifdef IS_WINDOWS +import GHCup.Prelude.Process +#endif +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ import Control.Exception.Safe ( MonadMask, MonadCatch ) #if !MIN_VERSION_base(4,13,0) diff --git a/app/ghcup/GHCup/OptParse/Set.hs b/app/ghcup/GHCup/OptParse/Set.hs index 5514085..22f8da6 100644 --- a/app/ghcup/GHCup/OptParse/Set.hs +++ b/app/ghcup/GHCup/OptParse/Set.hs @@ -17,8 +17,8 @@ import GHCup.OptParse.Common import GHCup import GHCup.Errors import GHCup.Types -import GHCup.Utils.Logger -import GHCup.Utils.String.QQ +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) diff --git a/app/ghcup/GHCup/OptParse/ToolRequirements.hs b/app/ghcup/GHCup/OptParse/ToolRequirements.hs index f7048ea..f917a05 100644 --- a/app/ghcup/GHCup/OptParse/ToolRequirements.hs +++ b/app/ghcup/GHCup/OptParse/ToolRequirements.hs @@ -11,8 +11,8 @@ module GHCup.OptParse.ToolRequirements where import GHCup.Errors import GHCup.Types -import GHCup.Utils.Logger -import GHCup.Utils.String.QQ +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) @@ -30,7 +30,7 @@ import qualified Data.Text.IO as T import Control.Exception.Safe (MonadMask) import GHCup.Types.Optics import GHCup.Platform -import GHCup.Utils.Prelude +import GHCup.Prelude import GHCup.Requirements import System.IO diff --git a/app/ghcup/GHCup/OptParse/UnSet.hs b/app/ghcup/GHCup/OptParse/UnSet.hs index fd3c4fa..08e804d 100644 --- a/app/ghcup/GHCup/OptParse/UnSet.hs +++ b/app/ghcup/GHCup/OptParse/UnSet.hs @@ -16,8 +16,8 @@ module GHCup.OptParse.UnSet where import GHCup import GHCup.Errors import GHCup.Types -import GHCup.Utils.Logger -import GHCup.Utils.String.QQ +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) diff --git a/app/ghcup/GHCup/OptParse/Upgrade.hs b/app/ghcup/GHCup/OptParse/Upgrade.hs index bceb4dc..193d178 100644 --- a/app/ghcup/GHCup/OptParse/Upgrade.hs +++ b/app/ghcup/GHCup/OptParse/Upgrade.hs @@ -14,7 +14,8 @@ module GHCup.OptParse.Upgrade where import GHCup import GHCup.Errors import GHCup.Types -import GHCup.Utils.Logger +import GHCup.Prelude.File +import GHCup.Prelude.Logger #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) diff --git a/app/ghcup/GHCup/OptParse/Whereis.hs b/app/ghcup/GHCup/OptParse/Whereis.hs index 89ef8ed..ed86697 100644 --- a/app/ghcup/GHCup/OptParse/Whereis.hs +++ b/app/ghcup/GHCup/OptParse/Whereis.hs @@ -18,8 +18,8 @@ import GHCup.Errors import GHCup.OptParse.Common import GHCup.Types import GHCup.Utils -import GHCup.Utils.Logger -import GHCup.Utils.String.QQ +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index df636d7..ee2cf08 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -22,9 +22,9 @@ import GHCup.Platform import GHCup.Types import GHCup.Types.Optics hiding ( toolRequirements ) import GHCup.Utils -import GHCup.Utils.Logger -import GHCup.Utils.Prelude -import GHCup.Utils.String.QQ +import GHCup.Prelude +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ import GHCup.Version import Cabal.Plan ( findPlanJson, SearchPlanJson(..) ) diff --git a/ghcup.cabal b/ghcup.cabal index 8484a50..ee0f476 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -44,31 +44,39 @@ flag internal-downloader manual: True flag no-exe - description: Don't build any executables + description: Don't build any executables default: False manual: True library exposed-modules: GHCup + GHCup.Cabal GHCup.Download GHCup.Download.Utils GHCup.Errors + GHCup.GHC + GHCup.HLS + GHCup.List GHCup.Platform + GHCup.Prelude + GHCup.Prelude.File + GHCup.Prelude.File.Search + GHCup.Prelude.Internal + GHCup.Prelude.Logger + GHCup.Prelude.Logger.Internal + GHCup.Prelude.MegaParsec + GHCup.Prelude.Process + GHCup.Prelude.String.QQ + GHCup.Prelude.Version.QQ GHCup.Requirements + GHCup.Stack GHCup.Types GHCup.Types.JSON GHCup.Types.JSON.Utils GHCup.Types.Optics GHCup.Utils GHCup.Utils.Dirs - GHCup.Utils.File - GHCup.Utils.File.Common - GHCup.Utils.Logger - GHCup.Utils.MegaParsec - GHCup.Utils.Prelude - GHCup.Utils.String.QQ - GHCup.Utils.Version.QQ GHCup.Version hs-source-dirs: lib @@ -155,9 +163,9 @@ library if os(windows) cpp-options: -DIS_WINDOWS other-modules: - GHCup.Utils.File.Windows - GHCup.Utils.Prelude.Windows - GHCup.Utils.Windows + GHCup.Prelude.File.Windows + GHCup.Prelude.Process.Windows + GHCup.Prelude.Windows build-depends: , bzlib @@ -166,11 +174,11 @@ library else other-modules: - GHCup.Utils.File.Posix - GHCup.Utils.File.Posix.Foreign - GHCup.Utils.File.Posix.Traversals - GHCup.Utils.Posix - GHCup.Utils.Prelude.Posix + GHCup.Prelude.File.Posix + GHCup.Prelude.File.Posix.Foreign + GHCup.Prelude.File.Posix.Traversals + GHCup.Prelude.Posix + GHCup.Prelude.Process.Posix c-sources: cbits/dirutils.c build-depends: diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 60a963f..ffeca3a 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -6,7 +6,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} {-| Module : GHCup @@ -23,9 +22,21 @@ and so on. These are the entry points. -} -module GHCup where +module GHCup ( + module GHCup, + module GHCup.Cabal, + module GHCup.GHC, + module GHCup.HLS, + module GHCup.Stack, + module GHCup.List +) where +import GHCup.Cabal +import GHCup.GHC +import GHCup.HLS +import GHCup.Stack +import GHCup.List import GHCup.Download import GHCup.Errors import GHCup.Platform @@ -33,14 +44,12 @@ import GHCup.Types import GHCup.Types.JSON ( ) import GHCup.Types.Optics import GHCup.Utils -import GHCup.Utils.File -import GHCup.Utils.Logger -import GHCup.Utils.Prelude -import GHCup.Utils.String.QQ -import GHCup.Utils.Version.QQ +import GHCup.Prelude +import GHCup.Prelude.File +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ import GHCup.Version -import Codec.Archive ( ArchiveResult ) import Control.Applicative import Control.Exception.Safe import Control.Monad @@ -54,46 +63,22 @@ import Data.ByteString ( ByteString ) import Data.Either import Data.List import Data.Maybe -import Data.List.NonEmpty ( NonEmpty((:|)) ) -import Data.String ( fromString ) -import Data.Text ( Text ) -import Data.Time.Clock -import Data.Time.Format.ISO8601 import Data.Versions hiding ( patch ) -import Distribution.Types.Version hiding ( Version ) -import Distribution.Types.PackageId -import Distribution.Types.PackageDescription -import Distribution.Types.GenericPackageDescription -import Distribution.PackageDescription.Parsec import GHC.IO.Exception import Haskus.Utils.Variant.Excepts -import Language.Haskell.TH -import Language.Haskell.TH.Syntax ( Quasi(qAddDependentFile) ) import Optics import Prelude hiding ( abs , writeFile ) -import Safe hiding ( at ) import System.Environment import System.FilePath import System.IO.Error -import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.Regex.Posix -import URI.ByteString -import qualified Crypto.Hash.SHA256 as SHA256 -import qualified Data.List.NonEmpty as NE -import qualified Data.ByteString.Base16 as B16 -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.Map.Strict as Map import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Data.Text.Encoding as E -import qualified Text.Megaparsec as MP import qualified Streamly.Prelude as S -import GHCup.Utils.MegaParsec -import Control.Concurrent (threadDelay) + + --------------------- @@ -130,1876 +115,14 @@ fetchToolBindist v t mfp = do liftE $ downloadCached' dlinfo Nothing mfp -fetchGHCSrc :: ( MonadFail m - , MonadMask m - , MonadCatch m - , MonadReader env m - , HasDirs env - , HasSettings env - , HasPlatformReq env - , HasGHCupInfo env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - ) - => Version - -> Maybe FilePath - -> Excepts - '[ DigestError - , GPGError - , DownloadFailed - , NoDownload - ] - m - FilePath -fetchGHCSrc v mfp = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - dlInfo <- - preview (ix GHC % ix v % viSourceDL % _Just) dls - ?? NoDownload - liftE $ downloadCached' dlInfo Nothing mfp + ------------ + --[ Nuke ]-- + ------------ - ------------------------- - --[ Tool installation ]-- - ------------------------- --- | Like 'installGHCBin', except takes the 'DownloadInfo' as --- argument instead of looking it up from 'GHCupDownloads'. -installGHCBindist :: ( MonadFail m - , MonadMask m - , MonadCatch m - , MonadReader env m - , HasDirs env - , HasSettings env - , HasPlatformReq env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - ) - => DownloadInfo -- ^ where/how to download - -> Version -- ^ the version to install - -> InstallDir - -> Bool -- ^ Force install - -> Excepts - '[ AlreadyInstalled - , BuildFailed - , DigestError - , GPGError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist - , DirNotEmpty - , ArchiveResult - , ProcessError - , UninstallFailed - , MergeFileTreeError - ] - m - () -installGHCBindist dlinfo ver installDir forceInstall = do - let tver = mkTVer ver - - lift $ logDebug $ "Requested to install GHC with " <> prettyVer ver - - regularGHCInstalled <- lift $ checkIfToolInstalled GHC ver - - if - | not forceInstall - , regularGHCInstalled - , GHCupInternal <- installDir -> do - throwE $ AlreadyInstalled GHC ver - - | forceInstall - , regularGHCInstalled - , GHCupInternal <- installDir -> do - lift $ logInfo "Removing the currently installed GHC version first!" - liftE $ rmGHCVer tver - - | otherwise -> pure () - - -- download (or use cached version) - dl <- liftE $ downloadCached dlinfo Nothing - - - toolchainSanityChecks - - case installDir of - IsolateDir isoDir -> do -- isolated install - lift $ logInfo $ "isolated installing GHC to " <> T.pack isoDir - liftE $ installPackedGHC dl (view dlSubdir dlinfo) (IsolateDirResolved isoDir) ver forceInstall - GHCupInternal -> do -- regular install - -- prepare paths - ghcdir <- lift $ ghcupGHCDir tver - - liftE $ installPackedGHC dl (view dlSubdir dlinfo) (GHCupDir ghcdir) ver forceInstall - - -- make symlinks & stuff when regular install, - liftE $ postGHCInstall tver - - where - toolchainSanityChecks = do - r <- forM ["CC", "LD"] (liftIO . lookupEnv) - case catMaybes r of - [] -> pure () - _ -> do - lift $ logWarn $ "CC/LD environment variable is set. This will change the compiler/linker" - <> "\n" <> "GHC uses internally and can cause defunct GHC in some cases (e.g. in Anaconda" - <> "\n" <> "environments). If you encounter problems, unset CC and LD and reinstall." - - --- | Install a packed GHC distribution. This only deals with unpacking and the GHC --- build system and nothing else. -installPackedGHC :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasDirs env - , HasPlatformReq env - , HasSettings env - , MonadThrow m - , HasLog env - , MonadIO m - , MonadUnliftIO m - , MonadFail m - , MonadResource m - ) - => FilePath -- ^ Path to the packed GHC bindist - -> Maybe TarDir -- ^ Subdir of the archive - -> InstallDirResolved - -> Version -- ^ The GHC version - -> Bool -- ^ Force install - -> Excepts - '[ BuildFailed - , UnknownArchive - , TarDirDoesNotExist - , DirNotEmpty - , ArchiveResult - , ProcessError - , MergeFileTreeError - ] m () -installPackedGHC dl msubdir inst ver forceInstall = do - PlatformRequest {..} <- lift getPlatformReq - - unless forceInstall - (liftE $ installDestSanityCheck inst) - - -- unpack - tmpUnpack <- lift mkGhcupTmpDir - liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) - - -- the subdir of the archive where we do the work - workdir <- maybe (pure tmpUnpack) - (liftE . intoSubdir tmpUnpack) - msubdir - - liftE $ runBuildAction tmpUnpack - (installUnpackedGHC workdir inst ver forceInstall) - - --- | Install an unpacked GHC distribution. This only deals with the GHC --- build system and nothing else. -installUnpackedGHC :: ( MonadReader env m - , HasPlatformReq env - , HasDirs env - , HasSettings env - , MonadThrow m - , HasLog env - , MonadIO m - , MonadUnliftIO m - , MonadMask m - , MonadResource m - , MonadFail m - ) - => GHCupPath -- ^ Path to the unpacked GHC bindist (where the configure script resides) - -> InstallDirResolved -- ^ Path to install to - -> Version -- ^ The GHC version - -> Bool -- ^ Force install - -> Excepts '[ProcessError, MergeFileTreeError] m () -installUnpackedGHC path inst ver forceInstall - | isWindows = do - lift $ logInfo "Installing GHC (this may take a while)" - -- Windows bindists are relocatable and don't need - -- to run configure. - -- We also must make sure to preserve mtime to not confuse ghc-pkg. - liftE $ mergeFileTree path inst GHC (mkTVer ver) $ \source dest -> do - mtime <- liftIO $ ifM (pathIsSymbolicLink source) (pure Nothing) (Just <$> getModificationTime source) - when forceInstall $ hideError doesNotExistErrorType $ hideError InappropriateType $ recycleFile dest - liftIO $ moveFilePortable source dest - forM_ mtime $ liftIO . setModificationTime dest - | otherwise = do - PlatformRequest {..} <- lift getPlatformReq - - let alpineArgs - | ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform - = ["--disable-ld-override"] - | otherwise - = [] - - lift $ logInfo "Installing GHC (this may take a while)" - lEM $ execLogged "sh" - ("./configure" : ("--prefix=" <> fromInstallDir inst) - : alpineArgs - ) - (Just $ fromGHCupPath path) - "ghc-configure" - Nothing - tmpInstallDest <- lift withGHCupTmpDir - lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "install"] (Just $ fromGHCupPath path) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpInstallDest) - liftE $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst)) - inst - GHC - (mkTVer ver) - (\f t -> liftIO $ do - mtime <- ifM (pathIsSymbolicLink f) (pure Nothing) (Just <$> getModificationTime f) - install f t (not forceInstall) - forM_ mtime $ setModificationTime t) - - pure () - - --- | Installs GHC into @~\/.ghcup\/ghc/\@ and places the --- following symlinks in @~\/.ghcup\/bin@: --- --- * @ghc-x.y.z -> ..\/ghc\/x.y.z\/bin/ghc@ --- * @ghc-x.y -> ..\/ghc\/x.y.z\/bin/ghc@ (if x.y.z is the latest x.y version) -installGHCBin :: ( MonadFail m - , MonadMask m - , MonadCatch m - , MonadReader env m - , HasPlatformReq env - , HasGHCupInfo env - , HasDirs env - , HasSettings env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - ) - => Version -- ^ the version to install - -> InstallDir - -> Bool -- ^ force install - -> Excepts - '[ AlreadyInstalled - , BuildFailed - , DigestError - , GPGError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist - , DirNotEmpty - , ArchiveResult - , ProcessError - , UninstallFailed - , MergeFileTreeError - ] - m - () -installGHCBin ver installDir forceInstall = do - dlinfo <- liftE $ getDownloadInfo GHC ver - liftE $ installGHCBindist dlinfo ver installDir forceInstall - - --- | Like 'installCabalBin', except takes the 'DownloadInfo' as --- argument instead of looking it up from 'GHCupDownloads'. -installCabalBindist :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasPlatformReq env - , HasDirs env - , HasSettings env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => DownloadInfo - -> Version - -> InstallDir - -> Bool -- ^ Force install - -> Excepts - '[ AlreadyInstalled - , CopyError - , DigestError - , GPGError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist - , ArchiveResult - , FileAlreadyExistsError - ] - m - () -installCabalBindist dlinfo ver installDir forceInstall = do - lift $ logDebug $ "Requested to install cabal version " <> prettyVer ver - - PlatformRequest {..} <- lift getPlatformReq - Dirs {..} <- lift getDirs - - -- check if we already have a regular cabal already installed - regularCabalInstalled <- lift $ checkIfToolInstalled Cabal ver - - if - | not forceInstall - , regularCabalInstalled - , GHCupInternal <- installDir -> do - throwE $ AlreadyInstalled Cabal ver - - | forceInstall - , regularCabalInstalled - , GHCupInternal <- installDir -> do - lift $ logInfo "Removing the currently installed version first!" - liftE $ rmCabalVer ver - - | otherwise -> pure () - - - -- download (or use cached version) - dl <- liftE $ downloadCached dlinfo Nothing - - -- unpack - tmpUnpack <- lift withGHCupTmpDir - liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) - - -- the subdir of the archive where we do the work - workdir <- fromGHCupPath <$> maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - - case installDir of - IsolateDir isoDir -> do -- isolated install - lift $ logInfo $ "isolated installing Cabal to " <> T.pack isoDir - liftE $ installCabalUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall - - GHCupInternal -> do -- regular install - liftE $ installCabalUnpacked workdir (GHCupBinDir binDir) ver forceInstall - - --- | Install an unpacked cabal distribution.Symbol -installCabalUnpacked :: (MonadCatch m, HasLog env, MonadIO m, MonadReader env m) - => FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides) - -> InstallDirResolved -- ^ Path to install to - -> Version - -> Bool -- ^ Force Install - -> Excepts '[CopyError, FileAlreadyExistsError] m () -installCabalUnpacked path inst ver forceInstall = do - lift $ logInfo "Installing cabal" - let cabalFile = "cabal" - liftIO $ createDirRecursive' (fromInstallDir inst) - let destFileName = cabalFile - <> (case inst of - IsolateDirResolved _ -> "" - _ -> ("-" <>) . T.unpack . prettyVer $ ver - ) - <> exeExt - let destPath = fromInstallDir inst destFileName - - copyFileE - (path cabalFile <> exeExt) - destPath - (not forceInstall) - lift $ chmod_755 destPath - --- | Installs cabal into @~\/.ghcup\/bin/cabal-\@ and --- creates a default @cabal -> cabal-x.y.z.q@ symlink for --- the latest installed version. -installCabalBin :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasPlatformReq env - , HasGHCupInfo env - , HasDirs env - , HasSettings env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => Version - -> InstallDir - -> Bool -- force install - -> Excepts - '[ AlreadyInstalled - , CopyError - , DigestError - , GPGError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist - , ArchiveResult - , FileAlreadyExistsError - ] - m - () -installCabalBin ver installDir forceInstall = do - dlinfo <- liftE $ getDownloadInfo Cabal ver - installCabalBindist dlinfo ver installDir forceInstall - - --- | Like 'installHLSBin, except takes the 'DownloadInfo' as --- argument instead of looking it up from 'GHCupDownloads'. -installHLSBindist :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasPlatformReq env - , HasDirs env - , HasSettings env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => DownloadInfo - -> Version - -> InstallDir -- ^ isolated install path, if user passed any - -> Bool -- ^ Force install - -> Excepts - '[ AlreadyInstalled - , CopyError - , DigestError - , GPGError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist - , ArchiveResult - , FileAlreadyExistsError - , ProcessError - , DirNotEmpty - , UninstallFailed - , MergeFileTreeError - ] - m - () -installHLSBindist dlinfo ver installDir forceInstall = do - lift $ logDebug $ "Requested to install hls version " <> prettyVer ver - - PlatformRequest {..} <- lift getPlatformReq - Dirs {..} <- lift getDirs - - regularHLSInstalled <- lift $ checkIfToolInstalled HLS ver - - if - | not forceInstall - , regularHLSInstalled - , GHCupInternal <- installDir -> do -- regular install - throwE $ AlreadyInstalled HLS ver - - | forceInstall - , regularHLSInstalled - , GHCupInternal <- installDir -> do -- regular forced install - lift $ logInfo "Removing the currently installed version of HLS before force installing!" - liftE $ rmHLSVer ver - - | otherwise -> pure () - - -- download (or use cached version) - dl <- liftE $ downloadCached dlinfo Nothing - - -- unpack - tmpUnpack <- lift withGHCupTmpDir - liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) - - -- the subdir of the archive where we do the work - workdir <- fromGHCupPath <$> maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - legacy <- liftIO $ isLegacyHLSBindist workdir - - if - | not forceInstall - , not legacy - , (IsolateDir fp) <- installDir -> liftE $ installDestSanityCheck (IsolateDirResolved fp) - | otherwise -> pure () - - case installDir of - IsolateDir isoDir -> do - lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir - if legacy - then liftE $ installHLSUnpackedLegacy workdir (IsolateDirResolved isoDir) ver forceInstall - else liftE $ runBuildAction tmpUnpack $ installHLSUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall - - GHCupInternal -> do - if legacy - then liftE $ installHLSUnpackedLegacy workdir (GHCupBinDir binDir) ver forceInstall - else do - inst <- ghcupHLSDir ver - liftE $ runBuildAction tmpUnpack - $ installHLSUnpacked workdir (GHCupDir inst) ver forceInstall - liftE $ setHLS ver SetHLS_XYZ Nothing - - -isLegacyHLSBindist :: FilePath -- ^ Path to the unpacked hls bindist - -> IO Bool -isLegacyHLSBindist path = do - not <$> doesFileExist (path "GNUmakefile") - --- | 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 - , MonadResource m - , HasPlatformReq env - ) - => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) - -> InstallDirResolved -- ^ Path to install to - -> Version - -> Bool - -> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled, MergeFileTreeError] m () -installHLSUnpacked path inst ver forceInstall = do - PlatformRequest { .. } <- lift getPlatformReq - lift $ logInfo "Installing HLS" - tmpInstallDest <- lift withGHCupTmpDir - lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "PREFIX=" <> fromInstallDir inst, "install"] (Just path) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpInstallDest) - liftE $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst)) - inst - HLS - (mkTVer ver) - (\f t -> liftIO $ do - mtime <- ifM (pathIsSymbolicLink f) (pure Nothing) (Just <$> getModificationTime f) - install f t (not forceInstall) - forM_ mtime $ setModificationTime t) - --- | Install an unpacked hls distribution (legacy). -installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m) - => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) - -> InstallDirResolved -- ^ Path to install to - -> Version - -> Bool -- ^ is it a force install - -> Excepts '[CopyError, FileAlreadyExistsError] m () -installHLSUnpackedLegacy path installDir ver forceInstall = do - lift $ logInfo "Installing HLS" - liftIO $ createDirRecursive' (fromInstallDir installDir) - - -- install haskell-language-server- - bins@(_:_) <- liftIO $ findFiles - path - (makeRegexOpts compExtended - execBlank - ([s|^haskell-language-server-[0-9].*$|] :: ByteString) - ) - forM_ bins $ \f -> do - let toF = dropSuffix exeExt f - <> (case installDir of - IsolateDirResolved _ -> "" - _ -> ("~" <>) . T.unpack . prettyVer $ ver - ) - <> exeExt - - let srcPath = path f - let destPath = fromInstallDir installDir toF - - -- destination could be an existing symlink - -- for new make-based HLSes - liftIO $ rmFileForce destPath - - copyFileE - srcPath - destPath - (not forceInstall) - lift $ chmod_755 destPath - - -- install haskell-language-server-wrapper - let wrapper = "haskell-language-server-wrapper" - toF = wrapper - <> (case installDir of - IsolateDirResolved _ -> "" - _ -> ("-" <>) . T.unpack . prettyVer $ ver - ) - <> exeExt - srcWrapperPath = path wrapper <> exeExt - destWrapperPath = fromInstallDir installDir toF - - liftIO $ rmFileForce destWrapperPath - copyFileE - srcWrapperPath - destWrapperPath - (not forceInstall) - - lift $ chmod_755 destWrapperPath - - - --- | Installs hls binaries @haskell-language-server-\@ --- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@. -installHLSBin :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasPlatformReq env - , HasGHCupInfo env - , HasDirs env - , HasSettings env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => Version - -> InstallDir - -> Bool -- force install - -> Excepts - '[ AlreadyInstalled - , CopyError - , DigestError - , GPGError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist - , ArchiveResult - , FileAlreadyExistsError - , ProcessError - , DirNotEmpty - , UninstallFailed - , MergeFileTreeError - ] - m - () -installHLSBin ver installDir forceInstall = do - dlinfo <- liftE $ getDownloadInfo HLS ver - installHLSBindist dlinfo ver installDir forceInstall - - -compileHLS :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasDirs env - , HasSettings env - , HasPlatformReq env - , HasGHCupInfo env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => Either Version GitBranch - -> [Version] - -> Maybe Int - -> Maybe Version - -> InstallDir - -> Maybe (Either FilePath URI) - -> Maybe URI - -> Maybe (Either FilePath [URI]) -- ^ patches - -> [Text] -- ^ additional args to cabal install - -> Excepts '[ NoDownload - , GPGError - , DownloadFailed - , DigestError - , UnknownArchive - , TarDirDoesNotExist - , ArchiveResult - , BuildFailed - , NotInstalled - ] m Version -compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patches cabalArgs = do - PlatformRequest { .. } <- lift getPlatformReq - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - Dirs { .. } <- lift getDirs - - - (workdir, tver) <- case targetHLS of - -- unpack from version tarball - Left tver -> do - lift $ logDebug $ "Requested to compile: " <> prettyVer tver - - -- download source tarball - dlInfo <- - preview (ix HLS % ix tver % viSourceDL % _Just) dls - ?? NoDownload - dl <- liftE $ downloadCached dlInfo Nothing - - -- unpack - tmpUnpack <- lift mkGhcupTmpDir - liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) - - workdir <- maybe (pure tmpUnpack) - (liftE . intoSubdir tmpUnpack) - (view dlSubdir dlInfo) - - pure (workdir, tver) - - -- clone from git - Right GitBranch{..} -> do - tmpUnpack <- lift mkGhcupTmpDir - let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing - tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do - let rep = fromMaybe "https://github.com/haskell/haskell-language-server.git" repo - lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)" - lEM $ git [ "init" ] - lEM $ git [ "remote" - , "add" - , "origin" - , fromString rep ] - - let fetch_args = - [ "fetch" - , "--depth" - , "1" - , "--quiet" - , "origin" - , fromString ref ] - lEM $ git fetch_args - - lEM $ git [ "checkout", "FETCH_HEAD" ] - (Just gpd) <- parseGenericPackageDescriptionMaybe <$> liftIO (B.readFile (fromGHCupPath tmpUnpack "haskell-language-server.cabal")) - pure . (\c -> Version Nothing c [] Nothing) - . NE.fromList . fmap (NE.fromList . (:[]) . digits . fromIntegral) - . versionNumbers - . pkgVersion - . package - . packageDescription - $ gpd - - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) - lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to HLS version " <> prettyVer tver - - pure (tmpUnpack, tver) - - -- the version that's installed may differ from the - -- compiled version, so the user can overwrite it - let installVer = fromMaybe tver ov - - liftE $ runBuildAction - workdir - (reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed $ fromGHCupPath workdir) $ do - let tmpInstallDir = fromGHCupPath workdir "out" - liftIO $ createDirRecursive' tmpInstallDir - - -- apply patches - liftE $ applyAnyPatch patches (fromGHCupPath workdir) - - -- set up project files - cp <- case cabalProject of - Just (Left cp) - | isAbsolute cp -> do - copyFileE cp (fromGHCupPath workdir "cabal.project") False - pure "cabal.project" - | otherwise -> pure (takeFileName cp) - Just (Right uri) -> do - tmpUnpack <- lift withGHCupTmpDir - cp <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack) (Just "cabal.project") False - copyFileE cp (fromGHCupPath workdir "cabal.project") False - pure "cabal.project" - Nothing -> pure "cabal.project" - forM_ cabalProjectLocal $ \uri -> do - tmpUnpack <- lift withGHCupTmpDir - cpl <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack) (Just (cp <.> "local")) False - copyFileE cpl (fromGHCupPath workdir cp <.> "local") False - artifacts <- forM (sort ghcs) $ \ghc -> do - let ghcInstallDir = tmpInstallDir T.unpack (prettyVer ghc) - liftIO $ createDirRecursive' tmpInstallDir - lift $ logInfo $ "Building HLS " <> prettyVer installVer <> " for GHC version " <> prettyVer ghc - liftE $ lEM @_ @'[ProcessError] $ - execLogged "cabal" ( [ "v2-install" - , "-w" - , "ghc-" <> T.unpack (prettyVer ghc) - , "--install-method=copy" - ] ++ - maybe [] (\j -> ["--jobs=" <> show j]) jobs ++ - [ "--overwrite-policy=always" - , "--disable-profiling" - , "--disable-tests" - , "--installdir=" <> ghcInstallDir - , "--project-file=" <> cp - ] ++ fmap T.unpack cabalArgs ++ [ - "exe:haskell-language-server" - , "exe:haskell-language-server-wrapper"] - ) - (Just $ fromGHCupPath workdir) - "cabal" - Nothing - pure ghcInstallDir - - forM_ artifacts $ \artifact -> do - liftIO $ renameFile (artifact "haskell-language-server" <.> exeExt) - (tmpInstallDir "haskell-language-server-" <> takeFileName artifact <.> exeExt) - liftIO $ renameFile (artifact "haskell-language-server-wrapper" <.> exeExt) - (tmpInstallDir "haskell-language-server-wrapper" <.> exeExt) - - case installDir of - IsolateDir isoDir -> do - lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir - liftE $ installHLSUnpackedLegacy tmpInstallDir (IsolateDirResolved isoDir) installVer True - GHCupInternal -> do - liftE $ installHLSUnpackedLegacy tmpInstallDir (GHCupBinDir binDir) installVer True - ) - - pure installVer - - - --- | Installs stack into @~\/.ghcup\/bin/stack-\@ and --- creates a default @stack -> stack-x.y.z.q@ symlink for --- the latest installed version. -installStackBin :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasDirs env - , HasSettings env - , HasPlatformReq env - , HasGHCupInfo env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => Version - -> InstallDir - -> Bool -- ^ Force install - -> Excepts - '[ AlreadyInstalled - , CopyError - , DigestError - , GPGError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist - , ArchiveResult - , FileAlreadyExistsError - ] - m - () -installStackBin ver installDir forceInstall = do - dlinfo <- liftE $ getDownloadInfo Stack ver - installStackBindist dlinfo ver installDir forceInstall - - --- | Like 'installStackBin', except takes the 'DownloadInfo' as --- argument instead of looking it up from 'GHCupDownloads'. -installStackBindist :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasPlatformReq env - , HasDirs env - , HasSettings env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => DownloadInfo - -> Version - -> InstallDir - -> Bool -- ^ Force install - -> Excepts - '[ AlreadyInstalled - , CopyError - , DigestError - , GPGError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist - , ArchiveResult - , FileAlreadyExistsError - ] - m - () -installStackBindist dlinfo ver installDir forceInstall = do - lift $ logDebug $ "Requested to install stack version " <> prettyVer ver - - PlatformRequest {..} <- lift getPlatformReq - Dirs {..} <- lift getDirs - - regularStackInstalled <- lift $ checkIfToolInstalled Stack ver - - if - | not forceInstall - , regularStackInstalled - , GHCupInternal <- installDir -> do - throwE $ AlreadyInstalled Stack ver - - | forceInstall - , regularStackInstalled - , GHCupInternal <- installDir -> do - lift $ logInfo "Removing the currently installed version of Stack first!" - liftE $ rmStackVer ver - - | otherwise -> pure () - - -- download (or use cached version) - dl <- liftE $ downloadCached dlinfo Nothing - - -- unpack - tmpUnpack <- lift withGHCupTmpDir - liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) - - -- the subdir of the archive where we do the work - workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - - case installDir of - IsolateDir isoDir -> do -- isolated install - lift $ logInfo $ "isolated installing Stack to " <> T.pack isoDir - liftE $ installStackUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall - GHCupInternal -> do -- regular install - liftE $ installStackUnpacked workdir (GHCupBinDir binDir) ver forceInstall - - --- | Install an unpacked stack distribution. -installStackUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m) - => GHCupPath -- ^ Path to the unpacked stack bindist (where the executable resides) - -> InstallDirResolved - -> Version - -> Bool -- ^ Force install - -> Excepts '[CopyError, FileAlreadyExistsError] m () -installStackUnpacked path installDir ver forceInstall = do - lift $ logInfo "Installing stack" - let stackFile = "stack" - liftIO $ createDirRecursive' (fromInstallDir installDir) - let destFileName = stackFile - <> (case installDir of - IsolateDirResolved _ -> "" - _ -> ("-" <>) . T.unpack . prettyVer $ ver - ) - <> exeExt - destPath = fromInstallDir installDir destFileName - - copyFileE - (fromGHCupPath path stackFile <> exeExt) - destPath - (not forceInstall) - lift $ chmod_755 destPath - - - --------------------- - --[ Set GHC/cabal ]-- - --------------------- - - - --- | Set GHC symlinks in @~\/.ghcup\/bin@ for the requested GHC version. The behavior depends --- on `SetGHC`: --- --- * SetGHCOnly: @~\/.ghcup\/bin\/ghc -> ~\/.ghcup\/ghc\/\\/bin\/ghc@ --- * SetGHC_XY: @~\/.ghcup\/bin\/ghc-X.Y -> ~\/.ghcup\/ghc\/\\/bin\/ghc@ --- * SetGHC_XYZ: @~\/.ghcup\/bin\/ghc-\ -> ~\/.ghcup\/ghc\/\\/bin\/ghc@ --- --- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\\/share symlink@ --- for 'SetGHCOnly' constructor. -setGHC :: ( MonadReader env m - , HasDirs env - , HasLog env - , MonadThrow m - , MonadFail m - , MonadIO m - , MonadCatch m - , MonadMask m - , MonadUnliftIO m - ) - => GHCTargetVersion - -> SetGHC - -> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin - -- and don't want mess with other versions - -> Excepts '[NotInstalled] m GHCTargetVersion -setGHC ver sghc mBinDir = do - let verS = T.unpack $ prettyVer (_tvVersion ver) - ghcdir <- lift $ ghcupGHCDir ver - - whenM (lift $ not <$> ghcInstalled ver) (throwE (NotInstalled GHC ver)) - - -- symlink destination - binDir <- case mBinDir of - Just x -> pure x - Nothing -> do - Dirs {binDir = f} <- lift getDirs - pure f - - -- first delete the old symlinks (this fixes compatibility issues - -- with old ghcup) - when (isNothing mBinDir) $ - case sghc of - SetGHCOnly -> liftE $ rmPlainGHC (_tvTarget ver) - SetGHC_XY -> liftE $ rmMajorGHCSymlinks ver - SetGHC_XYZ -> liftE $ rmMinorGHCSymlinks ver - - -- for ghc tools (ghc, ghci, haddock, ...) - verfiles <- ghcToolFiles ver - forM_ verfiles $ \file -> do - mTargetFile <- case sghc of - SetGHCOnly -> pure $ Just file - SetGHC_XY -> do - handle - (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing) - $ do - (mj, mi) <- getMajorMinorV (_tvVersion ver) - let major' = intToText mj <> "." <> intToText mi - pure $ Just (file <> "-" <> T.unpack major') - SetGHC_XYZ -> - pure $ Just (file <> "-" <> verS) - - -- create symlink - forM_ mTargetFile $ \targetFile -> do - bindir <- ghcInternalBinDir ver - let fullF = binDir targetFile <> exeExt - fileWithExt = bindir file <> exeExt - destL <- binarySymLinkDestination binDir fileWithExt - lift $ createLink destL fullF - - when (isNothing mBinDir) $ do - -- create symlink for share dir - when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir (fromGHCupPath ghcdir) verS - - when (sghc == SetGHCOnly) $ lift warnAboutHlsCompatibility - - pure ver - - where - - symlinkShareDir :: ( MonadReader env m - , HasDirs env - , MonadIO m - , HasLog env - , MonadCatch m - , MonadMask m - ) - => FilePath - -> String - -> m () - symlinkShareDir ghcdir ver' = do - Dirs {..} <- getDirs - let destdir = fromGHCupPath baseDir - case sghc of - SetGHCOnly -> do - let sharedir = "share" - let fullsharedir = ghcdir sharedir - logDebug $ "Checking for sharedir existence: " <> T.pack fullsharedir - whenM (liftIO $ doesDirectoryExist fullsharedir) $ do - let fullF = destdir sharedir - let targetF = "." "ghc" ver' sharedir - logDebug $ "rm -f " <> T.pack fullF - hideError doesNotExistErrorType $ rmDirectoryLink fullF - logDebug $ "ln -s " <> T.pack targetF <> " " <> T.pack fullF - - if isWindows - then liftIO - -- On windows we need to be more permissive - -- in case symlinks can't be created, be just - -- give up here. This symlink isn't strictly necessary. - $ hideError permissionErrorType - $ hideError illegalOperationErrorType - $ createDirectoryLink targetF fullF - else liftIO - $ createDirectoryLink targetF fullF - _ -> pure () - -unsetGHC :: ( MonadReader env m - , HasDirs env - , HasLog env - , MonadThrow m - , MonadFail m - , MonadIO m - , MonadMask m - ) - => Maybe Text - -> Excepts '[NotInstalled] m () -unsetGHC = rmPlainGHC - - --- | Set the @~\/.ghcup\/bin\/cabal@ symlink. -setCabal :: ( MonadMask m - , MonadReader env m - , HasDirs env - , HasLog env - , MonadFail m - , MonadIO m - , MonadUnliftIO m) - => Version - -> Excepts '[NotInstalled] m () -setCabal ver = do - let targetFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt - - -- symlink destination - Dirs {..} <- lift getDirs - - whenM (liftIO $ not <$> doesFileExist (binDir targetFile)) - $ throwE - $ NotInstalled Cabal (GHCTargetVersion Nothing ver) - - let cabalbin = binDir "cabal" <> exeExt - - -- create link - let destL = targetFile - lift $ createLink destL cabalbin - - pure () - -unsetCabal :: ( MonadMask m - , MonadReader env m - , HasDirs env - , MonadIO m) - => m () -unsetCabal = do - Dirs {..} <- getDirs - let cabalbin = binDir "cabal" <> exeExt - hideError doesNotExistErrorType $ rmLink cabalbin - - --- | Set the haskell-language-server symlinks. -setHLS :: ( MonadReader env m - , HasDirs env - , HasLog env - , MonadIO m - , MonadMask m - , MonadFail m - , MonadUnliftIO m - ) - => Version - -> SetHLS - -> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin - -- and don't want mess with other versions - -> Excepts '[NotInstalled] m () -setHLS ver shls mBinDir = do - whenM (lift $ not <$> hlsInstalled ver) (throwE (NotInstalled HLS (GHCTargetVersion Nothing ver))) - - -- symlink destination - binDir <- case mBinDir of - Just x -> pure x - Nothing -> do - Dirs {binDir = f} <- lift getDirs - pure f - - -- first delete the old symlinks - when (isNothing mBinDir) $ - case shls of - -- not for legacy - SetHLS_XYZ -> liftE $ rmMinorHLSSymlinks ver - -- legacy and new - SetHLSOnly -> liftE rmPlainHLS - - case shls of - -- not for legacy - SetHLS_XYZ -> do - bins <- lift $ hlsInternalServerScripts ver Nothing - - forM_ bins $ \f -> do - let fname = takeFileName f - destL <- binarySymLinkDestination binDir f - let target = if "haskell-language-server-wrapper" `isPrefixOf` fname - then fname <> "-" <> T.unpack (prettyVer ver) <> exeExt - else fname <> "~" <> T.unpack (prettyVer ver) <> exeExt - lift $ createLink destL (binDir target) - - -- legacy and new - SetHLSOnly -> do - -- set haskell-language-server- symlinks - bins <- lift $ hlsServerBinaries ver Nothing - when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver) - - forM_ bins $ \f -> do - let destL = f - let target = (<> exeExt) . head . splitOn "~" $ f - lift $ createLink destL (binDir target) - - -- set haskell-language-server-wrapper symlink - let destL = "haskell-language-server-wrapper-" <> T.unpack (prettyVer ver) <> exeExt - let wrapper = binDir "haskell-language-server-wrapper" <> exeExt - - lift $ createLink destL wrapper - - when (isNothing mBinDir) $ - lift warnAboutHlsCompatibility - - -unsetHLS :: ( MonadMask m - , MonadReader env m - , HasDirs env - , MonadIO m) - => m () -unsetHLS = do - Dirs {..} <- getDirs - let wrapper = binDir "haskell-language-server-wrapper" <> exeExt - bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles' - binDir - (MP.chunk "haskell-language-server-" <* pvp' <* MP.chunk (T.pack exeExt) <* MP.eof) - forM_ bins (hideError doesNotExistErrorType . rmLink . (binDir )) - hideError doesNotExistErrorType $ rmLink wrapper - - --- | Set the @~\/.ghcup\/bin\/stack@ symlink. -setStack :: ( MonadMask m - , MonadReader env m - , HasDirs env - , HasLog env - , MonadThrow m - , MonadFail m - , MonadIO m - , MonadUnliftIO m - ) - => Version - -> Excepts '[NotInstalled] m () -setStack ver = do - let targetFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt - - -- symlink destination - Dirs {..} <- lift getDirs - - whenM (liftIO $ not <$> doesFileExist (binDir targetFile)) - $ throwE - $ NotInstalled Stack (GHCTargetVersion Nothing ver) - - let stackbin = binDir "stack" <> exeExt - - lift $ createLink targetFile stackbin - - pure () - - -unsetStack :: ( MonadMask m - , MonadReader env m - , HasDirs env - , MonadIO m) - => m () -unsetStack = do - Dirs {..} <- getDirs - let stackbin = binDir "stack" <> exeExt - hideError doesNotExistErrorType $ rmLink stackbin - - --- | Warn if the installed and set HLS is not compatible with the installed and --- set GHC version. -warnAboutHlsCompatibility :: ( MonadReader env m - , HasDirs env - , HasLog env - , MonadThrow m - , MonadCatch m - , MonadIO m - ) - => m () -warnAboutHlsCompatibility = do - supportedGHC <- hlsGHCVersions - currentGHC <- fmap _tvVersion <$> ghcSet Nothing - currentHLS <- hlsSet - - case (currentGHC, currentHLS) of - (Just gv, Just hv) | gv `notElem` supportedGHC -> do - logWarn $ - "GHC " <> T.pack (prettyShow gv) <> " is not compatible with " <> - "Haskell Language Server " <> T.pack (prettyShow hv) <> "." <> "\n" <> - "Haskell IDE support may not work until this is fixed." <> "\n" <> - "Install a different HLS version, or install and set one of the following GHCs:" <> "\n" <> - T.pack (prettyShow supportedGHC) - - _ -> return () - - ------------------ - --[ List tools ]-- - ------------------ - - --- | Filter data type for 'listVersions'. -data ListCriteria = ListInstalled - | ListSet - | ListAvailable - deriving Show - --- | A list result describes a single tool version --- and various of its properties. -data ListResult = ListResult - { lTool :: Tool - , lVer :: Version - , lCross :: Maybe Text -- ^ currently only for GHC - , lTag :: [Tag] - , lInstalled :: Bool - , lSet :: Bool -- ^ currently active version - , fromSrc :: Bool -- ^ compiled from source - , lStray :: Bool -- ^ not in download info - , lNoBindist :: Bool -- ^ whether the version is available for this platform/arch - , hlsPowered :: Bool - } - deriving (Eq, Ord, Show) - - --- | Extract all available tool versions and their tags. -availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version VersionInfo -availableToolVersions av tool = view - (at tool % non Map.empty) - av - - --- | List all versions from the download info, as well as stray --- versions. -listVersions :: ( MonadCatch m - , HasLog env - , MonadThrow m - , HasLog env - , MonadIO m - , MonadReader env m - , HasDirs env - , HasPlatformReq env - , HasGHCupInfo env - ) - => Maybe Tool - -> Maybe ListCriteria - -> m [ListResult] -listVersions lt' criteria = do - -- some annoying work to avoid too much repeated IO - cSet <- cabalSet - cabals <- getInstalledCabals - hlsSet' <- hlsSet - hlses <- getInstalledHLSs - sSet <- stackSet - stacks <- getInstalledStacks - - go lt' cSet cabals hlsSet' hlses sSet stacks - where - go lt cSet cabals hlsSet' hlses sSet stacks = do - case lt of - Just t -> do - GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo - -- get versions from GHCupDownloads - let avTools = availableToolVersions dls t - lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses sSet stacks) - - case t of - GHC -> do - slr <- strayGHCs avTools - pure (sort (slr ++ lr)) - Cabal -> do - slr <- strayCabals avTools cSet cabals - pure (sort (slr ++ lr)) - HLS -> do - slr <- strayHLS avTools hlsSet' hlses - pure (sort (slr ++ lr)) - Stack -> do - slr <- strayStacks avTools sSet stacks - pure (sort (slr ++ lr)) - GHCup -> do - let cg = maybeToList $ currentGHCup avTools - pure (sort (cg ++ lr)) - Nothing -> do - ghcvers <- go (Just GHC) cSet cabals hlsSet' hlses sSet stacks - cabalvers <- go (Just Cabal) cSet cabals hlsSet' hlses sSet stacks - hlsvers <- go (Just HLS) cSet cabals hlsSet' hlses sSet stacks - ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses sSet stacks - stackvers <- go (Just Stack) cSet cabals hlsSet' hlses sSet stacks - pure (ghcvers <> cabalvers <> hlsvers <> stackvers <> ghcupvers) - strayGHCs :: ( MonadCatch m - , MonadReader env m - , HasDirs env - , MonadThrow m - , HasLog env - , MonadIO m - ) - => Map.Map Version VersionInfo - -> m [ListResult] - strayGHCs avTools = do - ghcs <- getInstalledGHCs - fmap catMaybes $ forM ghcs $ \case - Right tver@GHCTargetVersion{ _tvTarget = Nothing, .. } -> do - case Map.lookup _tvVersion avTools of - Just _ -> pure Nothing - Nothing -> do - lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing - fromSrc <- ghcSrcInstalled tver - hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions - pure $ Just $ ListResult - { lTool = GHC - , lVer = _tvVersion - , lCross = Nothing - , lTag = [] - , lInstalled = True - , lStray = isNothing (Map.lookup _tvVersion avTools) - , lNoBindist = False - , .. - } - Right tver@GHCTargetVersion{ .. } -> do - lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget - fromSrc <- ghcSrcInstalled tver - hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions - pure $ Just $ ListResult - { lTool = GHC - , lVer = _tvVersion - , lCross = _tvTarget - , lTag = [] - , lInstalled = True - , lStray = True -- NOTE: cross currently cannot be installed via bindist - , lNoBindist = False - , .. - } - Left e -> do - logWarn - $ "Could not parse version of stray directory" <> T.pack e - pure Nothing - - strayCabals :: ( MonadReader env m - , HasDirs env - , MonadCatch m - , MonadThrow m - , HasLog env - , MonadIO m - ) - => Map.Map Version VersionInfo - -> Maybe Version - -> [Either FilePath Version] - -> m [ListResult] - strayCabals avTools cSet cabals = do - fmap catMaybes $ forM cabals $ \case - Right ver -> - case Map.lookup ver avTools of - Just _ -> pure Nothing - Nothing -> do - let lSet = cSet == Just ver - pure $ Just $ ListResult - { lTool = Cabal - , lVer = ver - , lCross = Nothing - , lTag = [] - , lInstalled = True - , lStray = isNothing (Map.lookup ver avTools) - , lNoBindist = False - , fromSrc = False -- actually, we don't know :> - , hlsPowered = False - , .. - } - Left e -> do - logWarn - $ "Could not parse version of stray directory" <> T.pack e - pure Nothing - - strayHLS :: ( MonadReader env m - , HasDirs env - , MonadCatch m - , MonadThrow m - , HasLog env - , MonadIO m) - => Map.Map Version VersionInfo - -> Maybe Version - -> [Either FilePath Version] - -> m [ListResult] - strayHLS avTools hlsSet' hlss = do - fmap catMaybes $ forM hlss $ \case - Right ver -> - case Map.lookup ver avTools of - Just _ -> pure Nothing - Nothing -> do - let lSet = hlsSet' == Just ver - pure $ Just $ ListResult - { lTool = HLS - , lVer = ver - , lCross = Nothing - , lTag = [] - , lInstalled = True - , lStray = isNothing (Map.lookup ver avTools) - , lNoBindist = False - , fromSrc = False -- actually, we don't know :> - , hlsPowered = False - , .. - } - Left e -> do - logWarn - $ "Could not parse version of stray directory" <> T.pack e - pure Nothing - - strayStacks :: ( MonadReader env m - , HasDirs env - , MonadCatch m - , MonadThrow m - , HasLog env - , MonadIO m - ) - => Map.Map Version VersionInfo - -> Maybe Version - -> [Either FilePath Version] - -> m [ListResult] - strayStacks avTools stackSet' stacks = do - fmap catMaybes $ forM stacks $ \case - Right ver -> - case Map.lookup ver avTools of - Just _ -> pure Nothing - Nothing -> do - let lSet = stackSet' == Just ver - pure $ Just $ ListResult - { lTool = Stack - , lVer = ver - , lCross = Nothing - , lTag = [] - , lInstalled = True - , lStray = isNothing (Map.lookup ver avTools) - , lNoBindist = False - , fromSrc = False -- actually, we don't know :> - , hlsPowered = False - , .. - } - Left e -> do - logWarn - $ "Could not parse version of stray directory" <> T.pack e - pure Nothing - - currentGHCup :: Map.Map Version VersionInfo -> Maybe ListResult - currentGHCup av = - let currentVer = fromJust $ pvpToVersion ghcUpVer "" - listVer = Map.lookup currentVer av - latestVer = fst <$> headOf (getTagged Latest) av - recommendedVer = fst <$> headOf (getTagged Latest) av - isOld = maybe True (> currentVer) latestVer && maybe True (> currentVer) recommendedVer - in if | Map.member currentVer av -> Nothing - | otherwise -> Just $ ListResult { lVer = currentVer - , lTag = maybe (if isOld then [Old] else []) _viTags listVer - , lCross = Nothing - , lTool = GHCup - , fromSrc = False - , lStray = isNothing listVer - , lSet = True - , lInstalled = True - , lNoBindist = False - , hlsPowered = False - } - - -- NOTE: this are not cross ones, because no bindists - toListResult :: ( HasLog env - , MonadReader env m - , HasDirs env - , HasGHCupInfo env - , HasPlatformReq env - , MonadIO m - , MonadCatch m - ) - => Tool - -> Maybe Version - -> [Either FilePath Version] - -> Maybe Version - -> [Either FilePath Version] - -> Maybe Version - -> [Either FilePath Version] - -> (Version, VersionInfo) - -> m ListResult - toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, _viTags -> tags) = do - case t of - GHC -> do - lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo GHC v - let tver = mkTVer v - lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing - lInstalled <- ghcInstalled tver - fromSrc <- ghcSrcInstalled tver - hlsPowered <- fmap (elem v) hlsGHCVersions - pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. } - Cabal -> do - lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Cabal v - let lSet = cSet == Just v - let lInstalled = elem v $ rights cabals - pure ListResult { lVer = v - , lCross = Nothing - , lTag = tags - , lTool = t - , fromSrc = False - , lStray = False - , hlsPowered = False - , .. - } - GHCup -> do - let lSet = prettyPVP ghcUpVer == prettyVer v - let lInstalled = lSet - pure ListResult { lVer = v - , lTag = tags - , lCross = Nothing - , lTool = t - , fromSrc = False - , lStray = False - , lNoBindist = False - , hlsPowered = False - , .. - } - HLS -> do - lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo HLS v - let lSet = hlsSet' == Just v - let lInstalled = elem v $ rights hlses - pure ListResult { lVer = v - , lCross = Nothing - , lTag = tags - , lTool = t - , fromSrc = False - , lStray = False - , hlsPowered = False - , .. - } - Stack -> do - lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Stack v - let lSet = stackSet' == Just v - let lInstalled = elem v $ rights stacks - pure ListResult { lVer = v - , lCross = Nothing - , lTag = tags - , lTool = t - , fromSrc = False - , lStray = False - , hlsPowered = False - , .. - } - - - filter' :: [ListResult] -> [ListResult] - filter' lr = case criteria of - Nothing -> lr - Just ListInstalled -> filter (\ListResult {..} -> lInstalled) lr - Just ListSet -> filter (\ListResult {..} -> lSet) lr - Just ListAvailable -> filter (\ListResult {..} -> not lNoBindist) lr - - - - -------------------- - --[ GHC/cabal rm ]-- - -------------------- - - --- | Delete a ghc version and all its symlinks. --- --- This may leave GHCup without a "set" version. --- Will try to fix the ghc-x.y symlink after removal (e.g. to an --- older version). -rmGHCVer :: ( MonadReader env m - , HasDirs env - , MonadThrow m - , HasLog env - , MonadIO m - , MonadFail m - , MonadCatch m - , MonadMask m - , MonadUnliftIO m - ) - => GHCTargetVersion - -> Excepts '[NotInstalled, UninstallFailed] m () -rmGHCVer ver = do - isSetGHC <- lift $ fmap (== Just ver) $ ghcSet (_tvTarget ver) - - whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC ver)) - - -- this isn't atomic, order matters - when isSetGHC $ do - lift $ logInfo "Removing ghc symlinks" - liftE $ rmPlainGHC (_tvTarget ver) - - lift $ logInfo "Removing ghc-x.y.z symlinks" - liftE $ rmMinorGHCSymlinks ver - - lift $ logInfo "Removing/rewiring ghc-x.y symlinks" - -- first remove - handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorGHCSymlinks ver - -- then fix them (e.g. with an earlier version) - - dir' <- lift $ ghcupGHCDir ver - let dir = fromGHCupPath dir' - lift (getInstalledFiles GHC ver) >>= \case - Just files -> do - lift $ logInfo $ "Removing files safely from: " <> T.pack dir - forM_ files (lift . hideError NoSuchThing . recycleFile . (\f -> dir dropDrive f)) - removeEmptyDirsRecursive dir - survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory dir - f <- recordedInstallationFile GHC ver - lift $ recycleFile f - when (not (null survivors)) $ throwE $ UninstallFailed dir survivors - Nothing -> do - lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack dir - lift $ recyclePathForcibly dir' - - v' <- - handle - (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing) - $ fmap Just - $ getMajorMinorV (_tvVersion ver) - forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) (_tvTarget ver)) - >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY Nothing) - - Dirs {..} <- lift getDirs - - lift $ hideError doesNotExistErrorType $ rmDirectoryLink (fromGHCupPath baseDir "share") - - --- | Delete a cabal version. Will try to fix the @cabal@ symlink --- after removal (e.g. setting it to an older version). -rmCabalVer :: ( MonadMask m - , MonadReader env m - , HasDirs env - , MonadThrow m - , HasLog env - , MonadIO m - , MonadFail m - , MonadCatch m - , MonadUnliftIO m - ) - => Version - -> Excepts '[NotInstalled] m () -rmCabalVer ver = do - whenM (lift $ fmap not $ cabalInstalled ver) $ throwE (NotInstalled Cabal (GHCTargetVersion Nothing ver)) - - cSet <- lift cabalSet - - Dirs {..} <- lift getDirs - - let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt - lift $ hideError doesNotExistErrorType $ recycleFile (binDir cabalFile) - - when (Just ver == cSet) $ do - cVers <- lift $ fmap rights getInstalledCabals - case headMay . reverse . sort $ cVers of - Just latestver -> setCabal latestver - Nothing -> lift $ rmLink (binDir "cabal" <> exeExt) - - --- | Delete a hls version. Will try to fix the hls symlinks --- after removal (e.g. setting it to an older version). -rmHLSVer :: ( MonadMask m - , MonadReader env m - , HasDirs env - , MonadThrow m - , HasLog env - , MonadIO m - , MonadFail m - , MonadCatch m - , MonadUnliftIO m - ) - => Version - -> Excepts '[NotInstalled, UninstallFailed] m () -rmHLSVer ver = do - whenM (lift $ fmap not $ hlsInstalled ver) $ throwE (NotInstalled HLS (GHCTargetVersion Nothing ver)) - - isHlsSet <- lift hlsSet - - liftE $ rmMinorHLSSymlinks ver - - when (Just ver == isHlsSet) $ do - -- delete all set symlinks - liftE rmPlainHLS - - hlsDir' <- ghcupHLSDir ver - let hlsDir = fromGHCupPath hlsDir' - lift (getInstalledFiles HLS (mkTVer ver)) >>= \case - Just files -> do - lift $ logInfo $ "Removing files safely from: " <> T.pack hlsDir - forM_ files (lift . hideError NoSuchThing . recycleFile . (\f -> hlsDir dropDrive f)) - removeEmptyDirsRecursive hlsDir - survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory hlsDir - f <- recordedInstallationFile HLS (mkTVer ver) - lift $ recycleFile f - 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 - hlsVers <- lift $ fmap rights getInstalledHLSs - case headMay . reverse . sort $ hlsVers of - Just latestver -> liftE $ setHLS latestver SetHLSOnly Nothing - Nothing -> pure () - - --- | Delete a stack version. Will try to fix the @stack@ symlink --- after removal (e.g. setting it to an older version). -rmStackVer :: ( MonadMask m - , MonadReader env m - , HasDirs env - , MonadThrow m - , HasLog env - , MonadIO m - , MonadFail m - , MonadCatch m - , MonadUnliftIO m - ) - => Version - -> Excepts '[NotInstalled] m () -rmStackVer ver = do - whenM (lift $ fmap not $ stackInstalled ver) $ throwE (NotInstalled Stack (GHCTargetVersion Nothing ver)) - - sSet <- lift stackSet - - Dirs {..} <- lift getDirs - - let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt - lift $ hideError doesNotExistErrorType $ recycleFile (binDir stackFile) - - when (Just ver == sSet) $ do - sVers <- lift $ fmap rights getInstalledStacks - case headMay . reverse . sort $ sVers of - Just latestver -> setStack latestver - Nothing -> lift $ rmLink (binDir "stack" <> exeExt) - - --- assuming the current scheme of having just 1 ghcup bin, no version info is required. -rmGhcup :: ( MonadReader env m - , HasDirs env - , MonadIO m - , MonadCatch m - , HasLog env - , MonadMask m - , MonadUnliftIO m - ) - => m () -rmGhcup = do - Dirs { .. } <- getDirs - let ghcupFilename = "ghcup" <> exeExt - let ghcupFilepath = binDir ghcupFilename - - currentRunningExecPath <- liftIO getExecutablePath - - -- if paths do no exist, warn user, and continue to compare them, as is, - -- which should eventually fail and result in a non-standard install warning - - p1 <- handleIO' doesNotExistErrorType - (handlePathNotPresent currentRunningExecPath) - (liftIO $ canonicalizePath currentRunningExecPath) - - p2 <- handleIO' doesNotExistErrorType - (handlePathNotPresent ghcupFilepath) - (liftIO $ canonicalizePath ghcupFilepath) - - let areEqualPaths = equalFilePath p1 p2 - - unless areEqualPaths $ logWarn $ nonStandardInstallLocationMsg currentRunningExecPath - - if isWindows - then do - -- since it doesn't seem possible to delete a running exe on windows - -- we move it to temp dir, to be deleted at next reboot - tempFilepath <- mkGhcupTmpDir - hideError UnsupportedOperation $ - liftIO $ hideError NoSuchThing $ - moveFile ghcupFilepath (fromGHCupPath tempFilepath "ghcup") - else - -- delete it. - hideError doesNotExistErrorType $ rmFile ghcupFilepath - - where - handlePathNotPresent fp _err = do - logDebug $ "Error: The path does not exist, " <> T.pack fp - pure fp - - nonStandardInstallLocationMsg path = T.pack $ - "current ghcup is invoked from a non-standard location: \n" - <> path <> - "\n you may have to uninstall it manually." - rmTool :: ( MonadReader env m , HasDirs env , HasLog env @@ -2135,480 +258,9 @@ getDebugInfo = do - --------------- - --[ Compile ]-- - --------------- - - --- | Compile a GHC from source. This behaves wrt symlinks and installation --- the same as 'installGHCBin'. -compileGHC :: ( MonadMask m - , MonadReader env m - , HasDirs env - , HasPlatformReq env - , HasGHCupInfo env - , HasSettings env - , MonadThrow m - , MonadResource m - , HasLog env - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => Either GHCTargetVersion GitBranch -- ^ version to install - -> Maybe Version -- ^ overwrite version - -> Either Version FilePath -- ^ version to bootstrap with - -> Maybe Int -- ^ jobs - -> Maybe FilePath -- ^ build config - -> Maybe (Either FilePath [URI]) -- ^ patches - -> [Text] -- ^ additional args to ./configure - -> Maybe String -- ^ build flavour - -> Bool - -> InstallDir - -> Excepts - '[ AlreadyInstalled - , BuildFailed - , DigestError - , GPGError - , DownloadFailed - , GHCupSetError - , NoDownload - , NotFoundInPATH - , PatchFailed - , UnknownArchive - , TarDirDoesNotExist - , NotInstalled - , DirNotEmpty - , ArchiveResult - , FileDoesNotExistError - , HadrianNotFound - , InvalidBuildConfig - , ProcessError - , CopyError - , BuildFailed - , UninstallFailed - , MergeFileTreeError - ] - m - GHCTargetVersion -compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian installDir - = do - PlatformRequest { .. } <- lift getPlatformReq - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - - (workdir, tmpUnpack, tver) <- case targetGhc of - -- unpack from version tarball - Left tver -> do - lift $ logDebug $ "Requested to compile: " <> tVerToText tver <> " with " <> either prettyVer T.pack bstrap - - -- download source tarball - dlInfo <- - preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls - ?? NoDownload - dl <- liftE $ downloadCached dlInfo Nothing - - -- unpack - tmpUnpack <- lift mkGhcupTmpDir - liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform $ fromGHCupPath tmpUnpack - - workdir <- maybe (pure tmpUnpack) - (liftE . intoSubdir tmpUnpack) - (view dlSubdir dlInfo) - liftE $ applyAnyPatch patches (fromGHCupPath workdir) - - pure (workdir, tmpUnpack, tver) - - -- clone from git - Right GitBranch{..} -> do - tmpUnpack <- lift mkGhcupTmpDir - let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing - tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] DownloadFailed $ do - let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo - lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)" - lEM $ git [ "init" ] - lEM $ git [ "remote" - , "add" - , "origin" - , fromString rep ] - - let fetch_args = - [ "fetch" - , "--depth" - , "1" - , "--quiet" - , "origin" - , fromString ref ] - lEM $ git fetch_args - - lEM $ git [ "checkout", "FETCH_HEAD" ] - lEM $ git [ "submodule", "update", "--init", "--depth", "1" ] - liftE $ applyAnyPatch patches (fromGHCupPath tmpUnpack) - lEM $ execWithGhcEnv "python3" ["./boot"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" - lEM $ execWithGhcEnv "sh" ["./configure"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" - CapturedProcess {..} <- lift $ makeOut - ["show!", "--quiet", "VALUE=ProjectVersion" ] (Just $ fromGHCupPath tmpUnpack) - case _exitCode of - ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . decUTF8Safe' $ _stdOut - ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr)) - - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) - lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to GHC version " <> prettyVer tver - - pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver) - -- the version that's installed may differ from the - -- compiled version, so the user can overwrite it - let installVer = maybe tver (\ov' -> tver { _tvVersion = ov' }) ov - - alreadyInstalled <- lift $ ghcInstalled installVer - alreadySet <- fmap (== Just installVer) $ lift $ ghcSet (_tvTarget installVer) - - when alreadyInstalled $ do - case installDir of - IsolateDir isoDir -> - lift $ logWarn $ "GHC " <> T.pack (prettyShow installVer) <> " already installed. Isolate installing to " <> T.pack isoDir - GHCupInternal -> - lift $ logWarn $ "GHC " <> T.pack (prettyShow installVer) <> " already installed. Will overwrite existing version." - lift $ logWarn - "...waiting for 10 seconds before continuing, you can still abort..." - liftIO $ threadDelay 10000000 -- give the user a sec to intervene - - ghcdir <- case installDir of - IsolateDir isoDir -> pure $ IsolateDirResolved isoDir - GHCupInternal -> GHCupDir <$> lift (ghcupGHCDir installVer) - - (mBindist, bmk) <- liftE $ runBuildAction - tmpUnpack - (do - b <- if hadrian - then compileHadrianBindist tver (fromGHCupPath workdir) ghcdir - else compileMakeBindist tver (fromGHCupPath workdir) ghcdir - bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk $ fromGHCupPath workdir) - pure (b, bmk) - ) - - case installDir of - GHCupInternal -> - -- only remove old ghc in regular installs - when alreadyInstalled $ do - lift $ logInfo "Deleting existing installation" - liftE $ rmGHCVer installVer - - _ -> pure () - - forM_ mBindist $ \bindist -> do - liftE $ installPackedGHC bindist - (Just $ RegexDir "ghc-.*") - ghcdir - (installVer ^. tvVersion) - False -- not a force install, since we already overwrite when compiling. - - liftIO $ B.writeFile (fromInstallDir ghcdir ghcUpSrcBuiltFile) bmk - - case installDir of - -- set and make symlinks for regular (non-isolated) installs - GHCupInternal -> do - reThrowAll GHCupSetError $ postGHCInstall installVer - -- restore - when alreadySet $ liftE $ void $ setGHC installVer SetGHCOnly Nothing - - _ -> pure () - - pure installVer - - where - defaultConf = - let cross_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/cross" >> runIO (readFile "data/build_mk/cross"))) - default_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/default" >> runIO (readFile "data/build_mk/default"))) - in case targetGhc of - Left (GHCTargetVersion (Just _) _) -> cross_mk - _ -> default_mk - - compileHadrianBindist :: ( MonadReader env m - , HasDirs env - , HasSettings env - , HasPlatformReq env - , MonadThrow m - , MonadCatch m - , HasLog env - , MonadIO m - , MonadFail m - ) - => GHCTargetVersion - -> FilePath - -> InstallDirResolved - -> Excepts - '[ FileDoesNotExistError - , HadrianNotFound - , InvalidBuildConfig - , PatchFailed - , ProcessError - , NotFoundInPATH - , CopyError] - m - (Maybe FilePath) -- ^ output path of bindist, None for cross - compileHadrianBindist tver workdir ghcdir = do - lEM $ execWithGhcEnv "python3" ["./boot"] (Just workdir) "ghc-bootstrap" - - liftE $ configureBindist tver workdir ghcdir - - lift $ logInfo "Building (this may take a while)..." - hadrian_build <- liftE $ findHadrianFile workdir - lEM $ execWithGhcEnv hadrian_build - ( maybe [] (\j -> ["-j" <> show j] ) jobs - ++ maybe [] (\bf -> ["--flavour=" <> bf]) buildFlavour - ++ ["binary-dist"] - ) - (Just workdir) "ghc-make" - [tar] <- liftIO $ findFiles - (workdir "_build" "bindist") - (makeRegexOpts compExtended - execBlank - ([s|^ghc-.*\.tar\..*$|] :: ByteString) - ) - liftE $ fmap Just $ copyBindist tver tar (workdir "_build" "bindist") - - findHadrianFile :: (MonadIO m) - => FilePath - -> Excepts - '[HadrianNotFound] - m - FilePath - findHadrianFile workdir = do - let possible_files = if isWindows - then ((workdir "hadrian") ) <$> ["build.bat"] - else ((workdir "hadrian") ) <$> ["build", "build.sh"] - exsists <- forM possible_files (\f -> liftIO (doesFileExist f) <&> (,f)) - case filter fst exsists of - [] -> throwE HadrianNotFound - ((_, x):_) -> pure x - - compileMakeBindist :: ( MonadReader env m - , HasDirs env - , HasSettings env - , HasPlatformReq env - , MonadThrow m - , MonadCatch m - , HasLog env - , MonadIO m - , MonadFail m - ) - => GHCTargetVersion - -> FilePath - -> InstallDirResolved - -> Excepts - '[ FileDoesNotExistError - , HadrianNotFound - , InvalidBuildConfig - , PatchFailed - , ProcessError - , NotFoundInPATH - , CopyError] - m - (Maybe FilePath) -- ^ output path of bindist, None for cross - compileMakeBindist tver workdir ghcdir = do - liftE $ configureBindist tver workdir ghcdir - - case mbuildConfig of - Just bc -> liftIOException - doesNotExistErrorType - (FileDoesNotExistError bc) - (liftIO $ copyFile bc (build_mk workdir) False) - Nothing -> - liftIO $ T.writeFile (build_mk workdir) (addBuildFlavourToConf defaultConf) - - liftE $ checkBuildConfig (build_mk workdir) - - lift $ logInfo "Building (this may take a while)..." - lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir) - - if | isCross tver -> do - lift $ logInfo "Installing cross toolchain..." - lEM $ make ["install"] (Just workdir) - pure Nothing - | otherwise -> do - lift $ logInfo "Creating bindist..." - lEM $ make ["binary-dist"] (Just workdir) - [tar] <- liftIO $ findFiles - workdir - (makeRegexOpts compExtended - execBlank - ([s|^ghc-.*\.tar\..*$|] :: ByteString) - ) - liftE $ fmap Just $ copyBindist tver tar workdir - - build_mk workdir = workdir "mk" "build.mk" - - copyBindist :: ( MonadReader env m - , HasDirs env - , HasSettings env - , HasPlatformReq env - , MonadIO m - , MonadThrow m - , MonadCatch m - , HasLog env - ) - => GHCTargetVersion - -> FilePath -- ^ tar file - -> FilePath -- ^ workdir - -> Excepts - '[CopyError] - m - FilePath - copyBindist tver tar workdir = do - Dirs {..} <- lift getDirs - pfreq <- lift getPlatformReq - c <- liftIO $ BL.readFile (workdir tar) - cDigest <- - fmap (T.take 8) - . lift - . throwEither - . E.decodeUtf8' - . B16.encode - . SHA256.hashlazy - $ c - cTime <- liftIO getCurrentTime - let tarName = makeValid ("ghc-" - <> T.unpack (tVerToText tver) - <> "-" - <> pfReqToString pfreq - <> "-" - <> iso8601Show cTime - <> "-" - <> T.unpack cDigest - <> ".tar" - <> takeExtension tar) - let tarPath = fromGHCupPath cacheDir tarName - copyFileE (workdir tar) tarPath False - lift $ logInfo $ "Copied bindist to " <> T.pack tarPath - pure tarPath - - checkBuildConfig :: (MonadReader env m, MonadCatch m, MonadIO m, HasLog env) - => FilePath - -> Excepts - '[FileDoesNotExistError, InvalidBuildConfig] - m - () - checkBuildConfig bc = do - c <- liftIOException - doesNotExistErrorType - (FileDoesNotExistError bc) - (liftIO $ B.readFile bc) - let lines' = fmap T.strip . T.lines $ decUTF8Safe c - - -- for cross, we need Stage1Only - case targetGhc of - Left (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE - (InvalidBuildConfig - [s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|] - ) - _ -> pure () - - forM_ buildFlavour $ \bf -> - when (T.pack ("BuildFlavour = " <> bf) `notElem` lines') $ do - lift $ logWarn $ "Customly specified build config overwrites --flavour=" <> T.pack bf <> " switch! Waiting 5 seconds..." - liftIO $ threadDelay 5000000 - - addBuildFlavourToConf bc = case buildFlavour of - Just bf -> "BuildFlavour = " <> T.pack bf <> "\n" <> bc - Nothing -> bc - - isCross :: GHCTargetVersion -> Bool - isCross = isJust . _tvTarget - - - configureBindist :: ( MonadReader env m - , HasDirs env - , HasSettings env - , HasPlatformReq env - , MonadThrow m - , MonadCatch m - , HasLog env - , MonadIO m - , MonadFail m - ) - => GHCTargetVersion - -> FilePath - -> InstallDirResolved - -> Excepts - '[ FileDoesNotExistError - , InvalidBuildConfig - , PatchFailed - , ProcessError - , NotFoundInPATH - , CopyError - ] - m - () - configureBindist tver workdir (fromInstallDir -> ghcdir) = do - lift $ logInfo [s|configuring build|] - - if | _tvVersion tver >= [vver|8.8.0|] -> do - lEM $ execWithGhcEnv - "sh" - ("./configure" : maybe mempty - (\x -> ["--target=" <> T.unpack x]) - (_tvTarget tver) - ++ ["--prefix=" <> ghcdir] - ++ (if isWindows then ["--enable-tarballs-autodownload"] else []) - ++ fmap T.unpack aargs - ) - (Just workdir) - "ghc-conf" - | otherwise -> do - lEM $ execLogged - "sh" - ( [ "./configure", "--with-ghc=" <> either id id bghc - ] - ++ maybe mempty - (\x -> ["--target=" <> T.unpack x]) - (_tvTarget tver) - ++ ["--prefix=" <> ghcdir] - ++ (if isWindows then ["--enable-tarballs-autodownload"] else []) - ++ fmap T.unpack aargs - ) - (Just workdir) - "ghc-conf" - Nothing - pure () - - execWithGhcEnv :: ( MonadReader env m - , HasSettings env - , HasDirs env - , HasLog env - , MonadIO m - , MonadThrow m) - => FilePath -- ^ thing to execute - -> [String] -- ^ args for the thing - -> Maybe FilePath -- ^ optionally chdir into this - -> FilePath -- ^ log filename (opened in append mode) - -> m (Either ProcessError ()) - execWithGhcEnv fp args dir logf = do - env <- ghcEnv - execLogged fp args dir logf (Just env) - - bghc = case bstrap of - Right g -> Right g - Left bver -> Left ("ghc-" <> (T.unpack . prettyVer $ bver) <> exeExt) - - ghcEnv :: (MonadThrow m, MonadIO m) => m [(String, String)] - ghcEnv = do - cEnv <- liftIO getEnvironment - bghcPath <- case bghc of - Right ghc' -> pure ghc' - Left bver -> do - spaths <- liftIO getSearchPath - throwMaybeM (NotFoundInPATH bver) $ liftIO (searchPath spaths bver) - pure (("GHC", bghcPath) : cEnv) - - - - - - - --------------------- - --[ Upgrade GHCup ]-- - --------------------- + ------------------------- + --[ GHCup upgrade etc ]-- + ------------------------- -- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@, @@ -2685,38 +337,66 @@ upgradeGHCup mtarget force' fatal = do pure latestVer +-- assuming the current scheme of having just 1 ghcup bin, no version info is required. +rmGhcup :: ( MonadReader env m + , HasDirs env + , MonadIO m + , MonadCatch m + , HasLog env + , MonadMask m + , MonadUnliftIO m + ) + => m () +rmGhcup = do + Dirs { .. } <- getDirs + let ghcupFilename = "ghcup" <> exeExt + let ghcupFilepath = binDir ghcupFilename - ------------- - --[ Other ]-- - ------------- + currentRunningExecPath <- liftIO getExecutablePath + + -- if paths do no exist, warn user, and continue to compare them, as is, + -- which should eventually fail and result in a non-standard install warning + + p1 <- handleIO' doesNotExistErrorType + (handlePathNotPresent currentRunningExecPath) + (liftIO $ canonicalizePath currentRunningExecPath) + + p2 <- handleIO' doesNotExistErrorType + (handlePathNotPresent ghcupFilepath) + (liftIO $ canonicalizePath ghcupFilepath) + + let areEqualPaths = equalFilePath p1 p2 + + unless areEqualPaths $ logWarn $ nonStandardInstallLocationMsg currentRunningExecPath + + if isWindows + then do + -- since it doesn't seem possible to delete a running exe on windows + -- we move it to temp dir, to be deleted at next reboot + tempFilepath <- mkGhcupTmpDir + hideError UnsupportedOperation $ + liftIO $ hideError NoSuchThing $ + moveFile ghcupFilepath (fromGHCupPath tempFilepath "ghcup") + else + -- delete it. + hideError doesNotExistErrorType $ rmFile ghcupFilepath + + where + handlePathNotPresent fp _err = do + logDebug $ "Error: The path does not exist, " <> T.pack fp + pure fp + + nonStandardInstallLocationMsg path = T.pack $ + "current ghcup is invoked from a non-standard location: \n" + <> path <> + "\n you may have to uninstall it manually." --- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for --- both installing from source and bindist. -postGHCInstall :: ( MonadReader env m - , HasDirs env - , HasLog env - , MonadThrow m - , MonadFail m - , MonadIO m - , MonadCatch m - , MonadMask m - , MonadUnliftIO m - ) - => GHCTargetVersion - -> Excepts '[NotInstalled] m () -postGHCInstall ver@GHCTargetVersion {..} = do - void $ liftE $ setGHC ver SetGHC_XYZ Nothing + --------------- + --[ Whereis ]-- + --------------- - -- Create ghc-x.y symlinks. This may not be the current - -- version, create it regardless. - v' <- - handle (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing) - $ fmap Just - $ getMajorMinorV _tvVersion - forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) _tvTarget) - >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY Nothing) -- | Reports the binary location of a given tool: @@ -2769,6 +449,7 @@ whereIsTool tool ver@GHCTargetVersion {..} = do currentRunningExecPath <- liftIO getExecutablePath liftIO $ canonicalizePath currentRunningExecPath + -- | Doesn't work for cross GHC. checkIfToolInstalled :: ( MonadIO m , MonadReader env m @@ -2779,6 +460,7 @@ checkIfToolInstalled :: ( MonadIO m m Bool checkIfToolInstalled tool ver = checkIfToolInstalled' tool (mkTVer ver) + checkIfToolInstalled' :: ( MonadIO m , MonadReader env m , HasDirs env @@ -2794,12 +476,6 @@ checkIfToolInstalled' tool ver = GHC -> ghcInstalled ver _ -> pure False -throwIfFileAlreadyExists :: ( MonadIO m ) => - FilePath -> - Excepts '[FileAlreadyExistsError] m () - -throwIfFileAlreadyExists fp = whenM (checkFileAlreadyExists fp) - (throwE $ FileAlreadyExistsError fp) @@ -2938,23 +614,3 @@ rmTmp = do rmPathForcibly f -applyAnyPatch :: ( MonadReader env m - , HasDirs env - , HasLog env - , HasSettings env - , MonadUnliftIO m - , MonadCatch m - , MonadResource m - , MonadThrow m - , MonadMask m - , MonadIO m) - => Maybe (Either FilePath [URI]) - -> FilePath - -> Excepts '[PatchFailed, DownloadFailed, DigestError, GPGError] m () -applyAnyPatch Nothing _ = pure () -applyAnyPatch (Just (Left pdir)) workdir = liftE $ applyPatches pdir workdir -applyAnyPatch (Just (Right uris)) workdir = do - tmpUnpack <- fromGHCupPath <$> lift withGHCupTmpDir - forM_ uris $ \uri -> do - patch <- liftE $ download uri Nothing Nothing tmpUnpack Nothing False - liftE $ applyPatch patch workdir diff --git a/lib/GHCup/Cabal.hs b/lib/GHCup/Cabal.hs new file mode 100644 index 0000000..9f6fe67 --- /dev/null +++ b/lib/GHCup/Cabal.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : GHCup.Cabal +Description : GHCup installation functions for Cabal +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable +-} +module GHCup.Cabal where + +import GHCup.Download +import GHCup.Errors +import GHCup.Types +import GHCup.Types.JSON ( ) +import GHCup.Types.Optics +import GHCup.Utils +import GHCup.Prelude +import GHCup.Prelude.File +import GHCup.Prelude.Logger + +import Codec.Archive ( ArchiveResult ) +import Control.Applicative +import Control.Exception.Safe +import Control.Monad +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource + hiding ( throwM ) +import Data.Either +import Data.List +import Data.Maybe +import Data.Versions hiding ( patch ) +import Haskus.Utils.Variant.Excepts +import Optics +import Prelude hiding ( abs + , writeFile + ) +import Safe hiding ( at ) +import System.FilePath +import System.IO.Error + +import qualified Data.Text as T + + + + ------------------------- + --[ Tool installation ]-- + ------------------------- + + +-- | Like 'installCabalBin', except takes the 'DownloadInfo' as +-- argument instead of looking it up from 'GHCupDownloads'. +installCabalBindist :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasPlatformReq env + , HasDirs env + , HasSettings env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => DownloadInfo + -> Version + -> InstallDir + -> Bool -- ^ Force install + -> Excepts + '[ AlreadyInstalled + , CopyError + , DigestError + , GPGError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist + , ArchiveResult + , FileAlreadyExistsError + ] + m + () +installCabalBindist dlinfo ver installDir forceInstall = do + lift $ logDebug $ "Requested to install cabal version " <> prettyVer ver + + PlatformRequest {..} <- lift getPlatformReq + Dirs {..} <- lift getDirs + + -- check if we already have a regular cabal already installed + regularCabalInstalled <- lift $ cabalInstalled ver + + if + | not forceInstall + , regularCabalInstalled + , GHCupInternal <- installDir -> do + throwE $ AlreadyInstalled Cabal ver + + | forceInstall + , regularCabalInstalled + , GHCupInternal <- installDir -> do + lift $ logInfo "Removing the currently installed version first!" + liftE $ rmCabalVer ver + + | otherwise -> pure () + + + -- download (or use cached version) + dl <- liftE $ downloadCached dlinfo Nothing + + -- unpack + tmpUnpack <- lift withGHCupTmpDir + liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) + + -- the subdir of the archive where we do the work + workdir <- fromGHCupPath <$> maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) + + case installDir of + IsolateDir isoDir -> do -- isolated install + lift $ logInfo $ "isolated installing Cabal to " <> T.pack isoDir + liftE $ installCabalUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall + + GHCupInternal -> do -- regular install + liftE $ installCabalUnpacked workdir (GHCupBinDir binDir) ver forceInstall + + +-- | Install an unpacked cabal distribution.Symbol +installCabalUnpacked :: (MonadCatch m, HasLog env, MonadIO m, MonadReader env m) + => FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides) + -> InstallDirResolved -- ^ Path to install to + -> Version + -> Bool -- ^ Force Install + -> Excepts '[CopyError, FileAlreadyExistsError] m () +installCabalUnpacked path inst ver forceInstall = do + lift $ logInfo "Installing cabal" + let cabalFile = "cabal" + liftIO $ createDirRecursive' (fromInstallDir inst) + let destFileName = cabalFile + <> (case inst of + IsolateDirResolved _ -> "" + _ -> ("-" <>) . T.unpack . prettyVer $ ver + ) + <> exeExt + let destPath = fromInstallDir inst destFileName + + copyFileE + (path cabalFile <> exeExt) + destPath + (not forceInstall) + lift $ chmod_755 destPath + +-- | Installs cabal into @~\/.ghcup\/bin/cabal-\@ and +-- creates a default @cabal -> cabal-x.y.z.q@ symlink for +-- the latest installed version. +installCabalBin :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasPlatformReq env + , HasGHCupInfo env + , HasDirs env + , HasSettings env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => Version + -> InstallDir + -> Bool -- force install + -> Excepts + '[ AlreadyInstalled + , CopyError + , DigestError + , GPGError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist + , ArchiveResult + , FileAlreadyExistsError + ] + m + () +installCabalBin ver installDir forceInstall = do + dlinfo <- liftE $ getDownloadInfo Cabal ver + installCabalBindist dlinfo ver installDir forceInstall + + + ----------------- + --[ Set cabal ]-- + ----------------- + + +-- | Set the @~\/.ghcup\/bin\/cabal@ symlink. +setCabal :: ( MonadMask m + , MonadReader env m + , HasDirs env + , HasLog env + , MonadFail m + , MonadIO m + , MonadUnliftIO m) + => Version + -> Excepts '[NotInstalled] m () +setCabal ver = do + let targetFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt + + -- symlink destination + Dirs {..} <- lift getDirs + + whenM (liftIO $ not <$> doesFileExist (binDir targetFile)) + $ throwE + $ NotInstalled Cabal (GHCTargetVersion Nothing ver) + + let cabalbin = binDir "cabal" <> exeExt + + -- create link + let destL = targetFile + lift $ createLink destL cabalbin + + pure () + +unsetCabal :: ( MonadMask m + , MonadReader env m + , HasDirs env + , MonadIO m) + => m () +unsetCabal = do + Dirs {..} <- getDirs + let cabalbin = binDir "cabal" <> exeExt + hideError doesNotExistErrorType $ rmLink cabalbin + + + ---------------- + --[ Rm cabal ]-- + ---------------- + + +-- | Delete a cabal version. Will try to fix the @cabal@ symlink +-- after removal (e.g. setting it to an older version). +rmCabalVer :: ( MonadMask m + , MonadReader env m + , HasDirs env + , MonadThrow m + , HasLog env + , MonadIO m + , MonadFail m + , MonadCatch m + , MonadUnliftIO m + ) + => Version + -> Excepts '[NotInstalled] m () +rmCabalVer ver = do + whenM (lift $ fmap not $ cabalInstalled ver) $ throwE (NotInstalled Cabal (GHCTargetVersion Nothing ver)) + + cSet <- lift cabalSet + + Dirs {..} <- lift getDirs + + let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt + lift $ hideError doesNotExistErrorType $ recycleFile (binDir cabalFile) + + when (Just ver == cSet) $ do + cVers <- lift $ fmap rights getInstalledCabals + case headMay . reverse . sort $ cVers of + Just latestver -> setCabal latestver + Nothing -> lift $ rmLink (binDir "cabal" <> exeExt) diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index c768a47..382f6bc 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -34,9 +34,10 @@ import GHCup.Types import GHCup.Types.Optics import GHCup.Types.JSON ( ) import GHCup.Utils.Dirs -import GHCup.Utils.File -import GHCup.Utils.Logger -import GHCup.Utils.Prelude +import GHCup.Prelude +import GHCup.Prelude.File +import GHCup.Prelude.Logger.Internal +import GHCup.Prelude.Process import GHCup.Version import Control.Applicative diff --git a/lib/GHCup/Download/IOStreams.hs b/lib/GHCup/Download/IOStreams.hs index 9682a64..8f96f38 100644 --- a/lib/GHCup/Download/IOStreams.hs +++ b/lib/GHCup/Download/IOStreams.hs @@ -10,7 +10,7 @@ module GHCup.Download.IOStreams where import GHCup.Download.Utils import GHCup.Errors import GHCup.Types.JSON ( ) -import GHCup.Utils.Prelude +import GHCup.Prelude import Control.Applicative import Control.Exception.Safe diff --git a/lib/GHCup/Download/Utils.hs b/lib/GHCup/Download/Utils.hs index 7a7e3ba..ba5cdaf 100644 --- a/lib/GHCup/Download/Utils.hs +++ b/lib/GHCup/Download/Utils.hs @@ -10,7 +10,7 @@ module GHCup.Download.Utils where import GHCup.Errors import GHCup.Types.Optics import GHCup.Types.JSON ( ) -import GHCup.Utils.Prelude +import GHCup.Prelude import Control.Applicative import Control.Monad diff --git a/lib/GHCup/GHC.hs b/lib/GHCup/GHC.hs new file mode 100644 index 0000000..0e8ea65 --- /dev/null +++ b/lib/GHCup/GHC.hs @@ -0,0 +1,1078 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +{-| +Module : GHCup.GHC +Description : GHCup installation functions for GHC +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable +-} +module GHCup.GHC where + + +import GHCup.Download +import GHCup.Errors +import GHCup.Types +import GHCup.Types.JSON ( ) +import GHCup.Types.Optics +import GHCup.Utils +import GHCup.Prelude +import GHCup.Prelude.File +import GHCup.Prelude.Logger +import GHCup.Prelude.Process +import GHCup.Prelude.String.QQ +import GHCup.Prelude.Version.QQ +import GHCup.Prelude.MegaParsec + +import Codec.Archive ( ArchiveResult ) +import Control.Applicative +import Control.Concurrent ( threadDelay ) +import Control.Exception.Safe +import Control.Monad +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource + hiding ( throwM ) +import Data.ByteString ( ByteString ) +import Data.Either +import Data.List +import Data.Maybe +import Data.List.NonEmpty ( NonEmpty((:|)) ) +import Data.String ( fromString ) +import Data.Text ( Text ) +import Data.Time.Clock +import Data.Time.Format.ISO8601 +import Data.Versions hiding ( patch ) +import GHC.IO.Exception +import Haskus.Utils.Variant.Excepts +import Language.Haskell.TH +import Language.Haskell.TH.Syntax ( Quasi(qAddDependentFile) ) +import Optics +import Prelude hiding ( abs + , writeFile + ) +import System.Environment +import System.FilePath +import System.IO.Error +import Text.PrettyPrint.HughesPJClass ( prettyShow ) +import Text.Regex.Posix +import URI.ByteString + +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Text.Encoding as E +import qualified Text.Megaparsec as MP + + + --------------------- + --[ Tool fetching ]-- + --------------------- + + + +fetchGHCSrc :: ( MonadFail m + , MonadMask m + , MonadCatch m + , MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , HasGHCupInfo env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + ) + => Version + -> Maybe FilePath + -> Excepts + '[ DigestError + , GPGError + , DownloadFailed + , NoDownload + ] + m + FilePath +fetchGHCSrc v mfp = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + dlInfo <- + preview (ix GHC % ix v % viSourceDL % _Just) dls + ?? NoDownload + liftE $ downloadCached' dlInfo Nothing mfp + + + + ------------------------- + --[ Tool installation ]-- + ------------------------- + + +-- | Like 'installGHCBin', except takes the 'DownloadInfo' as +-- argument instead of looking it up from 'GHCupDownloads'. +installGHCBindist :: ( MonadFail m + , MonadMask m + , MonadCatch m + , MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + ) + => DownloadInfo -- ^ where/how to download + -> Version -- ^ the version to install + -> InstallDir + -> Bool -- ^ Force install + -> Excepts + '[ AlreadyInstalled + , BuildFailed + , DigestError + , GPGError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist + , DirNotEmpty + , ArchiveResult + , ProcessError + , UninstallFailed + , MergeFileTreeError + ] + m + () +installGHCBindist dlinfo ver installDir forceInstall = do + let tver = mkTVer ver + + lift $ logDebug $ "Requested to install GHC with " <> prettyVer ver + + regularGHCInstalled <- lift $ ghcInstalled tver + + if + | not forceInstall + , regularGHCInstalled + , GHCupInternal <- installDir -> do + throwE $ AlreadyInstalled GHC ver + + | forceInstall + , regularGHCInstalled + , GHCupInternal <- installDir -> do + lift $ logInfo "Removing the currently installed GHC version first!" + liftE $ rmGHCVer tver + + | otherwise -> pure () + + -- download (or use cached version) + dl <- liftE $ downloadCached dlinfo Nothing + + + toolchainSanityChecks + + case installDir of + IsolateDir isoDir -> do -- isolated install + lift $ logInfo $ "isolated installing GHC to " <> T.pack isoDir + liftE $ installPackedGHC dl (view dlSubdir dlinfo) (IsolateDirResolved isoDir) ver forceInstall + GHCupInternal -> do -- regular install + -- prepare paths + ghcdir <- lift $ ghcupGHCDir tver + + liftE $ installPackedGHC dl (view dlSubdir dlinfo) (GHCupDir ghcdir) ver forceInstall + + -- make symlinks & stuff when regular install, + liftE $ postGHCInstall tver + + where + toolchainSanityChecks = do + r <- forM ["CC", "LD"] (liftIO . lookupEnv) + case catMaybes r of + [] -> pure () + _ -> do + lift $ logWarn $ "CC/LD environment variable is set. This will change the compiler/linker" + <> "\n" <> "GHC uses internally and can cause defunct GHC in some cases (e.g. in Anaconda" + <> "\n" <> "environments). If you encounter problems, unset CC and LD and reinstall." + + +-- | Install a packed GHC distribution. This only deals with unpacking and the GHC +-- build system and nothing else. +installPackedGHC :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasDirs env + , HasPlatformReq env + , HasSettings env + , MonadThrow m + , HasLog env + , MonadIO m + , MonadUnliftIO m + , MonadFail m + , MonadResource m + ) + => FilePath -- ^ Path to the packed GHC bindist + -> Maybe TarDir -- ^ Subdir of the archive + -> InstallDirResolved + -> Version -- ^ The GHC version + -> Bool -- ^ Force install + -> Excepts + '[ BuildFailed + , UnknownArchive + , TarDirDoesNotExist + , DirNotEmpty + , ArchiveResult + , ProcessError + , MergeFileTreeError + ] m () +installPackedGHC dl msubdir inst ver forceInstall = do + PlatformRequest {..} <- lift getPlatformReq + + unless forceInstall + (liftE $ installDestSanityCheck inst) + + -- unpack + tmpUnpack <- lift mkGhcupTmpDir + liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) + + -- the subdir of the archive where we do the work + workdir <- maybe (pure tmpUnpack) + (liftE . intoSubdir tmpUnpack) + msubdir + + liftE $ runBuildAction tmpUnpack + (installUnpackedGHC workdir inst ver forceInstall) + + +-- | Install an unpacked GHC distribution. This only deals with the GHC +-- build system and nothing else. +installUnpackedGHC :: ( MonadReader env m + , HasPlatformReq env + , HasDirs env + , HasSettings env + , MonadThrow m + , HasLog env + , MonadIO m + , MonadUnliftIO m + , MonadMask m + , MonadResource m + , MonadFail m + ) + => GHCupPath -- ^ Path to the unpacked GHC bindist (where the configure script resides) + -> InstallDirResolved -- ^ Path to install to + -> Version -- ^ The GHC version + -> Bool -- ^ Force install + -> Excepts '[ProcessError, MergeFileTreeError] m () +installUnpackedGHC path inst ver forceInstall + | isWindows = do + lift $ logInfo "Installing GHC (this may take a while)" + -- Windows bindists are relocatable and don't need + -- to run configure. + -- We also must make sure to preserve mtime to not confuse ghc-pkg. + liftE $ mergeFileTree path inst GHC (mkTVer ver) $ \source dest -> do + mtime <- liftIO $ ifM (pathIsSymbolicLink source) (pure Nothing) (Just <$> getModificationTime source) + when forceInstall $ hideError doesNotExistErrorType $ hideError InappropriateType $ recycleFile dest + liftIO $ moveFilePortable source dest + forM_ mtime $ liftIO . setModificationTime dest + | otherwise = do + PlatformRequest {..} <- lift getPlatformReq + + let alpineArgs + | ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform + = ["--disable-ld-override"] + | otherwise + = [] + + lift $ logInfo "Installing GHC (this may take a while)" + lEM $ execLogged "sh" + ("./configure" : ("--prefix=" <> fromInstallDir inst) + : alpineArgs + ) + (Just $ fromGHCupPath path) + "ghc-configure" + Nothing + tmpInstallDest <- lift withGHCupTmpDir + lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "install"] (Just $ fromGHCupPath path) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpInstallDest) + liftE $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst)) + inst + GHC + (mkTVer ver) + (\f t -> liftIO $ do + mtime <- ifM (pathIsSymbolicLink f) (pure Nothing) (Just <$> getModificationTime f) + install f t (not forceInstall) + forM_ mtime $ setModificationTime t) + + pure () + + +-- | Installs GHC into @~\/.ghcup\/ghc/\@ and places the +-- following symlinks in @~\/.ghcup\/bin@: +-- +-- * @ghc-x.y.z -> ..\/ghc\/x.y.z\/bin/ghc@ +-- * @ghc-x.y -> ..\/ghc\/x.y.z\/bin/ghc@ (if x.y.z is the latest x.y version) +installGHCBin :: ( MonadFail m + , MonadMask m + , MonadCatch m + , MonadReader env m + , HasPlatformReq env + , HasGHCupInfo env + , HasDirs env + , HasSettings env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + ) + => Version -- ^ the version to install + -> InstallDir + -> Bool -- ^ force install + -> Excepts + '[ AlreadyInstalled + , BuildFailed + , DigestError + , GPGError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist + , DirNotEmpty + , ArchiveResult + , ProcessError + , UninstallFailed + , MergeFileTreeError + ] + m + () +installGHCBin ver installDir forceInstall = do + dlinfo <- liftE $ getDownloadInfo GHC ver + liftE $ installGHCBindist dlinfo ver installDir forceInstall + + + + + + --------------- + --[ Set GHC ]-- + --------------- + + + +-- | Set GHC symlinks in @~\/.ghcup\/bin@ for the requested GHC version. The behavior depends +-- on `SetGHC`: +-- +-- * SetGHCOnly: @~\/.ghcup\/bin\/ghc -> ~\/.ghcup\/ghc\/\\/bin\/ghc@ +-- * SetGHC_XY: @~\/.ghcup\/bin\/ghc-X.Y -> ~\/.ghcup\/ghc\/\\/bin\/ghc@ +-- * SetGHC_XYZ: @~\/.ghcup\/bin\/ghc-\ -> ~\/.ghcup\/ghc\/\\/bin\/ghc@ +-- +-- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\\/share symlink@ +-- for 'SetGHCOnly' constructor. +setGHC :: ( MonadReader env m + , HasDirs env + , HasLog env + , MonadThrow m + , MonadFail m + , MonadIO m + , MonadCatch m + , MonadMask m + , MonadUnliftIO m + ) + => GHCTargetVersion + -> SetGHC + -> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin + -- and don't want mess with other versions + -> Excepts '[NotInstalled] m GHCTargetVersion +setGHC ver sghc mBinDir = do + let verS = T.unpack $ prettyVer (_tvVersion ver) + ghcdir <- lift $ ghcupGHCDir ver + + whenM (lift $ not <$> ghcInstalled ver) (throwE (NotInstalled GHC ver)) + + -- symlink destination + binDir <- case mBinDir of + Just x -> pure x + Nothing -> do + Dirs {binDir = f} <- lift getDirs + pure f + + -- first delete the old symlinks (this fixes compatibility issues + -- with old ghcup) + when (isNothing mBinDir) $ + case sghc of + SetGHCOnly -> liftE $ rmPlainGHC (_tvTarget ver) + SetGHC_XY -> liftE $ rmMajorGHCSymlinks ver + SetGHC_XYZ -> liftE $ rmMinorGHCSymlinks ver + + -- for ghc tools (ghc, ghci, haddock, ...) + verfiles <- ghcToolFiles ver + forM_ verfiles $ \file -> do + mTargetFile <- case sghc of + SetGHCOnly -> pure $ Just file + SetGHC_XY -> do + handle + (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing) + $ do + (mj, mi) <- getMajorMinorV (_tvVersion ver) + let major' = intToText mj <> "." <> intToText mi + pure $ Just (file <> "-" <> T.unpack major') + SetGHC_XYZ -> + pure $ Just (file <> "-" <> verS) + + -- create symlink + forM_ mTargetFile $ \targetFile -> do + bindir <- ghcInternalBinDir ver + let fullF = binDir targetFile <> exeExt + fileWithExt = bindir file <> exeExt + destL <- binarySymLinkDestination binDir fileWithExt + lift $ createLink destL fullF + + when (isNothing mBinDir) $ do + -- create symlink for share dir + when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir (fromGHCupPath ghcdir) verS + + when (sghc == SetGHCOnly) $ lift warnAboutHlsCompatibility + + pure ver + + where + + symlinkShareDir :: ( MonadReader env m + , HasDirs env + , MonadIO m + , HasLog env + , MonadCatch m + , MonadMask m + ) + => FilePath + -> String + -> m () + symlinkShareDir ghcdir ver' = do + Dirs {..} <- getDirs + let destdir = fromGHCupPath baseDir + case sghc of + SetGHCOnly -> do + let sharedir = "share" + let fullsharedir = ghcdir sharedir + logDebug $ "Checking for sharedir existence: " <> T.pack fullsharedir + whenM (liftIO $ doesDirectoryExist fullsharedir) $ do + let fullF = destdir sharedir + let targetF = "." "ghc" ver' sharedir + logDebug $ "rm -f " <> T.pack fullF + hideError doesNotExistErrorType $ rmDirectoryLink fullF + logDebug $ "ln -s " <> T.pack targetF <> " " <> T.pack fullF + + if isWindows + then liftIO + -- On windows we need to be more permissive + -- in case symlinks can't be created, be just + -- give up here. This symlink isn't strictly necessary. + $ hideError permissionErrorType + $ hideError illegalOperationErrorType + $ createDirectoryLink targetF fullF + else liftIO + $ createDirectoryLink targetF fullF + _ -> pure () + +unsetGHC :: ( MonadReader env m + , HasDirs env + , HasLog env + , MonadThrow m + , MonadFail m + , MonadIO m + , MonadMask m + ) + => Maybe Text + -> Excepts '[NotInstalled] m () +unsetGHC = rmPlainGHC + + + + + + -------------- + --[ GHC rm ]-- + -------------- + + +-- | Delete a ghc version and all its symlinks. +-- +-- This may leave GHCup without a "set" version. +-- Will try to fix the ghc-x.y symlink after removal (e.g. to an +-- older version). +rmGHCVer :: ( MonadReader env m + , HasDirs env + , MonadThrow m + , HasLog env + , MonadIO m + , MonadFail m + , MonadCatch m + , MonadMask m + , MonadUnliftIO m + ) + => GHCTargetVersion + -> Excepts '[NotInstalled, UninstallFailed] m () +rmGHCVer ver = do + isSetGHC <- lift $ fmap (== Just ver) $ ghcSet (_tvTarget ver) + + whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC ver)) + + -- this isn't atomic, order matters + when isSetGHC $ do + lift $ logInfo "Removing ghc symlinks" + liftE $ rmPlainGHC (_tvTarget ver) + + lift $ logInfo "Removing ghc-x.y.z symlinks" + liftE $ rmMinorGHCSymlinks ver + + lift $ logInfo "Removing/rewiring ghc-x.y symlinks" + -- first remove + handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorGHCSymlinks ver + -- then fix them (e.g. with an earlier version) + + dir' <- lift $ ghcupGHCDir ver + let dir = fromGHCupPath dir' + lift (getInstalledFiles GHC ver) >>= \case + Just files -> do + lift $ logInfo $ "Removing files safely from: " <> T.pack dir + forM_ files (lift . hideError NoSuchThing . recycleFile . (\f -> dir dropDrive f)) + removeEmptyDirsRecursive dir + survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory dir + f <- recordedInstallationFile GHC ver + lift $ recycleFile f + when (not (null survivors)) $ throwE $ UninstallFailed dir survivors + Nothing -> do + lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack dir + lift $ recyclePathForcibly dir' + + v' <- + handle + (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing) + $ fmap Just + $ getMajorMinorV (_tvVersion ver) + forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) (_tvTarget ver)) + >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY Nothing) + + Dirs {..} <- lift getDirs + + lift $ hideError doesNotExistErrorType $ rmDirectoryLink (fromGHCupPath baseDir "share") + + + + + --------------- + --[ Compile ]-- + --------------- + + +-- | Compile a GHC from source. This behaves wrt symlinks and installation +-- the same as 'installGHCBin'. +compileGHC :: ( MonadMask m + , MonadReader env m + , HasDirs env + , HasPlatformReq env + , HasGHCupInfo env + , HasSettings env + , MonadThrow m + , MonadResource m + , HasLog env + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => Either GHCTargetVersion GitBranch -- ^ version to install + -> Maybe Version -- ^ overwrite version + -> Either Version FilePath -- ^ version to bootstrap with + -> Maybe Int -- ^ jobs + -> Maybe FilePath -- ^ build config + -> Maybe (Either FilePath [URI]) -- ^ patches + -> [Text] -- ^ additional args to ./configure + -> Maybe String -- ^ build flavour + -> Bool + -> InstallDir + -> Excepts + '[ AlreadyInstalled + , BuildFailed + , DigestError + , GPGError + , DownloadFailed + , GHCupSetError + , NoDownload + , NotFoundInPATH + , PatchFailed + , UnknownArchive + , TarDirDoesNotExist + , NotInstalled + , DirNotEmpty + , ArchiveResult + , FileDoesNotExistError + , HadrianNotFound + , InvalidBuildConfig + , ProcessError + , CopyError + , BuildFailed + , UninstallFailed + , MergeFileTreeError + ] + m + GHCTargetVersion +compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian installDir + = do + PlatformRequest { .. } <- lift getPlatformReq + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + + (workdir, tmpUnpack, tver) <- case targetGhc of + -- unpack from version tarball + Left tver -> do + lift $ logDebug $ "Requested to compile: " <> tVerToText tver <> " with " <> either prettyVer T.pack bstrap + + -- download source tarball + dlInfo <- + preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls + ?? NoDownload + dl <- liftE $ downloadCached dlInfo Nothing + + -- unpack + tmpUnpack <- lift mkGhcupTmpDir + liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform $ fromGHCupPath tmpUnpack + + workdir <- maybe (pure tmpUnpack) + (liftE . intoSubdir tmpUnpack) + (view dlSubdir dlInfo) + liftE $ applyAnyPatch patches (fromGHCupPath workdir) + + pure (workdir, tmpUnpack, tver) + + -- clone from git + Right GitBranch{..} -> do + tmpUnpack <- lift mkGhcupTmpDir + let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing + tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] DownloadFailed $ do + let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo + lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)" + lEM $ git [ "init" ] + lEM $ git [ "remote" + , "add" + , "origin" + , fromString rep ] + + let fetch_args = + [ "fetch" + , "--depth" + , "1" + , "--quiet" + , "origin" + , fromString ref ] + lEM $ git fetch_args + + lEM $ git [ "checkout", "FETCH_HEAD" ] + lEM $ git [ "submodule", "update", "--init", "--depth", "1" ] + liftE $ applyAnyPatch patches (fromGHCupPath tmpUnpack) + lEM $ execWithGhcEnv "python3" ["./boot"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" + lEM $ execWithGhcEnv "sh" ["./configure"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" + CapturedProcess {..} <- lift $ makeOut + ["show!", "--quiet", "VALUE=ProjectVersion" ] (Just $ fromGHCupPath tmpUnpack) + case _exitCode of + ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . decUTF8Safe' $ _stdOut + ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr)) + + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) + lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to GHC version " <> prettyVer tver + + pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver) + -- the version that's installed may differ from the + -- compiled version, so the user can overwrite it + let installVer = maybe tver (\ov' -> tver { _tvVersion = ov' }) ov + + alreadyInstalled <- lift $ ghcInstalled installVer + alreadySet <- fmap (== Just installVer) $ lift $ ghcSet (_tvTarget installVer) + + when alreadyInstalled $ do + case installDir of + IsolateDir isoDir -> + lift $ logWarn $ "GHC " <> T.pack (prettyShow installVer) <> " already installed. Isolate installing to " <> T.pack isoDir + GHCupInternal -> + lift $ logWarn $ "GHC " <> T.pack (prettyShow installVer) <> " already installed. Will overwrite existing version." + lift $ logWarn + "...waiting for 10 seconds before continuing, you can still abort..." + liftIO $ threadDelay 10000000 -- give the user a sec to intervene + + ghcdir <- case installDir of + IsolateDir isoDir -> pure $ IsolateDirResolved isoDir + GHCupInternal -> GHCupDir <$> lift (ghcupGHCDir installVer) + + (mBindist, bmk) <- liftE $ runBuildAction + tmpUnpack + (do + b <- if hadrian + then compileHadrianBindist tver (fromGHCupPath workdir) ghcdir + else compileMakeBindist tver (fromGHCupPath workdir) ghcdir + bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk $ fromGHCupPath workdir) + pure (b, bmk) + ) + + case installDir of + GHCupInternal -> + -- only remove old ghc in regular installs + when alreadyInstalled $ do + lift $ logInfo "Deleting existing installation" + liftE $ rmGHCVer installVer + + _ -> pure () + + forM_ mBindist $ \bindist -> do + liftE $ installPackedGHC bindist + (Just $ RegexDir "ghc-.*") + ghcdir + (installVer ^. tvVersion) + False -- not a force install, since we already overwrite when compiling. + + liftIO $ B.writeFile (fromInstallDir ghcdir ghcUpSrcBuiltFile) bmk + + case installDir of + -- set and make symlinks for regular (non-isolated) installs + GHCupInternal -> do + reThrowAll GHCupSetError $ postGHCInstall installVer + -- restore + when alreadySet $ liftE $ void $ setGHC installVer SetGHCOnly Nothing + + _ -> pure () + + pure installVer + + where + defaultConf = + let cross_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/cross" >> runIO (readFile "data/build_mk/cross"))) + default_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/default" >> runIO (readFile "data/build_mk/default"))) + in case targetGhc of + Left (GHCTargetVersion (Just _) _) -> cross_mk + _ -> default_mk + + compileHadrianBindist :: ( MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , MonadThrow m + , MonadCatch m + , HasLog env + , MonadIO m + , MonadFail m + ) + => GHCTargetVersion + -> FilePath + -> InstallDirResolved + -> Excepts + '[ FileDoesNotExistError + , HadrianNotFound + , InvalidBuildConfig + , PatchFailed + , ProcessError + , NotFoundInPATH + , CopyError] + m + (Maybe FilePath) -- ^ output path of bindist, None for cross + compileHadrianBindist tver workdir ghcdir = do + lEM $ execWithGhcEnv "python3" ["./boot"] (Just workdir) "ghc-bootstrap" + + liftE $ configureBindist tver workdir ghcdir + + lift $ logInfo "Building (this may take a while)..." + hadrian_build <- liftE $ findHadrianFile workdir + lEM $ execWithGhcEnv hadrian_build + ( maybe [] (\j -> ["-j" <> show j] ) jobs + ++ maybe [] (\bf -> ["--flavour=" <> bf]) buildFlavour + ++ ["binary-dist"] + ) + (Just workdir) "ghc-make" + [tar] <- liftIO $ findFiles + (workdir "_build" "bindist") + (makeRegexOpts compExtended + execBlank + ([s|^ghc-.*\.tar\..*$|] :: ByteString) + ) + liftE $ fmap Just $ copyBindist tver tar (workdir "_build" "bindist") + + findHadrianFile :: (MonadIO m) + => FilePath + -> Excepts + '[HadrianNotFound] + m + FilePath + findHadrianFile workdir = do + let possible_files = if isWindows + then ((workdir "hadrian") ) <$> ["build.bat"] + else ((workdir "hadrian") ) <$> ["build", "build.sh"] + exsists <- forM possible_files (\f -> liftIO (doesFileExist f) <&> (,f)) + case filter fst exsists of + [] -> throwE HadrianNotFound + ((_, x):_) -> pure x + + compileMakeBindist :: ( MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , MonadThrow m + , MonadCatch m + , HasLog env + , MonadIO m + , MonadFail m + ) + => GHCTargetVersion + -> FilePath + -> InstallDirResolved + -> Excepts + '[ FileDoesNotExistError + , HadrianNotFound + , InvalidBuildConfig + , PatchFailed + , ProcessError + , NotFoundInPATH + , CopyError] + m + (Maybe FilePath) -- ^ output path of bindist, None for cross + compileMakeBindist tver workdir ghcdir = do + liftE $ configureBindist tver workdir ghcdir + + case mbuildConfig of + Just bc -> liftIOException + doesNotExistErrorType + (FileDoesNotExistError bc) + (liftIO $ copyFile bc (build_mk workdir) False) + Nothing -> + liftIO $ T.writeFile (build_mk workdir) (addBuildFlavourToConf defaultConf) + + liftE $ checkBuildConfig (build_mk workdir) + + lift $ logInfo "Building (this may take a while)..." + lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir) + + if | isCross tver -> do + lift $ logInfo "Installing cross toolchain..." + lEM $ make ["install"] (Just workdir) + pure Nothing + | otherwise -> do + lift $ logInfo "Creating bindist..." + lEM $ make ["binary-dist"] (Just workdir) + [tar] <- liftIO $ findFiles + workdir + (makeRegexOpts compExtended + execBlank + ([s|^ghc-.*\.tar\..*$|] :: ByteString) + ) + liftE $ fmap Just $ copyBindist tver tar workdir + + build_mk workdir = workdir "mk" "build.mk" + + copyBindist :: ( MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , MonadIO m + , MonadThrow m + , MonadCatch m + , HasLog env + ) + => GHCTargetVersion + -> FilePath -- ^ tar file + -> FilePath -- ^ workdir + -> Excepts + '[CopyError] + m + FilePath + copyBindist tver tar workdir = do + Dirs {..} <- lift getDirs + pfreq <- lift getPlatformReq + c <- liftIO $ BL.readFile (workdir tar) + cDigest <- + fmap (T.take 8) + . lift + . throwEither + . E.decodeUtf8' + . B16.encode + . SHA256.hashlazy + $ c + cTime <- liftIO getCurrentTime + let tarName = makeValid ("ghc-" + <> T.unpack (tVerToText tver) + <> "-" + <> pfReqToString pfreq + <> "-" + <> iso8601Show cTime + <> "-" + <> T.unpack cDigest + <> ".tar" + <> takeExtension tar) + let tarPath = fromGHCupPath cacheDir tarName + copyFileE (workdir tar) tarPath False + lift $ logInfo $ "Copied bindist to " <> T.pack tarPath + pure tarPath + + checkBuildConfig :: (MonadReader env m, MonadCatch m, MonadIO m, HasLog env) + => FilePath + -> Excepts + '[FileDoesNotExistError, InvalidBuildConfig] + m + () + checkBuildConfig bc = do + c <- liftIOException + doesNotExistErrorType + (FileDoesNotExistError bc) + (liftIO $ B.readFile bc) + let lines' = fmap T.strip . T.lines $ decUTF8Safe c + + -- for cross, we need Stage1Only + case targetGhc of + Left (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE + (InvalidBuildConfig + [s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|] + ) + _ -> pure () + + forM_ buildFlavour $ \bf -> + when (T.pack ("BuildFlavour = " <> bf) `notElem` lines') $ do + lift $ logWarn $ "Customly specified build config overwrites --flavour=" <> T.pack bf <> " switch! Waiting 5 seconds..." + liftIO $ threadDelay 5000000 + + addBuildFlavourToConf bc = case buildFlavour of + Just bf -> "BuildFlavour = " <> T.pack bf <> "\n" <> bc + Nothing -> bc + + isCross :: GHCTargetVersion -> Bool + isCross = isJust . _tvTarget + + + configureBindist :: ( MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , MonadThrow m + , MonadCatch m + , HasLog env + , MonadIO m + , MonadFail m + ) + => GHCTargetVersion + -> FilePath + -> InstallDirResolved + -> Excepts + '[ FileDoesNotExistError + , InvalidBuildConfig + , PatchFailed + , ProcessError + , NotFoundInPATH + , CopyError + ] + m + () + configureBindist tver workdir (fromInstallDir -> ghcdir) = do + lift $ logInfo [s|configuring build|] + + if | _tvVersion tver >= [vver|8.8.0|] -> do + lEM $ execWithGhcEnv + "sh" + ("./configure" : maybe mempty + (\x -> ["--target=" <> T.unpack x]) + (_tvTarget tver) + ++ ["--prefix=" <> ghcdir] + ++ (if isWindows then ["--enable-tarballs-autodownload"] else []) + ++ fmap T.unpack aargs + ) + (Just workdir) + "ghc-conf" + | otherwise -> do + lEM $ execLogged + "sh" + ( [ "./configure", "--with-ghc=" <> either id id bghc + ] + ++ maybe mempty + (\x -> ["--target=" <> T.unpack x]) + (_tvTarget tver) + ++ ["--prefix=" <> ghcdir] + ++ (if isWindows then ["--enable-tarballs-autodownload"] else []) + ++ fmap T.unpack aargs + ) + (Just workdir) + "ghc-conf" + Nothing + pure () + + execWithGhcEnv :: ( MonadReader env m + , HasSettings env + , HasDirs env + , HasLog env + , MonadIO m + , MonadThrow m) + => FilePath -- ^ thing to execute + -> [String] -- ^ args for the thing + -> Maybe FilePath -- ^ optionally chdir into this + -> FilePath -- ^ log filename (opened in append mode) + -> m (Either ProcessError ()) + execWithGhcEnv fp args dir logf = do + env <- ghcEnv + execLogged fp args dir logf (Just env) + + bghc = case bstrap of + Right g -> Right g + Left bver -> Left ("ghc-" <> (T.unpack . prettyVer $ bver) <> exeExt) + + ghcEnv :: (MonadThrow m, MonadIO m) => m [(String, String)] + ghcEnv = do + cEnv <- liftIO getEnvironment + bghcPath <- case bghc of + Right ghc' -> pure ghc' + Left bver -> do + spaths <- liftIO getSearchPath + throwMaybeM (NotFoundInPATH bver) $ liftIO (searchPath spaths bver) + pure (("GHC", bghcPath) : cEnv) + + + + + ------------- + --[ Other ]-- + ------------- + + + +-- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for +-- both installing from source and bindist. +postGHCInstall :: ( MonadReader env m + , HasDirs env + , HasLog env + , MonadThrow m + , MonadFail m + , MonadIO m + , MonadCatch m + , MonadMask m + , MonadUnliftIO m + ) + => GHCTargetVersion + -> Excepts '[NotInstalled] m () +postGHCInstall ver@GHCTargetVersion {..} = do + void $ liftE $ setGHC ver SetGHC_XYZ Nothing + + -- Create ghc-x.y symlinks. This may not be the current + -- version, create it regardless. + v' <- + handle (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing) + $ fmap Just + $ getMajorMinorV _tvVersion + forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) _tvTarget) + >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY Nothing) + diff --git a/lib/GHCup/HLS.hs b/lib/GHCup/HLS.hs new file mode 100644 index 0000000..0f4f131 --- /dev/null +++ b/lib/GHCup/HLS.hs @@ -0,0 +1,620 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +{-| +Module : GHCup.HLS +Description : GHCup installation functions for HLS +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable +-} +module GHCup.HLS where + +import GHCup.Download +import GHCup.Errors +import GHCup.Types +import GHCup.Types.JSON ( ) +import GHCup.Types.Optics +import GHCup.Utils +import GHCup.Prelude +import GHCup.Prelude.File +import GHCup.Prelude.Logger +import GHCup.Prelude.Process +import GHCup.Prelude.String.QQ + +import Codec.Archive ( ArchiveResult ) +import Control.Applicative +import Control.Exception.Safe +import Control.Monad +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource + hiding ( throwM ) +import Data.ByteString ( ByteString ) +import Data.Either +import Data.List +import Data.Maybe +import Data.String ( fromString ) +import Data.Text ( Text ) +import Data.Versions hiding ( patch ) +import Distribution.Types.Version hiding ( Version ) +import Distribution.Types.PackageId +import Distribution.Types.PackageDescription +import Distribution.Types.GenericPackageDescription +import Distribution.PackageDescription.Parsec +import GHC.IO.Exception +import Haskus.Utils.Variant.Excepts +import Optics +import Prelude hiding ( abs + , writeFile + ) +import Safe hiding ( at ) +import System.FilePath +import System.IO.Error +import Text.Regex.Posix +import URI.ByteString + +import qualified Data.List.NonEmpty as NE +import qualified Data.ByteString as B +import qualified Data.Text as T +import qualified Text.Megaparsec as MP + + + + -------------------- + --[ Installation ]-- + -------------------- + + +-- | Like 'installHLSBin, except takes the 'DownloadInfo' as +-- argument instead of looking it up from 'GHCupDownloads'. +installHLSBindist :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasPlatformReq env + , HasDirs env + , HasSettings env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => DownloadInfo + -> Version + -> InstallDir -- ^ isolated install path, if user passed any + -> Bool -- ^ Force install + -> Excepts + '[ AlreadyInstalled + , CopyError + , DigestError + , GPGError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist + , ArchiveResult + , FileAlreadyExistsError + , ProcessError + , DirNotEmpty + , UninstallFailed + , MergeFileTreeError + ] + m + () +installHLSBindist dlinfo ver installDir forceInstall = do + lift $ logDebug $ "Requested to install hls version " <> prettyVer ver + + PlatformRequest {..} <- lift getPlatformReq + Dirs {..} <- lift getDirs + + regularHLSInstalled <- lift $ hlsInstalled ver + + if + | not forceInstall + , regularHLSInstalled + , GHCupInternal <- installDir -> do -- regular install + throwE $ AlreadyInstalled HLS ver + + | forceInstall + , regularHLSInstalled + , GHCupInternal <- installDir -> do -- regular forced install + lift $ logInfo "Removing the currently installed version of HLS before force installing!" + liftE $ rmHLSVer ver + + | otherwise -> pure () + + -- download (or use cached version) + dl <- liftE $ downloadCached dlinfo Nothing + + -- unpack + tmpUnpack <- lift withGHCupTmpDir + liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) + + -- the subdir of the archive where we do the work + workdir <- fromGHCupPath <$> maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) + legacy <- liftIO $ isLegacyHLSBindist workdir + + if + | not forceInstall + , not legacy + , (IsolateDir fp) <- installDir -> liftE $ installDestSanityCheck (IsolateDirResolved fp) + | otherwise -> pure () + + case installDir of + IsolateDir isoDir -> do + lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir + if legacy + then liftE $ installHLSUnpackedLegacy workdir (IsolateDirResolved isoDir) ver forceInstall + else liftE $ runBuildAction tmpUnpack $ installHLSUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall + + GHCupInternal -> do + if legacy + then liftE $ installHLSUnpackedLegacy workdir (GHCupBinDir binDir) ver forceInstall + else do + inst <- ghcupHLSDir ver + liftE $ runBuildAction tmpUnpack + $ installHLSUnpacked workdir (GHCupDir inst) ver forceInstall + liftE $ setHLS ver SetHLS_XYZ Nothing + + +isLegacyHLSBindist :: FilePath -- ^ Path to the unpacked hls bindist + -> IO Bool +isLegacyHLSBindist path = do + not <$> doesFileExist (path "GNUmakefile") + +-- | 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 + , MonadResource m + , HasPlatformReq env + ) + => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) + -> InstallDirResolved -- ^ Path to install to + -> Version + -> Bool + -> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled, MergeFileTreeError] m () +installHLSUnpacked path inst ver forceInstall = do + PlatformRequest { .. } <- lift getPlatformReq + lift $ logInfo "Installing HLS" + tmpInstallDest <- lift withGHCupTmpDir + lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "PREFIX=" <> fromInstallDir inst, "install"] (Just path) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpInstallDest) + liftE $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst)) + inst + HLS + (mkTVer ver) + (\f t -> liftIO $ do + mtime <- ifM (pathIsSymbolicLink f) (pure Nothing) (Just <$> getModificationTime f) + install f t (not forceInstall) + forM_ mtime $ setModificationTime t) + +-- | Install an unpacked hls distribution (legacy). +installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m) + => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) + -> InstallDirResolved -- ^ Path to install to + -> Version + -> Bool -- ^ is it a force install + -> Excepts '[CopyError, FileAlreadyExistsError] m () +installHLSUnpackedLegacy path installDir ver forceInstall = do + lift $ logInfo "Installing HLS" + liftIO $ createDirRecursive' (fromInstallDir installDir) + + -- install haskell-language-server- + bins@(_:_) <- liftIO $ findFiles + path + (makeRegexOpts compExtended + execBlank + ([s|^haskell-language-server-[0-9].*$|] :: ByteString) + ) + forM_ bins $ \f -> do + let toF = dropSuffix exeExt f + <> (case installDir of + IsolateDirResolved _ -> "" + _ -> ("~" <>) . T.unpack . prettyVer $ ver + ) + <> exeExt + + let srcPath = path f + let destPath = fromInstallDir installDir toF + + -- destination could be an existing symlink + -- for new make-based HLSes + liftIO $ rmFileForce destPath + + copyFileE + srcPath + destPath + (not forceInstall) + lift $ chmod_755 destPath + + -- install haskell-language-server-wrapper + let wrapper = "haskell-language-server-wrapper" + toF = wrapper + <> (case installDir of + IsolateDirResolved _ -> "" + _ -> ("-" <>) . T.unpack . prettyVer $ ver + ) + <> exeExt + srcWrapperPath = path wrapper <> exeExt + destWrapperPath = fromInstallDir installDir toF + + liftIO $ rmFileForce destWrapperPath + copyFileE + srcWrapperPath + destWrapperPath + (not forceInstall) + + lift $ chmod_755 destWrapperPath + + + +-- | Installs hls binaries @haskell-language-server-\@ +-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@. +installHLSBin :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasPlatformReq env + , HasGHCupInfo env + , HasDirs env + , HasSettings env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => Version + -> InstallDir + -> Bool -- force install + -> Excepts + '[ AlreadyInstalled + , CopyError + , DigestError + , GPGError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist + , ArchiveResult + , FileAlreadyExistsError + , ProcessError + , DirNotEmpty + , UninstallFailed + , MergeFileTreeError + ] + m + () +installHLSBin ver installDir forceInstall = do + dlinfo <- liftE $ getDownloadInfo HLS ver + installHLSBindist dlinfo ver installDir forceInstall + + +compileHLS :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , HasGHCupInfo env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => Either Version GitBranch + -> [Version] + -> Maybe Int + -> Maybe Version + -> InstallDir + -> Maybe (Either FilePath URI) + -> Maybe URI + -> Maybe (Either FilePath [URI]) -- ^ patches + -> [Text] -- ^ additional args to cabal install + -> Excepts '[ NoDownload + , GPGError + , DownloadFailed + , DigestError + , UnknownArchive + , TarDirDoesNotExist + , ArchiveResult + , BuildFailed + , NotInstalled + ] m Version +compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patches cabalArgs = do + PlatformRequest { .. } <- lift getPlatformReq + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + Dirs { .. } <- lift getDirs + + + (workdir, tver) <- case targetHLS of + -- unpack from version tarball + Left tver -> do + lift $ logDebug $ "Requested to compile: " <> prettyVer tver + + -- download source tarball + dlInfo <- + preview (ix HLS % ix tver % viSourceDL % _Just) dls + ?? NoDownload + dl <- liftE $ downloadCached dlInfo Nothing + + -- unpack + tmpUnpack <- lift mkGhcupTmpDir + liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) + + workdir <- maybe (pure tmpUnpack) + (liftE . intoSubdir tmpUnpack) + (view dlSubdir dlInfo) + + pure (workdir, tver) + + -- clone from git + Right GitBranch{..} -> do + tmpUnpack <- lift mkGhcupTmpDir + let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing + tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do + let rep = fromMaybe "https://github.com/haskell/haskell-language-server.git" repo + lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)" + lEM $ git [ "init" ] + lEM $ git [ "remote" + , "add" + , "origin" + , fromString rep ] + + let fetch_args = + [ "fetch" + , "--depth" + , "1" + , "--quiet" + , "origin" + , fromString ref ] + lEM $ git fetch_args + + lEM $ git [ "checkout", "FETCH_HEAD" ] + (Just gpd) <- parseGenericPackageDescriptionMaybe <$> liftIO (B.readFile (fromGHCupPath tmpUnpack "haskell-language-server.cabal")) + pure . (\c -> Version Nothing c [] Nothing) + . NE.fromList . fmap (NE.fromList . (:[]) . digits . fromIntegral) + . versionNumbers + . pkgVersion + . package + . packageDescription + $ gpd + + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) + lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to HLS version " <> prettyVer tver + + pure (tmpUnpack, tver) + + -- the version that's installed may differ from the + -- compiled version, so the user can overwrite it + let installVer = fromMaybe tver ov + + liftE $ runBuildAction + workdir + (reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed $ fromGHCupPath workdir) $ do + let tmpInstallDir = fromGHCupPath workdir "out" + liftIO $ createDirRecursive' tmpInstallDir + + -- apply patches + liftE $ applyAnyPatch patches (fromGHCupPath workdir) + + -- set up project files + cp <- case cabalProject of + Just (Left cp) + | isAbsolute cp -> do + copyFileE cp (fromGHCupPath workdir "cabal.project") False + pure "cabal.project" + | otherwise -> pure (takeFileName cp) + Just (Right uri) -> do + tmpUnpack <- lift withGHCupTmpDir + cp <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack) (Just "cabal.project") False + copyFileE cp (fromGHCupPath workdir "cabal.project") False + pure "cabal.project" + Nothing -> pure "cabal.project" + forM_ cabalProjectLocal $ \uri -> do + tmpUnpack <- lift withGHCupTmpDir + cpl <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack) (Just (cp <.> "local")) False + copyFileE cpl (fromGHCupPath workdir cp <.> "local") False + artifacts <- forM (sort ghcs) $ \ghc -> do + let ghcInstallDir = tmpInstallDir T.unpack (prettyVer ghc) + liftIO $ createDirRecursive' tmpInstallDir + lift $ logInfo $ "Building HLS " <> prettyVer installVer <> " for GHC version " <> prettyVer ghc + liftE $ lEM @_ @'[ProcessError] $ + execLogged "cabal" ( [ "v2-install" + , "-w" + , "ghc-" <> T.unpack (prettyVer ghc) + , "--install-method=copy" + ] ++ + maybe [] (\j -> ["--jobs=" <> show j]) jobs ++ + [ "--overwrite-policy=always" + , "--disable-profiling" + , "--disable-tests" + , "--installdir=" <> ghcInstallDir + , "--project-file=" <> cp + ] ++ fmap T.unpack cabalArgs ++ [ + "exe:haskell-language-server" + , "exe:haskell-language-server-wrapper"] + ) + (Just $ fromGHCupPath workdir) + "cabal" + Nothing + pure ghcInstallDir + + forM_ artifacts $ \artifact -> do + logInfo $ T.pack (show artifact) + liftIO $ renameFile (artifact "haskell-language-server" <.> exeExt) + (tmpInstallDir "haskell-language-server-" <> takeFileName artifact <.> exeExt) + liftIO $ renameFile (artifact "haskell-language-server-wrapper" <.> exeExt) + (tmpInstallDir "haskell-language-server-wrapper" <.> exeExt) + + case installDir of + IsolateDir isoDir -> do + lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir + liftE $ installHLSUnpackedLegacy tmpInstallDir (IsolateDirResolved isoDir) installVer True + GHCupInternal -> do + liftE $ installHLSUnpackedLegacy tmpInstallDir (GHCupBinDir binDir) installVer True + ) + + pure installVer + + + ----------------- + --[ Set/Unset ]-- + ----------------- + +-- | Set the haskell-language-server symlinks. +setHLS :: ( MonadReader env m + , HasDirs env + , HasLog env + , MonadIO m + , MonadMask m + , MonadFail m + , MonadUnliftIO m + ) + => Version + -> SetHLS + -> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin + -- and don't want mess with other versions + -> Excepts '[NotInstalled] m () +setHLS ver shls mBinDir = do + whenM (lift $ not <$> hlsInstalled ver) (throwE (NotInstalled HLS (GHCTargetVersion Nothing ver))) + + -- symlink destination + binDir <- case mBinDir of + Just x -> pure x + Nothing -> do + Dirs {binDir = f} <- lift getDirs + pure f + + -- first delete the old symlinks + when (isNothing mBinDir) $ + case shls of + -- not for legacy + SetHLS_XYZ -> liftE $ rmMinorHLSSymlinks ver + -- legacy and new + SetHLSOnly -> liftE rmPlainHLS + + case shls of + -- not for legacy + SetHLS_XYZ -> do + bins <- lift $ hlsInternalServerScripts ver Nothing + + forM_ bins $ \f -> do + let fname = takeFileName f + destL <- binarySymLinkDestination binDir f + let target = if "haskell-language-server-wrapper" `isPrefixOf` fname + then fname <> "-" <> T.unpack (prettyVer ver) <> exeExt + else fname <> "~" <> T.unpack (prettyVer ver) <> exeExt + lift $ createLink destL (binDir target) + + -- legacy and new + SetHLSOnly -> do + -- set haskell-language-server- symlinks + bins <- lift $ hlsServerBinaries ver Nothing + when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver) + + forM_ bins $ \f -> do + let destL = f + let target = (<> exeExt) . head . splitOn "~" $ f + lift $ createLink destL (binDir target) + + -- set haskell-language-server-wrapper symlink + let destL = "haskell-language-server-wrapper-" <> T.unpack (prettyVer ver) <> exeExt + let wrapper = binDir "haskell-language-server-wrapper" <> exeExt + + lift $ createLink destL wrapper + + when (isNothing mBinDir) $ + lift warnAboutHlsCompatibility + + +unsetHLS :: ( MonadMask m + , MonadReader env m + , HasDirs env + , MonadIO m) + => m () +unsetHLS = do + Dirs {..} <- getDirs + let wrapper = binDir "haskell-language-server-wrapper" <> exeExt + bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles' + binDir + (MP.chunk "haskell-language-server-" <* pvp' <* MP.chunk (T.pack exeExt) <* MP.eof) + forM_ bins (hideError doesNotExistErrorType . rmLink . (binDir )) + hideError doesNotExistErrorType $ rmLink wrapper + + + + + --------------- + --[ Removal ]-- + --------------- + + +-- | Delete a hls version. Will try to fix the hls symlinks +-- after removal (e.g. setting it to an older version). +rmHLSVer :: ( MonadMask m + , MonadReader env m + , HasDirs env + , MonadThrow m + , HasLog env + , MonadIO m + , MonadFail m + , MonadCatch m + , MonadUnliftIO m + ) + => Version + -> Excepts '[NotInstalled, UninstallFailed] m () +rmHLSVer ver = do + whenM (lift $ fmap not $ hlsInstalled ver) $ throwE (NotInstalled HLS (GHCTargetVersion Nothing ver)) + + isHlsSet <- lift hlsSet + + liftE $ rmMinorHLSSymlinks ver + + when (Just ver == isHlsSet) $ do + -- delete all set symlinks + liftE rmPlainHLS + + hlsDir' <- ghcupHLSDir ver + let hlsDir = fromGHCupPath hlsDir' + lift (getInstalledFiles HLS (mkTVer ver)) >>= \case + Just files -> do + lift $ logInfo $ "Removing files safely from: " <> T.pack hlsDir + forM_ files (lift . hideError NoSuchThing . recycleFile . (\f -> hlsDir dropDrive f)) + removeEmptyDirsRecursive hlsDir + survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory hlsDir + f <- recordedInstallationFile HLS (mkTVer ver) + lift $ recycleFile f + 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 + hlsVers <- lift $ fmap rights getInstalledHLSs + case headMay . reverse . sort $ hlsVers of + Just latestver -> liftE $ setHLS latestver SetHLSOnly Nothing + Nothing -> pure () diff --git a/lib/GHCup/List.hs b/lib/GHCup/List.hs new file mode 100644 index 0000000..91ba381 --- /dev/null +++ b/lib/GHCup/List.hs @@ -0,0 +1,410 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : GHCup.List +Description : Listing versions and tools +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable +-} +module GHCup.List where + +import GHCup.Download +import GHCup.Errors +import GHCup.Types +import GHCup.Types.JSON ( ) +import GHCup.Types.Optics +import GHCup.Utils +import GHCup.Prelude.Logger +import GHCup.Version + +import Control.Applicative +import Control.Exception.Safe +import Control.Monad +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Data.Either +import Data.List +import Data.Maybe +import Data.Text ( Text ) +import Data.Versions hiding ( patch ) +import Haskus.Utils.Variant.Excepts +import Optics +import Prelude hiding ( abs + , writeFile + ) + +import qualified Data.Map.Strict as Map +import qualified Data.Text as T + + + + + + + + + + + ------------------ + --[ List tools ]-- + ------------------ + + +-- | Filter data type for 'listVersions'. +data ListCriteria = ListInstalled + | ListSet + | ListAvailable + deriving Show + +-- | A list result describes a single tool version +-- and various of its properties. +data ListResult = ListResult + { lTool :: Tool + , lVer :: Version + , lCross :: Maybe Text -- ^ currently only for GHC + , lTag :: [Tag] + , lInstalled :: Bool + , lSet :: Bool -- ^ currently active version + , fromSrc :: Bool -- ^ compiled from source + , lStray :: Bool -- ^ not in download info + , lNoBindist :: Bool -- ^ whether the version is available for this platform/arch + , hlsPowered :: Bool + } + deriving (Eq, Ord, Show) + + +-- | Extract all available tool versions and their tags. +availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version VersionInfo +availableToolVersions av tool = view + (at tool % non Map.empty) + av + + +-- | List all versions from the download info, as well as stray +-- versions. +listVersions :: ( MonadCatch m + , HasLog env + , MonadThrow m + , HasLog env + , MonadIO m + , MonadReader env m + , HasDirs env + , HasPlatformReq env + , HasGHCupInfo env + ) + => Maybe Tool + -> Maybe ListCriteria + -> m [ListResult] +listVersions lt' criteria = do + -- some annoying work to avoid too much repeated IO + cSet <- cabalSet + cabals <- getInstalledCabals + hlsSet' <- hlsSet + hlses <- getInstalledHLSs + sSet <- stackSet + stacks <- getInstalledStacks + + go lt' cSet cabals hlsSet' hlses sSet stacks + where + go lt cSet cabals hlsSet' hlses sSet stacks = do + case lt of + Just t -> do + GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo + -- get versions from GHCupDownloads + let avTools = availableToolVersions dls t + lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses sSet stacks) + + case t of + GHC -> do + slr <- strayGHCs avTools + pure (sort (slr ++ lr)) + Cabal -> do + slr <- strayCabals avTools cSet cabals + pure (sort (slr ++ lr)) + HLS -> do + slr <- strayHLS avTools hlsSet' hlses + pure (sort (slr ++ lr)) + Stack -> do + slr <- strayStacks avTools sSet stacks + pure (sort (slr ++ lr)) + GHCup -> do + let cg = maybeToList $ currentGHCup avTools + pure (sort (cg ++ lr)) + Nothing -> do + ghcvers <- go (Just GHC) cSet cabals hlsSet' hlses sSet stacks + cabalvers <- go (Just Cabal) cSet cabals hlsSet' hlses sSet stacks + hlsvers <- go (Just HLS) cSet cabals hlsSet' hlses sSet stacks + ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses sSet stacks + stackvers <- go (Just Stack) cSet cabals hlsSet' hlses sSet stacks + pure (ghcvers <> cabalvers <> hlsvers <> stackvers <> ghcupvers) + strayGHCs :: ( MonadCatch m + , MonadReader env m + , HasDirs env + , MonadThrow m + , HasLog env + , MonadIO m + ) + => Map.Map Version VersionInfo + -> m [ListResult] + strayGHCs avTools = do + ghcs <- getInstalledGHCs + fmap catMaybes $ forM ghcs $ \case + Right tver@GHCTargetVersion{ _tvTarget = Nothing, .. } -> do + case Map.lookup _tvVersion avTools of + Just _ -> pure Nothing + Nothing -> do + lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing + fromSrc <- ghcSrcInstalled tver + hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions + pure $ Just $ ListResult + { lTool = GHC + , lVer = _tvVersion + , lCross = Nothing + , lTag = [] + , lInstalled = True + , lStray = isNothing (Map.lookup _tvVersion avTools) + , lNoBindist = False + , .. + } + Right tver@GHCTargetVersion{ .. } -> do + lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget + fromSrc <- ghcSrcInstalled tver + hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions + pure $ Just $ ListResult + { lTool = GHC + , lVer = _tvVersion + , lCross = _tvTarget + , lTag = [] + , lInstalled = True + , lStray = True -- NOTE: cross currently cannot be installed via bindist + , lNoBindist = False + , .. + } + Left e -> do + logWarn + $ "Could not parse version of stray directory" <> T.pack e + pure Nothing + + strayCabals :: ( MonadReader env m + , HasDirs env + , MonadCatch m + , MonadThrow m + , HasLog env + , MonadIO m + ) + => Map.Map Version VersionInfo + -> Maybe Version + -> [Either FilePath Version] + -> m [ListResult] + strayCabals avTools cSet cabals = do + fmap catMaybes $ forM cabals $ \case + Right ver -> + case Map.lookup ver avTools of + Just _ -> pure Nothing + Nothing -> do + let lSet = cSet == Just ver + pure $ Just $ ListResult + { lTool = Cabal + , lVer = ver + , lCross = Nothing + , lTag = [] + , lInstalled = True + , lStray = isNothing (Map.lookup ver avTools) + , lNoBindist = False + , fromSrc = False -- actually, we don't know :> + , hlsPowered = False + , .. + } + Left e -> do + logWarn + $ "Could not parse version of stray directory" <> T.pack e + pure Nothing + + strayHLS :: ( MonadReader env m + , HasDirs env + , MonadCatch m + , MonadThrow m + , HasLog env + , MonadIO m) + => Map.Map Version VersionInfo + -> Maybe Version + -> [Either FilePath Version] + -> m [ListResult] + strayHLS avTools hlsSet' hlss = do + fmap catMaybes $ forM hlss $ \case + Right ver -> + case Map.lookup ver avTools of + Just _ -> pure Nothing + Nothing -> do + let lSet = hlsSet' == Just ver + pure $ Just $ ListResult + { lTool = HLS + , lVer = ver + , lCross = Nothing + , lTag = [] + , lInstalled = True + , lStray = isNothing (Map.lookup ver avTools) + , lNoBindist = False + , fromSrc = False -- actually, we don't know :> + , hlsPowered = False + , .. + } + Left e -> do + logWarn + $ "Could not parse version of stray directory" <> T.pack e + pure Nothing + + strayStacks :: ( MonadReader env m + , HasDirs env + , MonadCatch m + , MonadThrow m + , HasLog env + , MonadIO m + ) + => Map.Map Version VersionInfo + -> Maybe Version + -> [Either FilePath Version] + -> m [ListResult] + strayStacks avTools stackSet' stacks = do + fmap catMaybes $ forM stacks $ \case + Right ver -> + case Map.lookup ver avTools of + Just _ -> pure Nothing + Nothing -> do + let lSet = stackSet' == Just ver + pure $ Just $ ListResult + { lTool = Stack + , lVer = ver + , lCross = Nothing + , lTag = [] + , lInstalled = True + , lStray = isNothing (Map.lookup ver avTools) + , lNoBindist = False + , fromSrc = False -- actually, we don't know :> + , hlsPowered = False + , .. + } + Left e -> do + logWarn + $ "Could not parse version of stray directory" <> T.pack e + pure Nothing + + currentGHCup :: Map.Map Version VersionInfo -> Maybe ListResult + currentGHCup av = + let currentVer = fromJust $ pvpToVersion ghcUpVer "" + listVer = Map.lookup currentVer av + latestVer = fst <$> headOf (getTagged Latest) av + recommendedVer = fst <$> headOf (getTagged Latest) av + isOld = maybe True (> currentVer) latestVer && maybe True (> currentVer) recommendedVer + in if | Map.member currentVer av -> Nothing + | otherwise -> Just $ ListResult { lVer = currentVer + , lTag = maybe (if isOld then [Old] else []) _viTags listVer + , lCross = Nothing + , lTool = GHCup + , fromSrc = False + , lStray = isNothing listVer + , lSet = True + , lInstalled = True + , lNoBindist = False + , hlsPowered = False + } + + -- NOTE: this are not cross ones, because no bindists + toListResult :: ( HasLog env + , MonadReader env m + , HasDirs env + , HasGHCupInfo env + , HasPlatformReq env + , MonadIO m + , MonadCatch m + ) + => Tool + -> Maybe Version + -> [Either FilePath Version] + -> Maybe Version + -> [Either FilePath Version] + -> Maybe Version + -> [Either FilePath Version] + -> (Version, VersionInfo) + -> m ListResult + toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, _viTags -> tags) = do + case t of + GHC -> do + lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo GHC v + let tver = mkTVer v + lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing + lInstalled <- ghcInstalled tver + fromSrc <- ghcSrcInstalled tver + hlsPowered <- fmap (elem v) hlsGHCVersions + pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. } + Cabal -> do + lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Cabal v + let lSet = cSet == Just v + let lInstalled = elem v $ rights cabals + pure ListResult { lVer = v + , lCross = Nothing + , lTag = tags + , lTool = t + , fromSrc = False + , lStray = False + , hlsPowered = False + , .. + } + GHCup -> do + let lSet = prettyPVP ghcUpVer == prettyVer v + let lInstalled = lSet + pure ListResult { lVer = v + , lTag = tags + , lCross = Nothing + , lTool = t + , fromSrc = False + , lStray = False + , lNoBindist = False + , hlsPowered = False + , .. + } + HLS -> do + lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo HLS v + let lSet = hlsSet' == Just v + let lInstalled = elem v $ rights hlses + pure ListResult { lVer = v + , lCross = Nothing + , lTag = tags + , lTool = t + , fromSrc = False + , lStray = False + , hlsPowered = False + , .. + } + Stack -> do + lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Stack v + let lSet = stackSet' == Just v + let lInstalled = elem v $ rights stacks + pure ListResult { lVer = v + , lCross = Nothing + , lTag = tags + , lTool = t + , fromSrc = False + , lStray = False + , hlsPowered = False + , .. + } + + + filter' :: [ListResult] -> [ListResult] + filter' lr = case criteria of + Nothing -> lr + Just ListInstalled -> filter (\ListResult {..} -> lInstalled) lr + Just ListSet -> filter (\ListResult {..} -> lSet) lr + Just ListAvailable -> filter (\ListResult {..} -> not lNoBindist) lr + diff --git a/lib/GHCup/Platform.hs b/lib/GHCup/Platform.hs index ec1e7c8..58722af 100644 --- a/lib/GHCup/Platform.hs +++ b/lib/GHCup/Platform.hs @@ -24,10 +24,10 @@ import GHCup.Types import GHCup.Types.Optics import GHCup.Types.JSON ( ) import GHCup.Utils.Dirs -import GHCup.Utils.File -import GHCup.Utils.Logger -import GHCup.Utils.Prelude -import GHCup.Utils.String.QQ +import GHCup.Prelude +import GHCup.Prelude.Logger +import GHCup.Prelude.Process +import GHCup.Prelude.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) diff --git a/lib/GHCup/Prelude.hs b/lib/GHCup/Prelude.hs new file mode 100644 index 0000000..63c2490 --- /dev/null +++ b/lib/GHCup/Prelude.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +Module : GHCup.Prelude +Description : MegaParsec utilities +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable + +GHCup specific prelude. Lots of Excepts functionality. +-} +module GHCup.Prelude + (module GHCup.Prelude, + module GHCup.Prelude.Internal, +#if defined(IS_WINDOWS) + module GHCup.Prelude.Windows +#else + module GHCup.Prelude.Posix +#endif + ) +where + +import GHCup.Prelude.Internal +import GHCup.Types.Optics (HasLog) +import GHCup.Prelude.Logger (logWarn) +#if defined(IS_WINDOWS) +import GHCup.Prelude.Windows +#else +import GHCup.Prelude.Posix +#endif + +import Control.Monad.IO.Class +import Control.Monad.Reader +import Haskus.Utils.Variant.Excepts +import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty ) +import qualified Data.Text as T + + + +-- for some obscure reason... this won't type-check if we move it to a different module +catchWarn :: forall es m env . ( Pretty (V es) + , MonadReader env m + , HasLog env + , MonadIO m + , Monad m) => Excepts es m () -> Excepts '[] m () +catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ v)) + diff --git a/lib/GHCup/Utils/File.hs b/lib/GHCup/Prelude/File.hs similarity index 79% rename from lib/GHCup/Utils/File.hs rename to lib/GHCup/Prelude/File.hs index 493c531..a79cd10 100644 --- a/lib/GHCup/Utils/File.hs +++ b/lib/GHCup/Prelude/File.hs @@ -8,7 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module GHCup.Utils.File ( +module GHCup.Prelude.File ( mergeFileTree, copyFileE, findFilesDeep, @@ -19,12 +19,8 @@ module GHCup.Utils.File ( getDirectoryContentsRecursiveBFSUnsafe, getDirectoryContentsRecursiveDFSUnsafe, recordedInstallationFile, - module GHCup.Utils.File.Common, + module GHCup.Prelude.File.Search, - executeOut, - execLogged, - exec, - toProcessError, chmod_755, isBrokenSymlink, copyFile, @@ -41,25 +37,38 @@ module GHCup.Utils.File ( rmFile, rmDirectoryLink, moveFilePortable, - moveFile + moveFile, + rmPathForcibly, + + exeExt, + exeExt', + getLinkTarget, + pathIsLink, + rmLink, + createLink ) where import GHCup.Utils.Dirs -import GHCup.Utils.File.Common +import GHCup.Prelude.Logger.Internal (logInfo, logDebug) +import GHCup.Prelude.Internal +import GHCup.Prelude.File.Search #if IS_WINDOWS -import GHCup.Utils.File.Windows +import GHCup.Prelude.File.Windows +import GHCup.Prelude.Windows #else -import GHCup.Utils.File.Posix +import GHCup.Prelude.File.Posix +import GHCup.Prelude.Posix #endif import GHCup.Errors import GHCup.Types import GHCup.Types.Optics -import GHCup.Utils.Prelude import Text.Regex.Posix +import Control.Monad.IO.Unlift ( MonadUnliftIO ) import Control.Exception.Safe -import Haskus.Utils.Variant.Excepts import Control.Monad.Reader +import Data.ByteString ( ByteString ) +import Haskus.Utils.Variant.Excepts import System.FilePath import Text.PrettyPrint.HughesPJClass (prettyShow) @@ -69,7 +78,6 @@ import Control.DeepSeq (force) import Control.Exception (evaluate) import GHC.IO.Exception import System.IO.Error -import GHCup.Utils.Logger -- | Merge one file tree to another given a copy operation. @@ -338,3 +346,81 @@ rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env) rmDirectoryLink fp | isWindows = recover (liftIO $ removeDirectoryLink fp) | otherwise = liftIO $ removeDirectoryLink fp + + +rmPathForcibly :: ( MonadIO m + , MonadMask m + ) + => GHCupPath + -> m () +rmPathForcibly fp + | isWindows = recover (liftIO $ removePathForcibly fp) + | otherwise = liftIO $ removePathForcibly fp + + +-- | The file extension for executables. +exeExt :: String +exeExt + | isWindows = ".exe" + | otherwise = "" + +-- | The file extension for executables. +exeExt' :: ByteString +exeExt' + | isWindows = ".exe" + | otherwise = "" + + +rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m () +rmLink fp + | isWindows = do + hideError doesNotExistErrorType . recycleFile $ fp + hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim") + | otherwise = hideError doesNotExistErrorType . recycleFile $ fp + + +-- | Creates a symbolic link on unix and a fake symlink on windows for +-- executables, which: +-- 1. is a shim exe +-- 2. has a corresponding .shim file in the same directory that +-- contains the target +-- +-- This overwrites previously existing files. +-- +-- On windows, this requires that 'ensureGlobalTools' was run beforehand. +createLink :: ( MonadMask m + , MonadThrow m + , HasLog env + , MonadIO m + , MonadReader env m + , HasDirs env + , MonadUnliftIO m + , MonadFail m + ) + => FilePath -- ^ path to the target executable + -> FilePath -- ^ path to be created + -> m () +createLink link exe + | isWindows = do + dirs <- getDirs + let shimGen = fromGHCupPath (cacheDir dirs) "gs.exe" + + let shim = dropExtension exe <.> "shim" + -- For hardlinks, link needs to be absolute. + -- If link is relative, it's relative to the target exe. + -- Note that () drops lhs when rhs is absolute. + fullLink = takeDirectory exe link + shimContents = "path = " <> fullLink + + logDebug $ "rm -f " <> T.pack exe + rmLink exe + + logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe + liftIO $ copyFile shimGen exe False + liftIO $ writeFile shim shimContents + | otherwise = do + logDebug $ "rm -f " <> T.pack exe + hideError doesNotExistErrorType $ recycleFile exe + + logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe + liftIO $ createFileLink link exe diff --git a/lib/GHCup/Prelude/File/Posix.hs b/lib/GHCup/Prelude/File/Posix.hs new file mode 100644 index 0000000..1b774ac --- /dev/null +++ b/lib/GHCup/Prelude/File/Posix.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE CApiFFI #-} + +{-| +Module : GHCup.Utils.File.Posix +Description : File and directory handling for unix +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : POSIX +-} +module GHCup.Prelude.File.Posix where + +import GHCup.Prelude.File.Posix.Traversals + +import Control.Exception.Safe +import Control.Monad.Reader +import Foreign.C.String +import Foreign.C.Error +import Foreign.C.Types +import System.IO ( hClose, hSetBinaryMode ) +import System.IO.Error hiding ( catchIOError ) +import System.FilePath +import System.Directory ( removeFile, pathIsSymbolicLink, getSymbolicLinkTarget, doesPathExist ) +import System.Posix.Directory +import System.Posix.Error ( throwErrnoPathIfMinus1Retry ) +import System.Posix.Internals ( withFilePath ) +import System.Posix.Files +import System.Posix.Types + + +import qualified System.Posix.Directory as PD +import qualified System.Posix.Files as PF +import qualified System.Posix.IO as SPI +import qualified System.Posix as Posix +import qualified Streamly.FileSystem.Handle as FH +import qualified Streamly.Internal.FileSystem.Handle + as IFH +import qualified Streamly.Prelude as S +import qualified GHCup.Prelude.File.Posix.Foreign as FD +import qualified Streamly.Internal.Data.Stream.StreamD.Type + as D +import Streamly.Internal.Data.Unfold.Type +import qualified Streamly.Internal.Data.Unfold as U +import Streamly.Internal.Control.Concurrent ( withRunInIO ) +import Streamly.Internal.Data.IOFinalizer ( newIOFinalizer, runIOFinalizer ) + + +-- | On unix, we can use symlinks, so we just get the +-- symbolic link target. +-- +-- On windows, we have to emulate symlinks via shims, +-- see 'createLink'. +getLinkTarget :: FilePath -> IO FilePath +getLinkTarget = getSymbolicLinkTarget + + +-- | Checks whether the path is a link. +pathIsLink :: FilePath -> IO Bool +pathIsLink = pathIsSymbolicLink + + +chmod_755 :: MonadIO m => FilePath -> m () +chmod_755 fp = do + let exe_mode = + nullFileMode + `unionFileModes` ownerExecuteMode + `unionFileModes` ownerReadMode + `unionFileModes` ownerWriteMode + `unionFileModes` groupExecuteMode + `unionFileModes` groupReadMode + `unionFileModes` otherExecuteMode + `unionFileModes` otherReadMode + liftIO $ setFileMode fp exe_mode + + +-- |Default permissions for a new file. +newFilePerms :: FileMode +newFilePerms = + ownerWriteMode + `unionFileModes` ownerReadMode + `unionFileModes` groupWriteMode + `unionFileModes` groupReadMode + `unionFileModes` otherWriteMode + `unionFileModes` otherReadMode + + +-- | Checks whether the binary is a broken link. +isBrokenSymlink :: FilePath -> IO Bool +isBrokenSymlink fp = do + try (pathIsSymbolicLink fp) >>= \case + Right True -> do + let symDir = takeDirectory fp + tfp <- getSymbolicLinkTarget fp + not <$> doesPathExist + -- this drops 'symDir' if 'tfp' is absolute + (symDir tfp) + Right b -> pure b + Left e | isDoesNotExistError e -> pure False + | otherwise -> throwIO e + +copyFile :: FilePath -- ^ source file + -> FilePath -- ^ destination file + -> Bool -- ^ fail if file exists + -> IO () +copyFile from to fail' = do + bracket + (openFdHandle from SPI.ReadOnly [FD.oNofollow] Nothing) + (hClose . snd) + $ \(fromFd, fH) -> do + sourceFileMode <- fileMode <$> getFdStatus fromFd + let dflags = [ FD.oNofollow + , if fail' then FD.oExcl else FD.oTrunc + ] + bracket + (openFdHandle to SPI.WriteOnly dflags $ Just sourceFileMode) + (hClose . snd) + $ \(_, tH) -> do + hSetBinaryMode fH True + hSetBinaryMode tH True + streamlyCopy (fH, tH) + where + openFdHandle fp omode flags fM = do + fd <- openFd' fp omode flags fM + handle' <- SPI.fdToHandle fd + pure (fd, handle') + streamlyCopy (fH, tH) = + S.fold (FH.writeChunks tH) $ IFH.toChunksWithBufferOf (256 * 1024) fH + +foreign import capi unsafe "fcntl.h 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 -> + handleIO (\e -> if doesNotExistErrorType == ioeGetErrorType e then pure () else liftIO . ioError $ e) $ 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) + +moveFile :: FilePath -> FilePath -> IO () +moveFile = rename + + +moveFilePortable :: FilePath -> FilePath -> IO () +moveFilePortable from to = do + catchErrno [eXDEV] (moveFile from to) $ do + copyFile from to True + removeFile from + + +catchErrno :: [Errno] -- ^ errno to catch + -> IO a -- ^ action to try, which can raise an IOException + -> IO a -- ^ action to carry out in case of an IOException and + -- if errno matches + -> IO a +catchErrno en a1 a2 = + catchIOError a1 $ \e -> do + errno <- getErrno + if errno `elem` en + then a2 + else ioError e + +removeEmptyDirectory :: FilePath -> IO () +removeEmptyDirectory = PD.removeDirectory + + +-- | Create an 'Unfold' of directory contents. +unfoldDirContents :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath (FD.DirType, FilePath) +unfoldDirContents = U.bracket (liftIO . openDirStream) (liftIO . closeDirStream) (Unfold step return) + where + {-# INLINE [0] step #-} + step dirstream = do + (typ, e) <- liftIO $ readDirEnt dirstream + return $ if + | null e -> D.Stop + | "." == e -> D.Skip dirstream + | ".." == e -> D.Skip dirstream + | otherwise -> D.Yield (typ, e) dirstream + + +getDirectoryContentsRecursiveDFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m) + => FilePath + -> S.SerialT m FilePath +getDirectoryContentsRecursiveDFSUnsafe fp = go "" + where + go cd = flip S.concatMap (S.unfold unfoldDirContents (fp cd)) $ \(t, f) -> + if | t == FD.dtDir -> go (cd f) + | otherwise -> pure (cd f) + + +getDirectoryContentsRecursiveUnfold :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath FilePath +getDirectoryContentsRecursiveUnfold = Unfold step (\s -> return (s, Nothing, [""])) + where + {-# INLINE [0] step #-} + step (_, Nothing, []) = return D.Stop + + step (topdir, Just (cdir, dirstream, finalizer), dirs) = flip onException (runIOFinalizer finalizer) $ do + (dt, f) <- liftIO $ readDirEnt dirstream + if | FD.dtUnknown == dt -> do + runIOFinalizer finalizer + return $ D.Skip (topdir, Nothing, dirs) + | f == "." || f == ".." + -> return $ D.Skip (topdir, Just (cdir, dirstream, finalizer), dirs) + | FD.dtDir == dt -> return $ D.Skip (topdir, Just (cdir, dirstream, finalizer), (cdir f):dirs) + | otherwise -> return $ D.Yield (cdir f) (topdir, Just (cdir, dirstream, finalizer), dirs) + + step (topdir, Nothing, dir:dirs) = do + (s, f) <- acquire (topdir dir) + return $ D.Skip (topdir, Just (dir, s, f), dirs) + + acquire dir = + withRunInIO $ \run -> mask_ $ run $ do + dirstream <- liftIO $ openDirStream dir + ref <- newIOFinalizer (liftIO $ closeDirStream dirstream) + return (dirstream, ref) + +getDirectoryContentsRecursiveBFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m) + => FilePath + -> S.SerialT m FilePath +getDirectoryContentsRecursiveBFSUnsafe = S.unfold getDirectoryContentsRecursiveUnfold + + diff --git a/lib/GHCup/Utils/File/Posix/Foreign.hsc b/lib/GHCup/Prelude/File/Posix/Foreign.hsc similarity index 97% rename from lib/GHCup/Utils/File/Posix/Foreign.hsc rename to lib/GHCup/Prelude/File/Posix/Foreign.hsc index 445b311..ed3f696 100644 --- a/lib/GHCup/Utils/File/Posix/Foreign.hsc +++ b/lib/GHCup/Prelude/File/Posix/Foreign.hsc @@ -1,6 +1,6 @@ {-# LANGUAGE PatternSynonyms #-} -module GHCup.Utils.File.Posix.Foreign where +module GHCup.Prelude.File.Posix.Foreign where import Data.Bits import Data.List (foldl') diff --git a/lib/GHCup/Utils/File/Posix/Traversals.hs b/lib/GHCup/Prelude/File/Posix/Traversals.hs similarity index 96% rename from lib/GHCup/Utils/File/Posix/Traversals.hs rename to lib/GHCup/Prelude/File/Posix/Traversals.hs index 1c1a241..f3a0490 100644 --- a/lib/GHCup/Utils/File/Posix/Traversals.hs +++ b/lib/GHCup/Prelude/File/Posix/Traversals.hs @@ -7,7 +7,7 @@ {-# OPTIONS_GHC -Wall #-} -module GHCup.Utils.File.Posix.Traversals ( +module GHCup.Prelude.File.Posix.Traversals ( -- lower-level stuff readDirEnt , unpackDirStream @@ -17,7 +17,7 @@ module GHCup.Utils.File.Posix.Traversals ( #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif -import GHCup.Utils.File.Posix.Foreign +import GHCup.Prelude.File.Posix.Foreign import Unsafe.Coerce (unsafeCoerce) import Foreign.C.Error diff --git a/lib/GHCup/Utils/File/Common.hs b/lib/GHCup/Prelude/File/Search.hs similarity index 86% rename from lib/GHCup/Utils/File/Common.hs rename to lib/GHCup/Prelude/File/Search.hs index 3a923e6..6a667c5 100644 --- a/lib/GHCup/Utils/File/Common.hs +++ b/lib/GHCup/Prelude/File/Search.hs @@ -2,13 +2,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} -module GHCup.Utils.File.Common ( - module GHCup.Utils.File.Common +module GHCup.Prelude.File.Search ( + module GHCup.Prelude.File.Search , ProcessError(..) , CapturedProcess(..) ) where -import GHCup.Utils.Prelude import GHCup.Types(ProcessError(..), CapturedProcess(..)) import Control.Monad.Reader @@ -27,6 +26,8 @@ import Text.Regex.Posix import qualified Data.Text as T import qualified Text.Megaparsec as MP +import Control.Exception.Safe (handleIO) +import System.Directory.Internal.Prelude (ioeGetErrorType) @@ -38,7 +39,7 @@ searchPath paths needle = go paths where go [] = pure Nothing go (x : xs) = - hideErrorDefM [InappropriateType, PermissionDenied, NoSuchThing] (go xs) + handleIO (\e -> if ioeGetErrorType e `elem` [InappropriateType, PermissionDenied, NoSuchThing] then go xs else ioError e) $ do contents <- listDirectory x findM (isMatch x) contents >>= \case @@ -52,6 +53,12 @@ searchPath paths needle = go paths isExecutable :: FilePath -> IO Bool isExecutable file = executable <$> getPermissions file + -- TODO: inlined from GHCup.Prelude + findM ~p = foldr (\x -> ifM (p x) (pure $ Just x)) (pure Nothing) + ifM ~b ~t ~f = do + b' <- b + if b' then t else f + -- | Check wether a binary is shadowed by another one that comes before -- it in PATH. Returns the path to said binary, if any. @@ -106,7 +113,3 @@ findFiles' path parser = do pure $ filter (\fp -> either (const False) (const True) $ MP.parse parser "" (T.pack fp)) contents -checkFileAlreadyExists :: (MonadIO m) => FilePath -> m Bool -checkFileAlreadyExists fp = liftIO $ doesFileExist fp - - diff --git a/lib/GHCup/Utils/File/Windows.hs b/lib/GHCup/Prelude/File/Windows.hs similarity index 52% rename from lib/GHCup/Utils/File/Windows.hs rename to lib/GHCup/Prelude/File/Windows.hs index 84d979b..acfca8b 100644 --- a/lib/GHCup/Utils/File/Windows.hs +++ b/lib/GHCup/Prelude/File/Windows.hs @@ -4,48 +4,28 @@ {-| Module : GHCup.Utils.File.Windows -Description : File and windows APIs +Description : File and directory handling for windows Copyright : (c) Julian Ospald, 2020 License : LGPL-3.0 Maintainer : hasufell@hasufell.de Stability : experimental Portability : Windows - -This module handles file and executable handling. -Some of these functions use sophisticated logging. -} -module GHCup.Utils.File.Windows where +module GHCup.Prelude.File.Windows where -import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink ) import GHCup.Utils.Dirs -import GHCup.Utils.File.Common -import GHCup.Utils.Logger -import GHCup.Types -import GHCup.Types.Optics +import GHCup.Prelude.Internal -import Control.Concurrent -import Control.DeepSeq import Control.Exception.Safe import Control.Monad import Control.Monad.Reader import Data.List -import Foreign.C.Error -import GHC.IO.Exception -import GHC.IO.Handle import qualified GHC.Unicode as U -import System.Environment import System.FilePath -import System.IO import qualified System.IO.Error as IOE -import System.Process import qualified System.Win32.Info as WS import qualified System.Win32.File as WS -import qualified Control.Exception as EX -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BL -import qualified Data.Map.Strict as Map -import qualified Data.Text as T import qualified Streamly.Internal.Data.Stream.StreamD.Type as D @@ -58,188 +38,23 @@ import Streamly.Internal.Data.IOFinalizer ( newIOFinalizer, runIOFin -toProcessError :: FilePath - -> [FilePath] - -> ExitCode - -> Either ProcessError () -toProcessError exe args exitcode = case exitcode of - (ExitFailure xi) -> Left $ NonZeroExit xi exe args - ExitSuccess -> Right () - - --- | @readCreateProcessWithExitCode@ works exactly like 'readProcessWithExitCode' except that it --- lets you pass 'CreateProcess' giving better flexibility. +-- | On unix, we can use symlinks, so we just get the +-- symbolic link target. -- --- Note that @Handle@s provided for @std_in@, @std_out@, or @std_err@ via the CreateProcess --- record will be ignored. --- --- @since 1.2.3.0 -readCreateProcessWithExitCodeBS - :: CreateProcess - -> BL.ByteString - -> IO (ExitCode, BL.ByteString, BL.ByteString) -- ^ exitcode, stdout, stderr -readCreateProcessWithExitCodeBS cp input = do - let cp_opts = cp { - std_in = CreatePipe, - std_out = CreatePipe, - std_err = CreatePipe - } - withCreateProcess_ "readCreateProcessWithExitCodeBS" cp_opts $ - \mb_inh mb_outh mb_errh ph -> - case (mb_inh, mb_outh, mb_errh) of - (Just inh, Just outh, Just errh) -> do - - out <- BS.hGetContents outh - err <- BS.hGetContents errh - - -- fork off threads to start consuming stdout & stderr - withForkWait (EX.evaluate $ rnf out) $ \waitOut -> - withForkWait (EX.evaluate $ rnf err) $ \waitErr -> do - - -- now write any input - unless (BL.null input) $ - ignoreSigPipe $ BL.hPut inh input - -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE - ignoreSigPipe $ hClose inh - - -- wait on the output - waitOut - waitErr - - hClose outh - hClose errh - - -- wait on the process - ex <- waitForProcess ph - return (ex, BL.fromStrict out, BL.fromStrict err) - - (Nothing,_,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdin handle." - (_,Nothing,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdout handle." - (_,_,Nothing) -> error "readCreateProcessWithExitCodeBS: Failed to get a stderr handle." - where - ignoreSigPipe :: IO () -> IO () - ignoreSigPipe = EX.handle $ \e -> case e of - IOError { ioe_type = ResourceVanished - , ioe_errno = Just ioe } - | Errno ioe == ePIPE -> return () - _ -> throwIO e - -- wrapper so we can get exceptions with the appropriate function name. - withCreateProcess_ - :: String - -> CreateProcess - -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) - -> IO a - withCreateProcess_ fun c action = - EX.bracketOnError (createProcess_ fun c) cleanupProcess - (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph) - --- | Fork a thread while doing something else, but kill it if there's an --- exception. --- --- This is important in the cases above because we want to kill the thread --- that is holding the Handle lock, because when we clean up the process we --- try to close that handle, which could otherwise deadlock. --- -withForkWait :: IO () -> (IO () -> IO a) -> IO a -withForkWait async' body = do - waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ())) - mask $ \restore -> do - tid <- forkIO $ try (restore async') >>= putMVar waitVar - let wait' = takeMVar waitVar >>= either throwIO return - restore (body wait') `EX.onException` killThread tid +-- On windows, we have to emulate symlinks via shims, +-- see 'createLink'. +getLinkTarget :: FilePath -> IO FilePath +getLinkTarget fp = do + content <- readFile (dropExtension fp <.> "shim") + [p] <- pure . filter ("path = " `isPrefixOf`) . lines $ content + pure $ stripNewline $ dropPrefix "path = " p --- | Execute the given command and collect the stdout, stderr and the exit code. --- The command is run in a subprocess. -executeOut :: MonadIO m - => FilePath -- ^ command as filename, e.g. 'ls' - -> [String] -- ^ arguments to the command - -> Maybe FilePath -- ^ chdir to this path - -> m CapturedProcess -executeOut path args chdir = do - cp <- createProcessWithMingwPath ((proc path args){ cwd = chdir }) - (exit, out, err) <- liftIO $ readCreateProcessWithExitCodeBS cp "" - pure $ CapturedProcess exit out err +-- | Checks whether the path is a link. +pathIsLink :: FilePath -> IO Bool +pathIsLink fp = doesPathExist (dropExtension fp <.> "shim") -execLogged :: ( MonadReader env m - , HasDirs env - , HasLog env - , HasSettings env - , MonadIO m - , MonadThrow m) - => FilePath -- ^ thing to execute - -> [String] -- ^ args for the thing - -> Maybe FilePath -- ^ optionally chdir into this - -> FilePath -- ^ log filename (opened in append mode) - -> Maybe [(String, String)] -- ^ optional environment - -> m (Either ProcessError ()) -execLogged exe args chdir lfile env = do - Dirs {..} <- getDirs - logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args - let stdoutLogfile = fromGHCupPath logsDir lfile <> ".stdout.log" - stderrLogfile = fromGHCupPath logsDir lfile <> ".stderr.log" - cp <- createProcessWithMingwPath ((proc exe args) - { cwd = chdir - , env = env - , std_in = CreatePipe - , std_out = CreatePipe - , std_err = CreatePipe - }) - fmap (toProcessError exe args) - $ liftIO - $ withCreateProcess cp - $ \_ mout merr ph -> - case (mout, merr) of - (Just cStdout, Just cStderr) -> do - withForkWait (tee stdoutLogfile cStdout) $ \waitOut -> - withForkWait (tee stderrLogfile cStderr) $ \waitErr -> do - waitOut - waitErr - waitForProcess ph - _ -> fail "Could not acquire out/err handle" - - where - tee :: FilePath -> Handle -> IO () - tee logFile handle' = go - where - go = do - some <- BS.hGetSome handle' 512 - if BS.null some - then pure () - else do - void $ BS.appendFile logFile some - -- subprocess stdout also goes to stderr for logging - void $ BS.hPut stderr some - go - - --- | Thin wrapper around `executeFile`. -exec :: MonadIO m - => FilePath -- ^ thing to execute - -> [FilePath] -- ^ args for the thing - -> Maybe FilePath -- ^ optionally chdir into this - -> Maybe [(String, String)] -- ^ optional environment - -> m (Either ProcessError ()) -exec exe args chdir env = do - cp <- createProcessWithMingwPath ((proc exe args) { cwd = chdir, env = env }) - exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p - pure $ toProcessError exe args exit_code - - --- | Thin wrapper around `executeFile`. -execShell :: MonadIO m - => FilePath -- ^ thing to execute - -> [FilePath] -- ^ args for the thing - -> Maybe FilePath -- ^ optionally chdir into this - -> Maybe [(String, String)] -- ^ optional environment - -> m (Either ProcessError ()) -execShell exe args chdir env = do - let cmd = exe <> " " <> concatMap (' ':) args - cp <- createProcessWithMingwPath ((shell cmd) { cwd = chdir, env = env }) - exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p - pure $ toProcessError cmd [] exit_code - chmod_755 :: MonadIO m => FilePath -> m () chmod_755 fp = @@ -247,30 +62,6 @@ chmod_755 fp = in liftIO $ setPermissions fp perm -createProcessWithMingwPath :: MonadIO m - => CreateProcess - -> m CreateProcess -createProcessWithMingwPath cp = do - msys2Dir <- liftIO ghcupMsys2Dir - cEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (env cp) - let mingWPaths = [msys2Dir "usr" "bin" - ,msys2Dir "mingw64" "bin"] - paths = ["PATH", "Path"] - curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths - newPath = intercalate [searchPathSeparator] (mingWPaths ++ curPaths) - envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths - envWithNewPath = Map.insert "Path" newPath envWithoutPath - liftIO $ setEnv "Path" newPath - pure $ cp { env = Just $ Map.toList envWithNewPath } - -ghcupMsys2Dir :: IO FilePath -ghcupMsys2Dir = - lookupEnv "GHCUP_MSYS2" >>= \case - Just fp -> pure fp - Nothing -> do - baseDir <- liftIO ghcupBaseDir - pure (fromGHCupPath baseDir "msys64") - -- | Checks whether the binary is a broken link. isBrokenSymlink :: FilePath -> IO Bool isBrokenSymlink fp = do diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Prelude/Internal.hs similarity index 80% rename from lib/GHCup/Utils/Prelude.hs rename to lib/GHCup/Prelude/Internal.hs index d39d5d0..093f3e1 100644 --- a/lib/GHCup/Utils/Prelude.hs +++ b/lib/GHCup/Prelude/Internal.hs @@ -7,7 +7,7 @@ {-# LANGUAGE TypeOperators #-} {-| -Module : GHCup.Utils.Prelude +Module : GHCup.Prelude.Internal Description : MegaParsec utilities Copyright : (c) Julian Ospald, 2020 License : LGPL-3.0 @@ -15,28 +15,11 @@ Maintainer : hasufell@hasufell.de Stability : experimental Portability : portable -GHCup specific prelude. Lots of Excepts functionality. +Stuff that doesn't need GHCup modules, so we can avoid +recursive imports. -} -module GHCup.Utils.Prelude - (module GHCup.Utils.Prelude, -#if defined(IS_WINDOWS) - module GHCup.Utils.Prelude.Windows -#else - module GHCup.Utils.Prelude.Posix -#endif - ) -where +module GHCup.Prelude.Internal where -import {-# SOURCE #-} GHCup.Utils.Dirs (GHCupPath, fromGHCupPath, createTempGHCupDirectory, appendGHCupPath, removePathForcibly, removeDirectory) -import GHCup.Types -import GHCup.Errors -import GHCup.Types.Optics -import {-# SOURCE #-} GHCup.Utils.Logger (logWarn) -#if defined(IS_WINDOWS) -import GHCup.Utils.Prelude.Windows -#else -import GHCup.Utils.Prelude.Posix -#endif import Control.Applicative import Control.Exception.Safe @@ -45,23 +28,15 @@ import Control.Monad.IO.Class import Control.Monad.Reader import Data.Bifunctor import Data.ByteString ( ByteString ) -import Data.List ( intercalate, stripPrefix, isPrefixOf, dropWhileEnd, intersperse ) +import Data.List ( intercalate, stripPrefix, isPrefixOf, dropWhileEnd ) import Data.Maybe -import Data.List.NonEmpty ( NonEmpty( (:|) )) import Data.String import Data.Text ( Text ) import Data.Versions import Data.Word8 hiding ( isDigit ) import Haskus.Utils.Types.List import Haskus.Utils.Variant.Excepts -import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty ) import System.IO.Error -import System.Directory hiding ( removeDirectory - , removeDirectoryRecursive - , removePathForcibly - , copyFile - ) -import System.FilePath import Control.Retry import GHC.IO.Exception @@ -70,7 +45,6 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.Strict.Maybe as S import qualified Data.List.Split as Split -import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding.Error as E @@ -184,13 +158,6 @@ lEM' :: forall e' e es a m -> Excepts es m a lEM' f em = lift em >>= lE . first f --- for some obscure reason... this won't type-check if we move it to a different module -catchWarn :: forall es m env . ( Pretty (V es) - , MonadReader env m - , HasLog env - , MonadIO m - , Monad m) => Excepts es m () -> Excepts '[] m () -catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ v)) fromEither :: Either a b -> VEither '[a] b fromEither = either (VLeft . V) VRight @@ -311,56 +278,6 @@ intToText :: Integral a => a -> T.Text intToText = TL.toStrict . B.toLazyText . B.decimal -pvpToVersion :: MonadThrow m => PVP -> Text -> m Version -pvpToVersion pvp_ rest = - either (\_ -> throwM $ ParseError "Couldn't convert PVP to Version") pure . version . (<> rest) . prettyPVP $ pvp_ - --- | Convert a version to a PVP and unparsable rest. --- --- -- prop> \v -> let (Just (pvp', r)) = versionToPVP v in pvpToVersion pvp' r === Just v -versionToPVP :: MonadThrow m => Version -> m (PVP, Text) -versionToPVP (Version (Just _) _ _ _) = throwM $ ParseError "Unexpected epoch" -versionToPVP v = either (\_ -> (, rest v) <$> alternative v) (pure . (, mempty)) . pvp . prettyVer $ v - where - alternative :: MonadThrow m => Version -> m PVP - alternative v' = case NE.takeWhile isDigit (_vChunks v') of - [] -> throwM $ ParseError "Couldn't convert Version to PVP" - xs -> pure $ pvpFromList (unsafeDigit <$> xs) - - rest :: Version -> Text - rest (Version _ cs pr me) = - let chunks = NE.dropWhile isDigit cs - ver = intersperse (T.pack ".") . chunksAsT $ chunks - me' = maybe [] (\m -> [T.pack "+",m]) me - pr' = foldable [] (T.pack "-" :) $ intersperse (T.pack ".") (chunksAsT pr) - prefix = case (ver, pr', me') of - (_:_, _, _) -> T.pack "." - _ -> T.pack "" - in prefix <> mconcat (ver <> pr' <> me') - where - chunksAsT :: Functor t => t VChunk -> t Text - chunksAsT = fmap (foldMap f) - where - f :: VUnit -> Text - f (Digits i) = T.pack $ show i - f (Str s) = s - - foldable :: Foldable f => f b -> (f a -> f b) -> f a -> f b - foldable d g f | null f = d - | otherwise = g f - - - - isDigit :: VChunk -> Bool - isDigit (Digits _ :| []) = True - isDigit _ = False - - unsafeDigit :: VChunk -> Int - unsafeDigit (Digits x :| []) = fromIntegral x - unsafeDigit _ = error "unsafeDigit: wrong input" - -pvpFromList :: [Int] -> PVP -pvpFromList = PVP . NE.fromList . fmap fromIntegral -- | Safe 'decodeUtf8With'. Replaces an invalid input byte with -- the Unicode replacement character U+FFFD. diff --git a/lib/GHCup/Prelude/Logger.hs b/lib/GHCup/Prelude/Logger.hs new file mode 100644 index 0000000..b256cf9 --- /dev/null +++ b/lib/GHCup/Prelude/Logger.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : GHCup.Utils.Logger +Description : logger definition +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable + +Here we define our main logger. +-} +module GHCup.Prelude.Logger + ( module GHCup.Prelude.Logger + , module GHCup.Prelude.Logger.Internal + ) +where + +import GHCup.Prelude.Logger.Internal +import GHCup.Types +import GHCup.Types.Optics +import GHCup.Utils.Dirs (fromGHCupPath) +import GHCup.Prelude.Internal +import GHCup.Prelude.File.Search (findFiles) +import GHCup.Prelude.File (recycleFile) +import GHCup.Prelude.String.QQ + +import Control.Exception.Safe +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Reader +import Prelude hiding ( appendFile ) +import System.FilePath +import System.IO.Error +import Text.Regex.Posix + +import qualified Data.ByteString as B + + + +initGHCupFileLogging :: ( MonadReader env m + , HasDirs env + , MonadIO m + , MonadMask m + ) => m FilePath +initGHCupFileLogging = do + Dirs { logsDir } <- getDirs + let logfile = fromGHCupPath logsDir "ghcup.log" + logFiles <- liftIO $ findFiles + (fromGHCupPath logsDir) + (makeRegexOpts compExtended + execBlank + ([s|^.*\.log$|] :: B.ByteString) + ) + forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (fromGHCupPath logsDir ) + + liftIO $ writeFile logfile "" + pure logfile diff --git a/lib/GHCup/Utils/Logger.hs b/lib/GHCup/Prelude/Logger/Internal.hs similarity index 70% rename from lib/GHCup/Utils/Logger.hs rename to lib/GHCup/Prelude/Logger/Internal.hs index 2d003b5..446f10e 100644 --- a/lib/GHCup/Utils/Logger.hs +++ b/lib/GHCup/Prelude/Logger/Internal.hs @@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-| -Module : GHCup.Utils.Logger +Module : GHCup.Utils.Logger.Internal Description : logger definition Copyright : (c) Julian Ospald, 2020 License : LGPL-3.0 @@ -11,18 +11,13 @@ Maintainer : hasufell@hasufell.de Stability : experimental Portability : portable -Here we define our main logger. +Breaking import cycles. -} -module GHCup.Utils.Logger where +module GHCup.Prelude.Logger.Internal where import GHCup.Types import GHCup.Types.Optics -import {-# SOURCE #-} GHCup.Utils.Dirs (fromGHCupPath) -import {-# SOURCE #-} GHCup.Utils.File.Common (findFiles) -import {-# SOURCE #-} GHCup.Utils.File (recycleFile) -import GHCup.Utils.String.QQ -import Control.Exception.Safe import Control.Monad import Control.Monad.IO.Class import Control.Monad.Reader @@ -30,12 +25,7 @@ import Data.Text ( Text ) import Optics import Prelude hiding ( appendFile ) import System.Console.Pretty -import System.FilePath -import System.IO.Error -import Text.Regex.Posix -import qualified Data.ByteString as B -import GHCup.Utils.Prelude import qualified Data.Text as T logInfo :: ( MonadReader env m @@ -93,7 +83,7 @@ logInternal logLevel msg = do let strs = T.split (== '\n') msg let out = case strs of [] -> T.empty - (x:xs) -> + (x:xs) -> foldr (\a b -> a <> "\n" <> b) mempty . ((l <> " " <> x) :) . fmap (\line' -> style' "[ ... ] " <> line' ) @@ -111,22 +101,3 @@ logInternal logLevel msg = do let outr = lr <> " " <> msg <> "\n" liftIO $ fileOutter outr - -initGHCupFileLogging :: ( MonadReader env m - , HasDirs env - , MonadIO m - , MonadMask m - ) => m FilePath -initGHCupFileLogging = do - Dirs { logsDir } <- getDirs - let logfile = fromGHCupPath logsDir "ghcup.log" - logFiles <- liftIO $ findFiles - (fromGHCupPath logsDir) - (makeRegexOpts compExtended - execBlank - ([s|^.*\.log$|] :: B.ByteString) - ) - forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (fromGHCupPath logsDir ) - - liftIO $ writeFile logfile "" - pure logfile diff --git a/lib/GHCup/Utils/MegaParsec.hs b/lib/GHCup/Prelude/MegaParsec.hs similarity index 98% rename from lib/GHCup/Utils/MegaParsec.hs rename to lib/GHCup/Prelude/MegaParsec.hs index b622eb8..2f8d06b 100644 --- a/lib/GHCup/Utils/MegaParsec.hs +++ b/lib/GHCup/Prelude/MegaParsec.hs @@ -10,7 +10,7 @@ Maintainer : hasufell@hasufell.de Stability : experimental Portability : portable -} -module GHCup.Utils.MegaParsec where +module GHCup.Prelude.MegaParsec where import GHCup.Types diff --git a/lib/GHCup/Utils/Posix.hs b/lib/GHCup/Prelude/Posix.hs similarity index 78% rename from lib/GHCup/Utils/Posix.hs rename to lib/GHCup/Prelude/Posix.hs index 4b2dcee..c7c13de 100644 --- a/lib/GHCup/Utils/Posix.hs +++ b/lib/GHCup/Prelude/Posix.hs @@ -1,4 +1,4 @@ -module GHCup.Utils.Posix where +module GHCup.Prelude.Posix where -- | Enables ANSI support on windows, does nothing on unix. @@ -12,3 +12,8 @@ module GHCup.Utils.Posix where enableAnsiSupport :: IO (Either String Bool) enableAnsiSupport = pure (Right True) +isWindows, isNotWindows :: Bool +isWindows = False +isNotWindows = not isWindows + + diff --git a/lib/GHCup/Prelude/Process.hs b/lib/GHCup/Prelude/Process.hs new file mode 100644 index 0000000..ed38b4e --- /dev/null +++ b/lib/GHCup/Prelude/Process.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE CPP #-} + +{-| +Module : GHCup.Utils.Process +Description : Process handling +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable +-} +module GHCup.Prelude.Process ( + executeOut, + execLogged, + exec, + toProcessError, +) where + + +#if IS_WINDOWS +import GHCup.Prelude.Process.Windows +#else +import GHCup.Prelude.Process.Posix +#endif + diff --git a/lib/GHCup/Utils/File/Posix.hs b/lib/GHCup/Prelude/Process/Posix.hs similarity index 54% rename from lib/GHCup/Utils/File/Posix.hs rename to lib/GHCup/Prelude/Process/Posix.hs index 1ff0f2f..4e9670b 100644 --- a/lib/GHCup/Utils/File/Posix.hs +++ b/lib/GHCup/Prelude/Process/Posix.hs @@ -6,25 +6,22 @@ {-| Module : GHCup.Utils.File.Posix -Description : File and unix APIs +Description : Process handling for unix Copyright : (c) Julian Ospald, 2020 License : LGPL-3.0 Maintainer : hasufell@hasufell.de Stability : experimental Portability : POSIX - -This module handles file and executable handling. -Some of these functions use sophisticated logging. -} -module GHCup.Utils.File.Posix where +module GHCup.Prelude.Process.Posix where import GHCup.Utils.Dirs -import GHCup.Utils.File.Common -import GHCup.Utils.Prelude -import GHCup.Utils.Logger +import GHCup.Prelude.File +import GHCup.Prelude.File.Posix +import GHCup.Prelude +import GHCup.Prelude.Logger import GHCup.Types import GHCup.Types.Optics -import GHCup.Utils.File.Posix.Traversals import Control.Concurrent import Control.Concurrent.Async @@ -39,17 +36,11 @@ import Data.IORef import Data.Sequence ( Seq, (|>) ) import Data.List import Data.Word8 -import Foreign.C.String -import Foreign.C.Error -import Foreign.C.Types import GHC.IO.Exception -import System.IO ( stderr, hClose, hSetBinaryMode ) +import System.IO ( stderr ) import System.IO.Error hiding ( catchIOError ) import System.FilePath import System.Posix.Directory -import System.Posix.Error ( throwErrnoPathIfMinus1Retry ) -import System.Posix.Internals ( withFilePath ) -import System.Posix.Files import System.Posix.IO import System.Posix.Process ( ProcessStatus(..) ) import System.Posix.Types @@ -59,27 +50,12 @@ import qualified Control.Exception as EX import qualified Data.Sequence as Sq import qualified Data.Text as T import qualified Data.Text.Encoding as E -import qualified System.Posix.Directory as PD -import qualified System.Posix.Files as PF 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.Posix as Posix import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import qualified "unix-bytestring" System.Posix.IO.ByteString 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 -import qualified Streamly.Internal.Data.Stream.StreamD.Type - as D -import Streamly.Internal.Data.Unfold.Type -import qualified Streamly.Internal.Data.Unfold as U -import Streamly.Internal.Control.Concurrent ( withRunInIO ) -import Streamly.Internal.Data.IOFinalizer ( newIOFinalizer, runIOFinalizer ) @@ -384,262 +360,3 @@ toProcessError exe args mps = case mps of -chmod_755 :: (MonadReader env m, HasLog env, MonadIO m) => FilePath -> m () -chmod_755 fp = do - let exe_mode = - nullFileMode - `unionFileModes` ownerExecuteMode - `unionFileModes` ownerReadMode - `unionFileModes` ownerWriteMode - `unionFileModes` groupExecuteMode - `unionFileModes` groupReadMode - `unionFileModes` otherExecuteMode - `unionFileModes` otherReadMode - logDebug ("chmod 755 " <> T.pack fp) - liftIO $ setFileMode fp exe_mode - - --- |Default permissions for a new file. -newFilePerms :: FileMode -newFilePerms = - ownerWriteMode - `unionFileModes` ownerReadMode - `unionFileModes` groupWriteMode - `unionFileModes` groupReadMode - `unionFileModes` otherWriteMode - `unionFileModes` otherReadMode - - --- | Checks whether the binary is a broken link. -isBrokenSymlink :: FilePath -> IO Bool -isBrokenSymlink fp = do - try (pathIsSymbolicLink fp) >>= \case - Right True -> do - let symDir = takeDirectory fp - tfp <- getSymbolicLinkTarget fp - not <$> doesPathExist - -- this drops 'symDir' if 'tfp' is absolute - (symDir tfp) - Right b -> pure b - Left e | isDoesNotExistError e -> pure False - | otherwise -> throwIO e - -copyFile :: FilePath -- ^ source file - -> FilePath -- ^ destination file - -> Bool -- ^ fail if file exists - -> IO () -copyFile from to fail' = do - bracket - (openFdHandle from SPI.ReadOnly [FD.oNofollow] Nothing) - (hClose . snd) - $ \(fromFd, fH) -> do - sourceFileMode <- fileMode <$> getFdStatus fromFd - let dflags = [ FD.oNofollow - , if fail' then FD.oExcl else FD.oTrunc - ] - bracket - (openFdHandle to SPI.WriteOnly dflags $ Just sourceFileMode) - (hClose . snd) - $ \(_, tH) -> do - hSetBinaryMode fH True - hSetBinaryMode tH True - streamlyCopy (fH, tH) - where - openFdHandle fp omode flags fM = do - fd <- openFd' fp omode flags fM - handle' <- SPI.fdToHandle fd - pure (fd, handle') - streamlyCopy (fH, tH) = - S.fold (FH.writeChunks tH) $ IFH.toChunksWithBufferOf (256 * 1024) fH - -foreign import capi unsafe "fcntl.h 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) - -moveFile :: FilePath -> FilePath -> IO () -moveFile = rename - - -moveFilePortable :: FilePath -> FilePath -> IO () -moveFilePortable from to = do - catchErrno [eXDEV] (moveFile from to) $ do - copyFile from to True - removeFile from - - -catchErrno :: [Errno] -- ^ errno to catch - -> IO a -- ^ action to try, which can raise an IOException - -> IO a -- ^ action to carry out in case of an IOException and - -- if errno matches - -> IO a -catchErrno en a1 a2 = - catchIOError a1 $ \e -> do - errno <- getErrno - if errno `elem` en - then a2 - else ioError e - -removeEmptyDirectory :: FilePath -> IO () -removeEmptyDirectory = PD.removeDirectory - - --- | Create an 'Unfold' of directory contents. -unfoldDirContents :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath (FD.DirType, FilePath) -unfoldDirContents = U.bracket (liftIO . openDirStream) (liftIO . closeDirStream) (Unfold step return) - where - {-# INLINE [0] step #-} - step dirstream = do - (typ, e) <- liftIO $ readDirEnt dirstream - return $ if - | null e -> D.Stop - | "." == e -> D.Skip dirstream - | ".." == e -> D.Skip dirstream - | otherwise -> D.Yield (typ, e) dirstream - - -getDirectoryContentsRecursiveDFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m) - => FilePath - -> S.SerialT m FilePath -getDirectoryContentsRecursiveDFSUnsafe fp = go "" - where - go cd = flip S.concatMap (S.unfold unfoldDirContents (fp cd)) $ \(t, f) -> - if | t == FD.dtDir -> go (cd f) - | otherwise -> pure (cd f) - - -getDirectoryContentsRecursiveUnfold :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath FilePath -getDirectoryContentsRecursiveUnfold = Unfold step (\s -> return (s, Nothing, [""])) - where - {-# INLINE [0] step #-} - step (_, Nothing, []) = return D.Stop - - step (topdir, Just (cdir, dirstream, finalizer), dirs) = flip onException (runIOFinalizer finalizer) $ do - (dt, f) <- liftIO $ readDirEnt dirstream - if | FD.dtUnknown == dt -> do - runIOFinalizer finalizer - return $ D.Skip (topdir, Nothing, dirs) - | f == "." || f == ".." - -> return $ D.Skip (topdir, Just (cdir, dirstream, finalizer), dirs) - | FD.dtDir == dt -> return $ D.Skip (topdir, Just (cdir, dirstream, finalizer), (cdir f):dirs) - | otherwise -> return $ D.Yield (cdir f) (topdir, Just (cdir, dirstream, finalizer), dirs) - - step (topdir, Nothing, dir:dirs) = do - (s, f) <- acquire (topdir dir) - return $ D.Skip (topdir, Just (dir, s, f), dirs) - - acquire dir = - withRunInIO $ \run -> mask_ $ run $ do - dirstream <- liftIO $ openDirStream dir - ref <- newIOFinalizer (liftIO $ closeDirStream dirstream) - return (dirstream, ref) - -getDirectoryContentsRecursiveBFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m) - => FilePath - -> S.SerialT m FilePath -getDirectoryContentsRecursiveBFSUnsafe = S.unfold getDirectoryContentsRecursiveUnfold - - diff --git a/lib/GHCup/Prelude/Process/Windows.hs b/lib/GHCup/Prelude/Process/Windows.hs new file mode 100644 index 0000000..17c75ac --- /dev/null +++ b/lib/GHCup/Prelude/Process/Windows.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} + +{-| +Module : GHCup.Utils.Process.Windows +Description : Process handling for windows +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : Windows +-} +module GHCup.Prelude.Process.Windows where + +import GHCup.Utils.Dirs +import GHCup.Prelude.File.Search +import GHCup.Prelude.Logger.Internal +import GHCup.Types +import GHCup.Types.Optics + +import Control.Concurrent +import Control.DeepSeq +import Control.Exception.Safe +import Control.Monad +import Control.Monad.Reader +import Data.List +import Foreign.C.Error +import GHC.IO.Exception +import GHC.IO.Handle +import System.Environment +import System.FilePath +import System.IO +import System.Process + +import qualified Control.Exception as EX +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.Map.Strict as Map +import qualified Data.Text as T + + + + +toProcessError :: FilePath + -> [FilePath] + -> ExitCode + -> Either ProcessError () +toProcessError exe args exitcode = case exitcode of + (ExitFailure xi) -> Left $ NonZeroExit xi exe args + ExitSuccess -> Right () + + +-- | @readCreateProcessWithExitCode@ works exactly like 'readProcessWithExitCode' except that it +-- lets you pass 'CreateProcess' giving better flexibility. +-- +-- Note that @Handle@s provided for @std_in@, @std_out@, or @std_err@ via the CreateProcess +-- record will be ignored. +-- +-- @since 1.2.3.0 +readCreateProcessWithExitCodeBS + :: CreateProcess + -> BL.ByteString + -> IO (ExitCode, BL.ByteString, BL.ByteString) -- ^ exitcode, stdout, stderr +readCreateProcessWithExitCodeBS cp input = do + let cp_opts = cp { + std_in = CreatePipe, + std_out = CreatePipe, + std_err = CreatePipe + } + withCreateProcess_ "readCreateProcessWithExitCodeBS" cp_opts $ + \mb_inh mb_outh mb_errh ph -> + case (mb_inh, mb_outh, mb_errh) of + (Just inh, Just outh, Just errh) -> do + + out <- BS.hGetContents outh + err <- BS.hGetContents errh + + -- fork off threads to start consuming stdout & stderr + withForkWait (EX.evaluate $ rnf out) $ \waitOut -> + withForkWait (EX.evaluate $ rnf err) $ \waitErr -> do + + -- now write any input + unless (BL.null input) $ + ignoreSigPipe $ BL.hPut inh input + -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE + ignoreSigPipe $ hClose inh + + -- wait on the output + waitOut + waitErr + + hClose outh + hClose errh + + -- wait on the process + ex <- waitForProcess ph + return (ex, BL.fromStrict out, BL.fromStrict err) + + (Nothing,_,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdin handle." + (_,Nothing,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdout handle." + (_,_,Nothing) -> error "readCreateProcessWithExitCodeBS: Failed to get a stderr handle." + where + ignoreSigPipe :: IO () -> IO () + ignoreSigPipe = EX.handle $ \e -> case e of + IOError { ioe_type = ResourceVanished + , ioe_errno = Just ioe } + | Errno ioe == ePIPE -> return () + _ -> throwIO e + -- wrapper so we can get exceptions with the appropriate function name. + withCreateProcess_ + :: String + -> CreateProcess + -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) + -> IO a + withCreateProcess_ fun c action = + EX.bracketOnError (createProcess_ fun c) cleanupProcess + (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph) + +-- | Fork a thread while doing something else, but kill it if there's an +-- exception. +-- +-- This is important in the cases above because we want to kill the thread +-- that is holding the Handle lock, because when we clean up the process we +-- try to close that handle, which could otherwise deadlock. +-- +withForkWait :: IO () -> (IO () -> IO a) -> IO a +withForkWait async' body = do + waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ())) + mask $ \restore -> do + tid <- forkIO $ try (restore async') >>= putMVar waitVar + let wait' = takeMVar waitVar >>= either throwIO return + restore (body wait') `EX.onException` killThread tid + + +-- | Execute the given command and collect the stdout, stderr and the exit code. +-- The command is run in a subprocess. +executeOut :: MonadIO m + => FilePath -- ^ command as filename, e.g. 'ls' + -> [String] -- ^ arguments to the command + -> Maybe FilePath -- ^ chdir to this path + -> m CapturedProcess +executeOut path args chdir = do + cp <- createProcessWithMingwPath ((proc path args){ cwd = chdir }) + (exit, out, err) <- liftIO $ readCreateProcessWithExitCodeBS cp "" + pure $ CapturedProcess exit out err + + +execLogged :: ( MonadReader env m + , HasDirs env + , HasLog env + , HasSettings env + , MonadIO m + , MonadThrow m) + => FilePath -- ^ thing to execute + -> [String] -- ^ args for the thing + -> Maybe FilePath -- ^ optionally chdir into this + -> FilePath -- ^ log filename (opened in append mode) + -> Maybe [(String, String)] -- ^ optional environment + -> m (Either ProcessError ()) +execLogged exe args chdir lfile env = do + Dirs {..} <- getDirs + logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args + let stdoutLogfile = fromGHCupPath logsDir lfile <> ".stdout.log" + stderrLogfile = fromGHCupPath logsDir lfile <> ".stderr.log" + cp <- createProcessWithMingwPath ((proc exe args) + { cwd = chdir + , env = env + , std_in = CreatePipe + , std_out = CreatePipe + , std_err = CreatePipe + }) + fmap (toProcessError exe args) + $ liftIO + $ withCreateProcess cp + $ \_ mout merr ph -> + case (mout, merr) of + (Just cStdout, Just cStderr) -> do + withForkWait (tee stdoutLogfile cStdout) $ \waitOut -> + withForkWait (tee stderrLogfile cStderr) $ \waitErr -> do + waitOut + waitErr + waitForProcess ph + _ -> fail "Could not acquire out/err handle" + + where + tee :: FilePath -> Handle -> IO () + tee logFile handle' = go + where + go = do + some <- BS.hGetSome handle' 512 + if BS.null some + then pure () + else do + void $ BS.appendFile logFile some + -- subprocess stdout also goes to stderr for logging + void $ BS.hPut stderr some + go + + +-- | Thin wrapper around `executeFile`. +exec :: MonadIO m + => FilePath -- ^ thing to execute + -> [FilePath] -- ^ args for the thing + -> Maybe FilePath -- ^ optionally chdir into this + -> Maybe [(String, String)] -- ^ optional environment + -> m (Either ProcessError ()) +exec exe args chdir env = do + cp <- createProcessWithMingwPath ((proc exe args) { cwd = chdir, env = env }) + exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p + pure $ toProcessError exe args exit_code + + +-- | Thin wrapper around `executeFile`. +execShell :: MonadIO m + => FilePath -- ^ thing to execute + -> [FilePath] -- ^ args for the thing + -> Maybe FilePath -- ^ optionally chdir into this + -> Maybe [(String, String)] -- ^ optional environment + -> m (Either ProcessError ()) +execShell exe args chdir env = do + let cmd = exe <> " " <> concatMap (' ':) args + cp <- createProcessWithMingwPath ((shell cmd) { cwd = chdir, env = env }) + exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p + pure $ toProcessError cmd [] exit_code + + +createProcessWithMingwPath :: MonadIO m + => CreateProcess + -> m CreateProcess +createProcessWithMingwPath cp = do + msys2Dir <- liftIO ghcupMsys2Dir + cEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (env cp) + let mingWPaths = [msys2Dir "usr" "bin" + ,msys2Dir "mingw64" "bin"] + paths = ["PATH", "Path"] + curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths + newPath = intercalate [searchPathSeparator] (mingWPaths ++ curPaths) + envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths + envWithNewPath = Map.insert "Path" newPath envWithoutPath + liftIO $ setEnv "Path" newPath + pure $ cp { env = Just $ Map.toList envWithNewPath } + +ghcupMsys2Dir :: IO FilePath +ghcupMsys2Dir = + lookupEnv "GHCUP_MSYS2" >>= \case + Just fp -> pure fp + Nothing -> do + baseDir <- liftIO ghcupBaseDir + pure (fromGHCupPath baseDir "msys64") + diff --git a/lib/GHCup/Utils/String/QQ.hs b/lib/GHCup/Prelude/String/QQ.hs similarity index 97% rename from lib/GHCup/Utils/String/QQ.hs rename to lib/GHCup/Prelude/String/QQ.hs index ec249de..822a34e 100644 --- a/lib/GHCup/Utils/String/QQ.hs +++ b/lib/GHCup/Prelude/String/QQ.hs @@ -30,7 +30,7 @@ Any instance of the IsString type is permitted. (For GHC versions 6, write "[$s||]" instead of "[s||]".) -} -module GHCup.Utils.String.QQ +module GHCup.Prelude.String.QQ ( s ) where diff --git a/lib/GHCup/Utils/Version/QQ.hs b/lib/GHCup/Prelude/Version/QQ.hs similarity index 98% rename from lib/GHCup/Utils/Version/QQ.hs rename to lib/GHCup/Prelude/Version/QQ.hs index fe87237..d3d03c6 100644 --- a/lib/GHCup/Utils/Version/QQ.hs +++ b/lib/GHCup/Prelude/Version/QQ.hs @@ -16,7 +16,7 @@ Maintainer : hasufell@hasufell.de Stability : experimental Portability : portable -} -module GHCup.Utils.Version.QQ where +module GHCup.Prelude.Version.QQ where import Data.Data import Data.Text ( Text ) diff --git a/lib/GHCup/Utils/Windows.hs b/lib/GHCup/Prelude/Windows.hs similarity index 93% rename from lib/GHCup/Utils/Windows.hs rename to lib/GHCup/Prelude/Windows.hs index 14ffbd8..25b8731 100644 --- a/lib/GHCup/Utils/Windows.hs +++ b/lib/GHCup/Prelude/Windows.hs @@ -3,7 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -module GHCup.Utils.Windows where +module GHCup.Prelude.Windows where import Control.Exception.Safe @@ -46,3 +46,8 @@ enableAnsiSupport = handleIO (pure . Left . displayException) $ do >> pure (Right False) else pure (Right True) + +isWindows, isNotWindows :: Bool +isWindows = True +isNotWindows = not isWindows + diff --git a/lib/GHCup/Stack.hs b/lib/GHCup/Stack.hs new file mode 100644 index 0000000..cfc7587 --- /dev/null +++ b/lib/GHCup/Stack.hs @@ -0,0 +1,278 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : GHCup.Stack +Description : GHCup installation functions for Stack +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable +-} +module GHCup.Stack where + +import GHCup.Download +import GHCup.Errors +import GHCup.Types +import GHCup.Types.JSON ( ) +import GHCup.Types.Optics +import GHCup.Utils +import GHCup.Prelude +import GHCup.Prelude.File +import GHCup.Prelude.Logger + +import Codec.Archive ( ArchiveResult ) +import Control.Applicative +import Control.Exception.Safe +import Control.Monad +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource + hiding ( throwM ) +import Data.Either +import Data.List +import Data.Maybe +import Data.Versions hiding ( patch ) +import Haskus.Utils.Variant.Excepts +import Optics +import Prelude hiding ( abs + , writeFile + ) +import Safe hiding ( at ) +import System.FilePath +import System.IO.Error + +import qualified Data.Text as T + + + + -------------------- + --[ Installation ]-- + -------------------- + + +-- | Installs stack into @~\/.ghcup\/bin/stack-\@ and +-- creates a default @stack -> stack-x.y.z.q@ symlink for +-- the latest installed version. +installStackBin :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , HasGHCupInfo env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => Version + -> InstallDir + -> Bool -- ^ Force install + -> Excepts + '[ AlreadyInstalled + , CopyError + , DigestError + , GPGError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist + , ArchiveResult + , FileAlreadyExistsError + ] + m + () +installStackBin ver installDir forceInstall = do + dlinfo <- liftE $ getDownloadInfo Stack ver + installStackBindist dlinfo ver installDir forceInstall + + +-- | Like 'installStackBin', except takes the 'DownloadInfo' as +-- argument instead of looking it up from 'GHCupDownloads'. +installStackBindist :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasPlatformReq env + , HasDirs env + , HasSettings env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => DownloadInfo + -> Version + -> InstallDir + -> Bool -- ^ Force install + -> Excepts + '[ AlreadyInstalled + , CopyError + , DigestError + , GPGError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist + , ArchiveResult + , FileAlreadyExistsError + ] + m + () +installStackBindist dlinfo ver installDir forceInstall = do + lift $ logDebug $ "Requested to install stack version " <> prettyVer ver + + PlatformRequest {..} <- lift getPlatformReq + Dirs {..} <- lift getDirs + + regularStackInstalled <- lift $ stackInstalled ver + + if + | not forceInstall + , regularStackInstalled + , GHCupInternal <- installDir -> do + throwE $ AlreadyInstalled Stack ver + + | forceInstall + , regularStackInstalled + , GHCupInternal <- installDir -> do + lift $ logInfo "Removing the currently installed version of Stack first!" + liftE $ rmStackVer ver + + | otherwise -> pure () + + -- download (or use cached version) + dl <- liftE $ downloadCached dlinfo Nothing + + -- unpack + tmpUnpack <- lift withGHCupTmpDir + liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) + + -- the subdir of the archive where we do the work + workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) + + case installDir of + IsolateDir isoDir -> do -- isolated install + lift $ logInfo $ "isolated installing Stack to " <> T.pack isoDir + liftE $ installStackUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall + GHCupInternal -> do -- regular install + liftE $ installStackUnpacked workdir (GHCupBinDir binDir) ver forceInstall + + +-- | Install an unpacked stack distribution. +installStackUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m) + => GHCupPath -- ^ Path to the unpacked stack bindist (where the executable resides) + -> InstallDirResolved + -> Version + -> Bool -- ^ Force install + -> Excepts '[CopyError, FileAlreadyExistsError] m () +installStackUnpacked path installDir ver forceInstall = do + lift $ logInfo "Installing stack" + let stackFile = "stack" + liftIO $ createDirRecursive' (fromInstallDir installDir) + let destFileName = stackFile + <> (case installDir of + IsolateDirResolved _ -> "" + _ -> ("-" <>) . T.unpack . prettyVer $ ver + ) + <> exeExt + destPath = fromInstallDir installDir destFileName + + copyFileE + (fromGHCupPath path stackFile <> exeExt) + destPath + (not forceInstall) + lift $ chmod_755 destPath + + + + ----------------- + --[ Set stack ]-- + ----------------- + + +-- | Set the @~\/.ghcup\/bin\/stack@ symlink. +setStack :: ( MonadMask m + , MonadReader env m + , HasDirs env + , HasLog env + , MonadThrow m + , MonadFail m + , MonadIO m + , MonadUnliftIO m + ) + => Version + -> Excepts '[NotInstalled] m () +setStack ver = do + let targetFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt + + -- symlink destination + Dirs {..} <- lift getDirs + + whenM (liftIO $ not <$> doesFileExist (binDir targetFile)) + $ throwE + $ NotInstalled Stack (GHCTargetVersion Nothing ver) + + let stackbin = binDir "stack" <> exeExt + + lift $ createLink targetFile stackbin + + pure () + + +unsetStack :: ( MonadMask m + , MonadReader env m + , HasDirs env + , MonadIO m) + => m () +unsetStack = do + Dirs {..} <- getDirs + let stackbin = binDir "stack" <> exeExt + hideError doesNotExistErrorType $ rmLink stackbin + + + ---------------- + --[ Rm stack ]-- + ---------------- + +-- | Delete a stack version. Will try to fix the @stack@ symlink +-- after removal (e.g. setting it to an older version). +rmStackVer :: ( MonadMask m + , MonadReader env m + , HasDirs env + , MonadThrow m + , HasLog env + , MonadIO m + , MonadFail m + , MonadCatch m + , MonadUnliftIO m + ) + => Version + -> Excepts '[NotInstalled] m () +rmStackVer ver = do + whenM (lift $ fmap not $ stackInstalled ver) $ throwE (NotInstalled Stack (GHCTargetVersion Nothing ver)) + + sSet <- lift stackSet + + Dirs {..} <- lift getDirs + + let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt + lift $ hideError doesNotExistErrorType $ recycleFile (binDir stackFile) + + when (Just ver == sSet) $ do + sVers <- lift $ fmap rights getInstalledStacks + case headMay . reverse . sort $ sVers of + Just latestver -> setStack latestver + Nothing -> lift $ rmLink (binDir "stack" <> exeExt) diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 3918de7..63761d2 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -26,8 +26,7 @@ module GHCup.Types ) where -import {-# SOURCE #-} GHCup.Utils.Dirs ( fromGHCupPath ) -import {-# SOURCE #-} GHCup.Utils.Dirs ( GHCupPath ) +import {-# SOURCE #-} GHCup.Utils.Dirs ( fromGHCupPath, GHCupPath ) import Control.DeepSeq ( NFData, rnf ) import Data.Map.Strict ( Map ) diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index 8d7cd3b..35d8b83 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -23,7 +23,7 @@ module GHCup.Types.JSON where import GHCup.Types import GHCup.Types.JSON.Utils -import GHCup.Utils.MegaParsec +import GHCup.Prelude.MegaParsec import Control.Applicative ( (<|>) ) import Data.Aeson hiding (Key) diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 6a161a2..e46bf69 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -23,18 +23,18 @@ module GHCup.Utils ( module GHCup.Utils.Dirs , module GHCup.Utils #if defined(IS_WINDOWS) - , module GHCup.Utils.Windows + , module GHCup.Prelude.Windows #else - , module GHCup.Utils.Posix + , module GHCup.Prelude.Posix #endif ) where #if defined(IS_WINDOWS) -import GHCup.Utils.Windows +import GHCup.Prelude.Windows #else -import GHCup.Utils.Posix +import GHCup.Prelude.Posix #endif import GHCup.Download import GHCup.Errors @@ -42,11 +42,13 @@ import GHCup.Types import GHCup.Types.Optics import GHCup.Types.JSON ( ) import GHCup.Utils.Dirs -import GHCup.Utils.File -import GHCup.Utils.Logger -import GHCup.Utils.MegaParsec -import GHCup.Utils.Prelude -import GHCup.Utils.String.QQ +import GHCup.Version +import GHCup.Prelude +import GHCup.Prelude.File +import GHCup.Prelude.Logger.Internal +import GHCup.Prelude.MegaParsec +import GHCup.Prelude.Process +import GHCup.Prelude.String.QQ import Codec.Archive hiding ( Directory ) import Control.Applicative @@ -75,6 +77,7 @@ import Safe import System.FilePath import System.IO.Error import Text.Regex.Posix +import Text.PrettyPrint.HughesPJClass (prettyShow) import URI.ByteString import qualified Codec.Compression.BZip as BZip @@ -99,14 +102,14 @@ import GHC.IO (evaluate) -- >>> import System.Directory -- >>> import URI.ByteString -- >>> import qualified Data.Text as T --- >>> import GHCup.Utils.Prelude +-- >>> import GHCup.Prelude -- >>> import GHCup.Download -- >>> import GHCup.Version -- >>> import GHCup.Errors -- >>> import GHCup.Types -- >>> import GHCup.Types.Optics -- >>> import Optics --- >>> import GHCup.Utils.Version.QQ +-- >>> import GHCup.Prelude.Version.QQ -- >>> import qualified Data.Text.Encoding as E -- >>> import Control.Monad.Reader -- >>> import Haskus.Utils.Variant.Excepts @@ -1019,6 +1022,28 @@ applyPatch patch ddir = do !? PatchFailed +applyAnyPatch :: ( MonadReader env m + , HasDirs env + , HasLog env + , HasSettings env + , MonadUnliftIO m + , MonadCatch m + , MonadResource m + , MonadThrow m + , MonadMask m + , MonadIO m) + => Maybe (Either FilePath [URI]) + -> FilePath + -> Excepts '[PatchFailed, DownloadFailed, DigestError, GPGError] m () +applyAnyPatch Nothing _ = pure () +applyAnyPatch (Just (Left pdir)) workdir = liftE $ applyPatches pdir workdir +applyAnyPatch (Just (Right uris)) workdir = do + tmpUnpack <- fromGHCupPath <$> lift withGHCupTmpDir + forM_ uris $ \uri -> do + patch <- liftE $ download uri Nothing Nothing tmpUnpack Nothing False + liftE $ applyPatch patch workdir + + -- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353 darwinNotarization :: (MonadReader env m, HasDirs env, MonadIO m) => Platform @@ -1134,97 +1159,6 @@ getVersionInfo v' tool = ) --- | The file extension for executables. -exeExt :: String -exeExt - | isWindows = ".exe" - | otherwise = "" - --- | The file extension for executables. -exeExt' :: ByteString -exeExt' - | isWindows = ".exe" - | otherwise = "" - - - - --- | On unix, we can use symlinks, so we just get the --- symbolic link target. --- --- On windows, we have to emulate symlinks via shims, --- see 'createLink'. -getLinkTarget :: FilePath -> IO FilePath -getLinkTarget fp - | isWindows = do - content <- readFile (dropExtension fp <.> "shim") - [p] <- pure . filter ("path = " `isPrefixOf`) . lines $ content - pure $ stripNewline $ dropPrefix "path = " p - | otherwise = getSymbolicLinkTarget fp - - --- | Checks whether the path is a link. -pathIsLink :: FilePath -> IO Bool -pathIsLink fp - | isWindows = doesPathExist (dropExtension fp <.> "shim") - | otherwise = pathIsSymbolicLink fp - - -rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m () -rmLink fp - | isWindows = do - hideError doesNotExistErrorType . recycleFile $ fp - hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim") - | otherwise = hideError doesNotExistErrorType . recycleFile $ fp - - --- | Creates a symbolic link on unix and a fake symlink on windows for --- executables, which: --- 1. is a shim exe --- 2. has a corresponding .shim file in the same directory that --- contains the target --- --- This overwrites previously existing files. --- --- On windows, this requires that 'ensureGlobalTools' was run beforehand. -createLink :: ( MonadMask m - , MonadThrow m - , HasLog env - , MonadIO m - , MonadReader env m - , HasDirs env - , MonadUnliftIO m - , MonadFail m - ) - => FilePath -- ^ path to the target executable - -> FilePath -- ^ path to be created - -> m () -createLink link exe - | isWindows = do - dirs <- getDirs - let shimGen = fromGHCupPath (cacheDir dirs) "gs.exe" - - let shim = dropExtension exe <.> "shim" - -- For hardlinks, link needs to be absolute. - -- If link is relative, it's relative to the target exe. - -- Note that () drops lhs when rhs is absolute. - fullLink = takeDirectory exe link - shimContents = "path = " <> fullLink - - logDebug $ "rm -f " <> T.pack exe - rmLink exe - - logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe - liftIO $ copyFile shimGen exe False - liftIO $ writeFile shim shimContents - | otherwise = do - logDebug $ "rm -f " <> T.pack exe - hideError doesNotExistErrorType $ recycleFile exe - - logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe - liftIO $ createFileLink link exe - - ensureGlobalTools :: ( MonadMask m , MonadThrow m , HasLog env @@ -1316,3 +1250,28 @@ getInstalledFiles t v' = hideErrorDef [doesNotExistErrorType] Nothing $ do pure (Just $ lines c) +-- | Warn if the installed and set HLS is not compatible with the installed and +-- set GHC version. +warnAboutHlsCompatibility :: ( MonadReader env m + , HasDirs env + , HasLog env + , MonadThrow m + , MonadCatch m + , MonadIO m + ) + => m () +warnAboutHlsCompatibility = do + supportedGHC <- hlsGHCVersions + currentGHC <- fmap _tvVersion <$> ghcSet Nothing + currentHLS <- hlsSet + + case (currentGHC, currentHLS) of + (Just gv, Just hv) | gv `notElem` supportedGHC -> do + logWarn $ + "GHC " <> T.pack (prettyShow gv) <> " is not compatible with " <> + "Haskell Language Server " <> T.pack (prettyShow hv) <> "." <> "\n" <> + "Haskell IDE support may not work until this is fixed." <> "\n" <> + "Install a different HLS version, or install and set one of the following GHCs:" <> "\n" <> + T.pack (prettyShow supportedGHC) + + _ -> return () diff --git a/lib/GHCup/Utils.hs-boot b/lib/GHCup/Utils.hs-boot deleted file mode 100644 index e534e82..0000000 --- a/lib/GHCup/Utils.hs-boot +++ /dev/null @@ -1,4 +0,0 @@ -module GHCup.Utils where - -getLinkTarget :: FilePath -> IO FilePath -pathIsLink :: FilePath -> IO Bool diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs index 817d2ac..c2c026a 100644 --- a/lib/GHCup/Utils/Dirs.hs +++ b/lib/GHCup/Utils/Dirs.hs @@ -99,9 +99,6 @@ module GHCup.Utils.Dirs , setAccessTime , setModificationTime , isSymbolicLink - - -- uhm - , rmPathForcibly ) where @@ -110,11 +107,15 @@ import GHCup.Errors import GHCup.Types import GHCup.Types.JSON ( ) import GHCup.Types.Optics -import GHCup.Utils.MegaParsec -import GHCup.Utils.Logger -import GHCup.Utils.Prelude -import GHCup.Utils.File.Common -import GHCup.Utils.String.QQ +import GHCup.Prelude.MegaParsec +import GHCup.Prelude.File.Search +import GHCup.Prelude.String.QQ +import GHCup.Prelude.Logger.Internal (logWarn, logDebug) +#if defined(IS_WINDOWS) +import GHCup.Prelude.Windows ( isWindows ) +#else +import GHCup.Prelude.Posix ( isWindows ) +#endif import Control.DeepSeq (NFData, rnf) import Control.Exception.Safe @@ -147,6 +148,7 @@ import qualified Data.ByteString as BS import qualified Data.Text as T import qualified Data.Yaml.Aeson as Y import qualified Text.Megaparsec as MP +import System.IO.Error (ioeGetErrorType) @@ -371,10 +373,15 @@ ghcupConfigFile :: (MonadIO m) => Excepts '[JSONError] m UserSettings ghcupConfigFile = do filepath <- getConfigFilePath - contents <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> BS.readFile filepath + contents <- liftIO $ handleIO (\e -> if NoSuchThing == ioeGetErrorType e then pure Nothing else liftIO $ ioError e) $ Just <$> BS.readFile filepath case contents of Nothing -> pure defaultUserSettings - Just contents' -> lE' JSONDecodeError . first displayException . Y.decodeEither' $ contents' + Just contents' -> liftE + . veitherToExcepts @_ @'[JSONError] + . either (VLeft . V) VRight + . first (JSONDecodeError . displayException) + . Y.decodeEither' + $ contents' ------------------------- @@ -411,6 +418,12 @@ parseGHCupHLSDir :: MonadThrow m => FilePath -> m Version parseGHCupHLSDir (T.pack -> fp) = throwEither $ MP.parse version' "" fp +-- TODO: inlined from GHCup.Prelude +throwEither :: (Exception a, MonadThrow m) => Either a b -> m b +throwEither a = case a of + Left e -> throwM e + Right r -> pure r + -- | ~/.ghcup/hls by default, for new-style installs. ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath ghcupHLSBaseDir = do @@ -459,7 +472,7 @@ withGHCupTmpDir = snd <$> withRunInIO (\run -> (\fp -> handleIO (\e -> run $ logDebug ("Resource cleanup failed for " <> T.pack (fromGHCupPath fp) <> ", error was: " <> T.pack (displayException e))) - . rmPathForcibly + . removePathForcibly $ fp)) @@ -522,13 +535,5 @@ removePathForcibly :: GHCupPath -> IO () removePathForcibly (GHCupPath fp) = SD.removePathForcibly fp -rmPathForcibly :: ( MonadIO m - , MonadMask m - ) - => GHCupPath - -> m () -rmPathForcibly fp - | isWindows = recover (liftIO $ removePathForcibly fp) - | otherwise = liftIO $ removePathForcibly fp diff --git a/lib/GHCup/Utils/File.hs-boot b/lib/GHCup/Utils/File.hs-boot deleted file mode 100644 index 2da9c00..0000000 --- a/lib/GHCup/Utils/File.hs-boot +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module GHCup.Utils.File ( - recycleFile -) where - -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Catch (MonadMask) -import Control.Monad.Reader (MonadReader) -import GHCup.Types.Optics (HasDirs) - - -recycleFile :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env) => FilePath -> m () - diff --git a/lib/GHCup/Utils/File/Common.hs-boot b/lib/GHCup/Utils/File/Common.hs-boot deleted file mode 100644 index 5933883..0000000 --- a/lib/GHCup/Utils/File/Common.hs-boot +++ /dev/null @@ -1,5 +0,0 @@ -module GHCup.Utils.File.Common where - -import Text.Regex.Posix - -findFiles :: FilePath -> Regex -> IO [FilePath] diff --git a/lib/GHCup/Utils/Logger.hs-boot b/lib/GHCup/Utils/Logger.hs-boot deleted file mode 100644 index 9e3b1b9..0000000 --- a/lib/GHCup/Utils/Logger.hs-boot +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DataKinds #-} - -module GHCup.Utils.Logger where - -import GHCup.Types - -import Control.Monad.IO.Class -import Control.Monad.Reader -import Data.Text ( Text ) -import Optics - -logWarn :: ( MonadReader env m - , LabelOptic' "loggerConfig" A_Lens env LoggerConfig - , MonadIO m - ) - => Text - -> m () - diff --git a/lib/GHCup/Utils/Prelude/Posix.hs b/lib/GHCup/Utils/Prelude/Posix.hs deleted file mode 100644 index 3945423..0000000 --- a/lib/GHCup/Utils/Prelude/Posix.hs +++ /dev/null @@ -1,8 +0,0 @@ -module GHCup.Utils.Prelude.Posix where - - -isWindows, isNotWindows :: Bool -isWindows = False -isNotWindows = not isWindows - - diff --git a/lib/GHCup/Utils/Prelude/Windows.hs b/lib/GHCup/Utils/Prelude/Windows.hs deleted file mode 100644 index bcdeb41..0000000 --- a/lib/GHCup/Utils/Prelude/Windows.hs +++ /dev/null @@ -1,6 +0,0 @@ -module GHCup.Utils.Prelude.Windows where - -isWindows, isNotWindows :: Bool -isWindows = True -isNotWindows = not isWindows - diff --git a/lib/GHCup/Version.hs b/lib/GHCup/Version.hs index 37926cb..065a49b 100644 --- a/lib/GHCup/Version.hs +++ b/lib/GHCup/Version.hs @@ -16,12 +16,18 @@ import GHCup.Types import Paths_ghcup (version) import Data.Version (Version(versionBranch)) -import Data.Versions hiding (version) import URI.ByteString import URI.ByteString.QQ import qualified Data.List.NonEmpty as NE import qualified Data.Text as T +import qualified Data.Versions as V +import Control.Exception.Safe (MonadThrow) +import Data.Text (Text) +import Data.List.NonEmpty (NonEmpty((:|))) +import Data.List (intersperse) +import Control.Monad.Catch (throwM) +import GHCup.Errors (ParseError(..)) -- | This reflects the API version of the YAML. -- @@ -31,22 +37,72 @@ ghcupURL :: URI ghcupURL = [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-0.0.7.yaml|] -- | The current ghcup version. -ghcUpVer :: PVP -ghcUpVer = PVP . NE.fromList . fmap fromIntegral $ versionBranch version +ghcUpVer :: V.PVP +ghcUpVer = V.PVP . NE.fromList . fmap fromIntegral $ versionBranch version -- | ghcup version as numeric string. numericVer :: String -numericVer = T.unpack . prettyPVP $ ghcUpVer +numericVer = T.unpack . V.prettyPVP $ ghcUpVer -versionCmp :: Versioning -> VersionCmp -> Bool +versionCmp :: V.Versioning -> VersionCmp -> Bool versionCmp ver1 (VR_gt ver2) = ver1 > ver2 versionCmp ver1 (VR_gteq ver2) = ver1 >= ver2 versionCmp ver1 (VR_lt ver2) = ver1 < ver2 versionCmp ver1 (VR_lteq ver2) = ver1 <= ver2 versionCmp ver1 (VR_eq ver2) = ver1 == ver2 -versionRange :: Versioning -> VersionRange -> Bool +versionRange :: V.Versioning -> VersionRange -> Bool versionRange ver' (SimpleRange cmps) = and $ fmap (versionCmp ver') cmps versionRange ver' (OrRange cmps range) = versionRange ver' (SimpleRange cmps) || versionRange ver' range +pvpToVersion :: MonadThrow m => V.PVP -> Text -> m V.Version +pvpToVersion pvp_ rest = + either (\_ -> throwM $ ParseError "Couldn't convert PVP to Version") pure . V.version . (<> rest) . V.prettyPVP $ pvp_ + +-- | Convert a version to a PVP and unparsable rest. +-- +-- -- prop> \v -> let (Just (pvp', r)) = versionToPVP v in pvpToVersion pvp' r === Just v +versionToPVP :: MonadThrow m => V.Version -> m (V.PVP, Text) +versionToPVP (V.Version (Just _) _ _ _) = throwM $ ParseError "Unexpected epoch" +versionToPVP v = either (\_ -> (, rest v) <$> alternative v) (pure . (, mempty)) . V.pvp . V.prettyVer $ v + where + alternative :: MonadThrow m => V.Version -> m V.PVP + alternative v' = case NE.takeWhile isDigit (V._vChunks v') of + [] -> throwM $ ParseError "Couldn't convert Version to PVP" + xs -> pure $ pvpFromList (unsafeDigit <$> xs) + + rest :: V.Version -> Text + rest (V.Version _ cs pr me) = + let chunks = NE.dropWhile isDigit cs + ver = intersperse (T.pack ".") . chunksAsT $ chunks + me' = maybe [] (\m -> [T.pack "+",m]) me + pr' = foldable [] (T.pack "-" :) $ intersperse (T.pack ".") (chunksAsT pr) + prefix = case (ver, pr', me') of + (_:_, _, _) -> T.pack "." + _ -> T.pack "" + in prefix <> mconcat (ver <> pr' <> me') + where + chunksAsT :: Functor t => t V.VChunk -> t Text + chunksAsT = fmap (foldMap f) + where + f :: V.VUnit -> Text + f (V.Digits i) = T.pack $ show i + f (V.Str s) = s + + foldable :: Foldable f => f b -> (f a -> f b) -> f a -> f b + foldable d g f | null f = d + | otherwise = g f + + + + isDigit :: V.VChunk -> Bool + isDigit (V.Digits _ :| []) = True + isDigit _ = False + + unsafeDigit :: V.VChunk -> Int + unsafeDigit (V.Digits x :| []) = fromIntegral x + unsafeDigit _ = error "unsafeDigit: wrong input" + +pvpFromList :: [Int] -> V.PVP +pvpFromList = V.PVP . NE.fromList . fmap fromIntegral diff --git a/test/GHCup/Utils/FileSpec.hs b/test/GHCup/Utils/FileSpec.hs index 8bcc53c..aac4e3d 100644 --- a/test/GHCup/Utils/FileSpec.hs +++ b/test/GHCup/Utils/FileSpec.hs @@ -1,6 +1,6 @@ module GHCup.Utils.FileSpec where -import GHCup.Utils.File +import GHCup.Prelude.File import Data.List import System.Directory