312 lines
10 KiB
Haskell
312 lines
10 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
|
|
{-|
|
|
Module : GHCup.Utils.File.Windows
|
|
Description : File and directory handling for windows
|
|
Copyright : (c) Julian Ospald, 2020
|
|
License : LGPL-3.0
|
|
Maintainer : hasufell@hasufell.de
|
|
Stability : experimental
|
|
Portability : Windows
|
|
-}
|
|
module GHCup.Prelude.File.Windows where
|
|
|
|
import GHCup.Utils.Dirs
|
|
import GHCup.Prelude.Internal
|
|
|
|
import Control.Exception.Safe
|
|
import Control.Monad
|
|
import Control.Monad.Reader
|
|
import Data.List
|
|
import qualified GHC.Unicode as U
|
|
import System.FilePath
|
|
import qualified System.IO.Error as IOE
|
|
|
|
import qualified System.Win32.Info as WS
|
|
import qualified System.Win32.File as WS
|
|
|
|
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 )
|
|
|
|
|
|
|
|
-- | 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 = do
|
|
content <- readFile (dropExtension fp <.> "shim")
|
|
[p] <- pure . filter ("path = " `isPrefixOf`) . lines $ content
|
|
pure $ stripNewline $ dropPrefix "path = " p
|
|
|
|
|
|
-- | Checks whether the path is a link.
|
|
pathIsLink :: FilePath -> IO Bool
|
|
pathIsLink fp = doesPathExist (dropExtension fp <.> "shim")
|
|
|
|
|
|
|
|
chmod_755 :: MonadIO m => FilePath -> m ()
|
|
chmod_755 fp =
|
|
let perm = setOwnerWritable True emptyPermissions
|
|
in liftIO $ setPermissions fp perm
|
|
|
|
|
|
-- | Checks whether the binary is a broken link.
|
|
isBrokenSymlink :: FilePath -> IO Bool
|
|
isBrokenSymlink fp = do
|
|
b <- pathIsLink fp
|
|
if b
|
|
then do
|
|
tfp <- getLinkTarget fp
|
|
not <$> doesPathExist
|
|
-- 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
|
|
|
|
|
|
moveFile :: FilePath -> FilePath -> IO ()
|
|
moveFile from to = WS.moveFileEx from (Just to) 0
|
|
|
|
|
|
moveFilePortable :: FilePath -> FilePath -> IO ()
|
|
moveFilePortable = WS.moveFile
|
|
|
|
|
|
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)
|