ghcup-hs/lib/GHCup/Utils/File.hs

104 lines
3.8 KiB
Haskell
Raw Normal View History

2021-05-14 21:09:45 +00:00
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
2021-05-14 21:09:45 +00:00
module GHCup.Utils.File (
mergeFileTree,
mergeFileTreeAll,
copyFileE,
2021-05-14 21:09:45 +00:00
module GHCup.Utils.File.Common,
#if IS_WINDOWS
module GHCup.Utils.File.Windows
#else
module GHCup.Utils.File.Posix
#endif
) where
import GHCup.Utils.Dirs
2021-05-14 21:09:45 +00:00
import GHCup.Utils.File.Common
#if IS_WINDOWS
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.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
=> 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
=> 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
-> m ()
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.
--
-- 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