hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

[WIP] Prototype of recording installed files

Browse Source 
This also installs makefile based build system via DESTDIR
into a temporary directory and then merges it into the filesystem.
This commit is contained in:
Julian Ospald
2022-05-12 17:58:40 +02:00
parent e60b8ee238
commit 48aee1e76c
22 changed files with 628 additions and 117 deletions
Download Patch File Download Diff File Expand all files Collapse all files

7
lib/GHCup/Errors.hs
View File

@@ -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

1
lib/GHCup/Types.hs
View File

@@ -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)

85
lib/GHCup/Utils.hs
View File

@@ -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'))

25
lib/GHCup/Utils/Dirs.hs
View File

@@ -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 { .. }

86
lib/GHCup/Utils/File.hs
View File

@@ -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

8
lib/GHCup/Utils/File/Common.hs
View File

@@ -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

168
lib/GHCup/Utils/File/Posix.hs
View File

@@ -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)

77
lib/GHCup/Utils/File/Posix/Foreign.hsc Normal file
View File

@@ -0,0 +1,77 @@
{-# LANGUAGE PatternSynonyms #-}
module GHCup.Utils.File.Posix.Foreign where
import Data.Bits
import Data.List (foldl')
import Foreign.C.Types
#include <limits.h>
#include <stdlib.h>
#include <dirent.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
newtype DirType = DirType Int deriving (Eq, Show)
data Flags = Flags Int | UnsupportedFlag String deriving (Eq, Show)
unFlags :: Flags -> Int
unFlags (Flags i) = i
unFlags (UnsupportedFlag name) = error (name ++ " is not supported on this platform")
-- |Returns @True@ if posix-paths was compiled with support for the provided
-- flag. (As of this writing, the only flag for which this check may be
-- necessary is 'oCloexec'; all other flags will always yield @True@.)
isSupported :: Flags -> Bool
isSupported (Flags _) = True
isSupported _ = False
-- |@O_CLOEXEC@ is not supported on every POSIX platform. Use
-- @'isSupported' oCloexec@ to determine if support for @O_CLOEXEC@ was
-- compiled into your version of posix-paths. (If not, using @oCloexec@ will
-- throw an exception.)
oCloexec :: Flags
#ifdef O_CLOEXEC
oCloexec = Flags #{const O_CLOEXEC}
#else
{-# WARNING oCloexec
"This version of posix-paths was compiled without @O_CLOEXEC@ support." #-}
oCloexec = UnsupportedFlag "O_CLOEXEC"
#endif
-- If these enum declarations occur earlier in the file, haddock
-- gets royally confused about the above doc comments.
-- Probably http://trac.haskell.org/haddock/ticket/138
#{enum DirType, DirType, DT_BLK, DT_CHR, DT_DIR, DT_FIFO, DT_LNK, DT_REG, DT_SOCK, DT_UNKNOWN}
#{enum Flags, Flags, O_APPEND, O_ASYNC, O_CREAT, O_DIRECTORY, O_EXCL, O_NOCTTY, O_NOFOLLOW, O_NONBLOCK, O_RDONLY, O_WRONLY, O_RDWR, O_SYNC, O_TRUNC}
pathMax :: Int
pathMax = #{const PATH_MAX}
unionFlags :: [Flags] -> CInt
unionFlags = fromIntegral . foldl' ((. unFlags) . (.|.)) 0
pattern DtBlk :: DirType
pattern DtBlk <- dtBlk
pattern DtChr :: DirType
pattern DtChr <- dtChr
pattern DtDir :: DirType
pattern DtDir <- dtdir
pattern DtFifo :: DirType
pattern DtFifo <- dtFifo
pattern DtLnk :: DirType
pattern DtLnk <- dtLnk
pattern DtReg :: DirType
pattern DtReg <- dtReg
pattern DtSock :: DirType
pattern DtSock <- dtSock
pattern DtUnknown :: DirType
pattern DtUnknown <- dtUnknown
{-# COMPLETE DtBlk, DtChr, DtDir, DtFifo, DtLnk, DtReg, DtSock, DtUnknown #-}

18
lib/GHCup/Utils/File/Windows.hs
View File

@@ -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

26
lib/GHCup/Utils/Prelude.hs
View File

@@ -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

2
lib/GHCup/Utils/Prelude/Posix.hs
View File

@@ -17,4 +17,4 @@ moveFilePortable :: FilePath -> FilePath -> IO ()
moveFilePortable from to = do
copyFile from to
removeFile from