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

312 lines
10 KiB
Haskell
Raw Permalink Normal View History

2021-05-14 21:09:45 +00:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
2022-05-13 09:58:01 +00:00
{-# LANGUAGE DataKinds #-}
2021-05-14 21:09:45 +00:00
{-|
Module : GHCup.Utils.File.Windows
2022-05-21 20:54:18 +00:00
Description : File and directory handling for windows
2021-05-14 21:09:45 +00:00
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : Windows
-}
2022-05-21 20:54:18 +00:00
module GHCup.Prelude.File.Windows where
2021-05-14 21:09:45 +00:00
2022-05-14 15:58:11 +00:00
import GHCup.Utils.Dirs
2022-05-21 20:54:18 +00:00
import GHCup.Prelude.Internal
2021-05-14 21:09:45 +00:00
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Reader
import Data.List
2022-05-14 15:58:11 +00:00
import qualified GHC.Unicode as U
2021-05-14 21:09:45 +00:00
import System.FilePath
2022-05-14 15:58:11 +00:00
import qualified System.IO.Error as IOE
2022-05-14 15:58:11 +00:00
import qualified System.Win32.Info as WS
import qualified System.Win32.File as WS
2021-05-14 21:09:45 +00:00
2022-05-14 15:58:11 +00:00
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 )
2021-05-14 21:09:45 +00:00
2022-05-21 20:54:18 +00:00
-- | On unix, we can use symlinks, so we just get the
-- symbolic link target.
2021-05-14 21:09:45 +00:00
--
2022-05-21 20:54:18 +00:00
-- 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
2021-05-14 21:09:45 +00:00
2022-05-21 20:54:18 +00:00
-- | Checks whether the path is a link.
pathIsLink :: FilePath -> IO Bool
pathIsLink fp = doesPathExist (dropExtension fp <.> "shim")
2022-05-14 15:58:11 +00:00
2021-05-14 21:09:45 +00:00
2021-07-24 14:36:31 +00:00
2021-05-14 21:09:45 +00:00
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
2022-05-20 21:19:33 +00:00
install :: FilePath -> FilePath -> Bool -> IO ()
2022-05-20 22:33:01 +00:00
install = copyFile
2022-05-20 21:19:33 +00:00
moveFile :: FilePath -> FilePath -> IO ()
2022-05-20 22:33:01 +00:00
moveFile from to = WS.moveFileEx from (Just to) 0
2022-05-20 21:19:33 +00:00
moveFilePortable :: FilePath -> FilePath -> IO ()
2022-05-20 22:33:01 +00:00
moveFilePortable = WS.moveFile
2022-05-20 21:19:33 +00:00
removeEmptyDirectory :: FilePath -> IO ()
removeEmptyDirectory = WS.removeDirectory
2022-05-14 15:58:11 +00:00
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)