325 lines
11 KiB
Haskell
325 lines
11 KiB
Haskell
{-# 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
|
|
|
|
|