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

{-# LANGUAGE CPP                 #-}
{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}

module GHCup.Prelude.File (
  mergeFileTree,
  copyFileE,
  findFilesDeep,
  getDirectoryContentsRecursive,
  getDirectoryContentsRecursiveBFS,
  getDirectoryContentsRecursiveDFS,
  getDirectoryContentsRecursiveUnsafe,
  getDirectoryContentsRecursiveBFSUnsafe,
  getDirectoryContentsRecursiveDFSUnsafe,
  recordedInstallationFile,
  module GHCup.Prelude.File.Search,

  chmod_755,
  isBrokenSymlink,
  copyFile,
  deleteFile,
  install,
  removeEmptyDirectory,
  removeDirIfEmptyOrIsSymlink,
  removeEmptyDirsRecursive,
  rmFileForce,
  createDirRecursive',
  recyclePathForcibly,
  rmDirectory,
  recycleFile,
  rmFile,
  rmDirectoryLink,
  moveFilePortable,
  moveFile,
  rmPathForcibly,

  exeExt,
  exeExt',
  getLinkTarget,
  pathIsLink,
  rmLink,
  createLink
) where

import GHCup.Utils.Dirs
import GHCup.Prelude.Logger.Internal (logInfo, logDebug)
import GHCup.Prelude.Internal
import GHCup.Prelude.File.Search
#if IS_WINDOWS
import GHCup.Prelude.File.Windows
import GHCup.Prelude.Windows
#else
import GHCup.Prelude.File.Posix
import GHCup.Prelude.Posix
#endif
import           GHCup.Errors
import           GHCup.Types
import           GHCup.Types.Optics

import           Text.Regex.Posix
import           Control.Monad.IO.Unlift        ( MonadUnliftIO )
import           Control.Exception.Safe
import           Control.Monad.Reader
import           Data.ByteString                ( ByteString )
import           Haskus.Utils.Variant.Excepts
import           System.FilePath
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


-- | 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
              -> Excepts '[MergeFileTreeError] m ()
mergeFileTree _ (GHCupBinDir fp) _ _ _ =
  throwIO $ userError ("mergeFileTree: internal error, called on " <> fp)
mergeFileTree sourceBase destBase tool v' copyOp = do
  lift $ logInfo $ "Merging file tree from \""
       <> T.pack (fromGHCupPath sourceBase)
       <> "\" to \""
       <> T.pack (fromInstallDir destBase)
       <> "\""
  recFile <- recordedInstallationFile tool v'

  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)

  -- 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
  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 (fromInstallDir destBase)


  recordInstalledFile f recFile = when (isSafeDir destBase) $
    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!")



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

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 ()
removeEmptyDirsRecursive = go
 where
  go fp = do
    cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>)
    forM_ cs go
    liftIO $ removeEmptyDirectory fp

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


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 'ensureShimGen' 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