module System.Directory.Internal.Windows where
#if defined i386_HOST_ARCH
# define WINAPI stdcall
#elif defined x86_64_HOST_ARCH
# define WINAPI ccall
#else
# error unknown architecture
#endif
import Prelude ()
import System.Directory.Internal.Prelude
import System.Directory.Internal.Common
import Data.Time (UTCTime)
import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime)
import System.FilePath (addTrailingPathSeparator, hasTrailingPathSeparator,
isPathSeparator, isRelative, joinDrive, joinPath,
normalise, pathSeparator, pathSeparators,
splitDirectories, splitDrive, takeExtension)
import qualified Data.List as List
import qualified System.Win32 as Win32
win32_cSIDL_LOCAL_APPDATA :: Win32.CSIDL
win32_cSIDL_LOCAL_APPDATA = Win32.cSIDL_LOCAL_APPDATA
win32_eRROR_INVALID_FUNCTION :: Win32.ErrCode
win32_eRROR_INVALID_FUNCTION = 0x1
win32_fILE_ATTRIBUTE_REPARSE_POINT :: Win32.FileAttributeOrFlag
win32_fILE_ATTRIBUTE_REPARSE_POINT = Win32.fILE_ATTRIBUTE_REPARSE_POINT
win32_fILE_SHARE_DELETE :: Win32.ShareMode
win32_fILE_SHARE_DELETE = Win32.fILE_SHARE_DELETE
maxShareMode :: Win32.ShareMode
maxShareMode =
win32_fILE_SHARE_DELETE .|.
Win32.fILE_SHARE_READ .|.
Win32.fILE_SHARE_WRITE
win32_getLongPathName, win32_getShortPathName :: FilePath -> IO FilePath
win32_getLongPathName = Win32.getLongPathName
win32_getShortPathName = Win32.getShortPathName
win32_getFinalPathNameByHandle :: Win32.HANDLE -> Win32.DWORD -> IO FilePath
win32_getFinalPathNameByHandle _h _flags =
modifyIOError (`ioeSetLocation` "GetFinalPathNameByHandle") $ do
throwIO (mkIOError UnsupportedOperation
"platform does not support GetFinalPathNameByHandle"
Nothing Nothing)
getFinalPathName :: FilePath -> IO FilePath
getFinalPathName =
(fromExtendedLengthPath <$>) . rawGetFinalPathName . toExtendedLengthPath
where
rawGetFinalPathName = win32_getLongPathName <=< win32_getShortPathName
win32_fILE_FLAG_OPEN_REPARSE_POINT :: Win32.FileAttributeOrFlag
win32_fILE_FLAG_OPEN_REPARSE_POINT = 0x00200000
win32_fSCTL_GET_REPARSE_POINT :: Win32.DWORD
win32_fSCTL_GET_REPARSE_POINT = 0x900a8
win32_iO_REPARSE_TAG_MOUNT_POINT, win32_iO_REPARSE_TAG_SYMLINK :: CULong
win32_iO_REPARSE_TAG_MOUNT_POINT = (2684354563)
win32_iO_REPARSE_TAG_SYMLINK = (2684354572)
win32_mAXIMUM_REPARSE_DATA_BUFFER_SIZE :: Win32.DWORD
win32_mAXIMUM_REPARSE_DATA_BUFFER_SIZE =
(16384)
win32_sYMLINK_FLAG_RELATIVE :: CULong
win32_sYMLINK_FLAG_RELATIVE = 0x00000001
data Win32_REPARSE_DATA_BUFFER
= Win32_MOUNT_POINT_REPARSE_DATA_BUFFER String String
| Win32_SYMLINK_REPARSE_DATA_BUFFER String String Bool
| Win32_GENERIC_REPARSE_DATA_BUFFER
win32_alloca_REPARSE_DATA_BUFFER
:: ((Ptr Win32_REPARSE_DATA_BUFFER, Int) -> IO a) -> IO a
win32_alloca_REPARSE_DATA_BUFFER action =
allocaBytesAligned size align $ \ ptr ->
action (ptr, size)
where size = fromIntegral win32_mAXIMUM_REPARSE_DATA_BUFFER_SIZE
align = (4)
win32_peek_REPARSE_DATA_BUFFER
:: Ptr Win32_REPARSE_DATA_BUFFER -> IO Win32_REPARSE_DATA_BUFFER
win32_peek_REPARSE_DATA_BUFFER p = do
tag <- (\hsc_ptr -> peekByteOff hsc_ptr 0) p
case () of
_ | tag == win32_iO_REPARSE_TAG_MOUNT_POINT -> do
let buf = (\hsc_ptr -> hsc_ptr `plusPtr` 16) p
sni <- (\hsc_ptr -> peekByteOff hsc_ptr 8) p
sns <- (\hsc_ptr -> peekByteOff hsc_ptr 10) p
sn <- peekName buf sni sns
pni <- (\hsc_ptr -> peekByteOff hsc_ptr 12) p
pns <- (\hsc_ptr -> peekByteOff hsc_ptr 14) p
pn <- peekName buf pni pns
pure (Win32_MOUNT_POINT_REPARSE_DATA_BUFFER sn pn)
| tag == win32_iO_REPARSE_TAG_SYMLINK -> do
let buf = (\hsc_ptr -> hsc_ptr `plusPtr` 20) p
sni <- (\hsc_ptr -> peekByteOff hsc_ptr 8) p
sns <- (\hsc_ptr -> peekByteOff hsc_ptr 10) p
sn <- peekName buf sni sns
pni <- (\hsc_ptr -> peekByteOff hsc_ptr 12) p
pns <- (\hsc_ptr -> peekByteOff hsc_ptr 14) p
pn <- peekName buf pni pns
flags <- (\hsc_ptr -> peekByteOff hsc_ptr 16) p
pure (Win32_SYMLINK_REPARSE_DATA_BUFFER sn pn
(flags .&. win32_sYMLINK_FLAG_RELATIVE /= 0))
| otherwise -> pure Win32_GENERIC_REPARSE_DATA_BUFFER
where
peekName :: Ptr CWchar -> CUShort -> CUShort -> IO String
peekName buf offset size =
peekCWStringLen ( buf `plusPtr` fromIntegral offset
, fromIntegral size `div` sizeOf (0 :: CWchar) )
deviceIoControl
:: Win32.HANDLE
-> Win32.DWORD
-> (Ptr a, Int)
-> (Ptr b, Int)
-> Maybe Void
-> IO (Either Win32.ErrCode Int)
deviceIoControl h code (inPtr, inSize) (outPtr, outSize) _ = do
with 0 $ \ lenPtr -> do
status <- c_DeviceIoControl h code inPtr (fromIntegral inSize) outPtr
(fromIntegral outSize) lenPtr nullPtr
if not status
then do
Left <$> Win32.getLastError
else
Right . fromIntegral <$> peek lenPtr
foreign import WINAPI unsafe "windows.h DeviceIoControl"
c_DeviceIoControl
:: Win32.HANDLE
-> Win32.DWORD
-> Ptr a
-> Win32.DWORD
-> Ptr b
-> Win32.DWORD
-> Ptr Win32.DWORD
-> Ptr Void
-> IO Win32.BOOL
readSymbolicLink :: FilePath -> IO FilePath
readSymbolicLink path = modifyIOError (`ioeSetFileName` path) $ do
path' <- toExtendedLengthPath <$> prependCurrentDirectory path
let open = Win32.createFile path' 0 maxShareMode Nothing Win32.oPEN_EXISTING
(Win32.fILE_FLAG_BACKUP_SEMANTICS .|.
win32_fILE_FLAG_OPEN_REPARSE_POINT) Nothing
bracket open Win32.closeHandle $ \ h -> do
win32_alloca_REPARSE_DATA_BUFFER $ \ ptrAndSize@(ptr, _) -> do
result <- deviceIoControl h win32_fSCTL_GET_REPARSE_POINT
(nullPtr, 0) ptrAndSize Nothing
case result of
Left e | e == win32_eRROR_INVALID_FUNCTION -> do
let msg = "Incorrect function. The file system " <>
"might not support symbolic links."
throwIO (mkIOError illegalOperationErrorType
"DeviceIoControl" Nothing Nothing
`ioeSetErrorString` msg)
| otherwise -> Win32.failWith "DeviceIoControl" e
Right _ -> return ()
rData <- win32_peek_REPARSE_DATA_BUFFER ptr
strip <$> case rData of
Win32_MOUNT_POINT_REPARSE_DATA_BUFFER sn _ -> pure sn
Win32_SYMLINK_REPARSE_DATA_BUFFER sn _ _ -> pure sn
_ -> throwIO (mkIOError InappropriateType
"readSymbolicLink" Nothing Nothing)
where
strip sn = fromMaybe sn (List.stripPrefix "\\??\\" sn)
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
_ : ys -> go ys xs
[] -> go (x : ys') xs
_ -> go (x : ys') xs
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'')
normaliseW :: FilePath -> FilePath
normaliseW path@('\\' : '\\' : '?' : '\\' : _) = path
normaliseW path = normalise (joinDrive drive' subpath')
where
(drive, subpath) = splitDrive path
drive' = normaliseTrailingSep drive
subpath' = appendSep . prependSep . joinPath .
stripPardirs . expandDots . skipSeps .
splitDirectories $ subpath
skipSeps = filter (not . (`elem` (pure <$> pathSeparators)))
stripPardirs | not (isRelative path) = dropWhile (== "..")
| otherwise = id
prependSep | any isPathSeparator (take 1 subpath) = (pathSeparator :)
| otherwise = id
appendSep | hasTrailingPathSeparator subpath = addTrailingPathSeparator
| otherwise = id
toNormalisedExtendedLengthPath :: FilePath -> FilePath
toNormalisedExtendedLengthPath path
| isRelative path = normalise path
| otherwise = toExtendedLengthPath path
normaliseSeparators :: FilePath -> FilePath
normaliseSeparators path
| isRelative path = normaliseSep <$> path
| otherwise = toExtendedLengthPath path
where normaliseSep c = if isPathSeparator c then pathSeparator else c
toExtendedLengthPath :: FilePath -> FilePath
toExtendedLengthPath path
| isRelative path = path
| otherwise =
case normaliseW path of
'\\' : '?' : '?' : '\\' : _ -> path
'\\' : '\\' : '?' : '\\' : _ -> path
'\\' : '\\' : '.' : '\\' : _ -> path
'\\' : subpath@('\\' : _) -> "\\\\?\\UNC" <> subpath
normalisedPath -> "\\\\?\\" <> normalisedPath
fromExtendedLengthPath :: FilePath -> FilePath
fromExtendedLengthPath ePath =
case ePath of
'\\' : '\\' : '?' : '\\' : path ->
case path of
'U' : 'N' : 'C' : subpath@('\\' : _) -> "\\" <> subpath
drive : ':' : subpath
| isAlpha drive && isAscii drive && isPathRegular subpath -> path
_ -> ePath
_ -> ePath
where
isPathRegular path =
not ('/' `elem` path ||
"." `elem` splitDirectories path ||
".." `elem` splitDirectories path)
getPathNameWith :: (Ptr CWchar -> Win32.DWORD -> IO Win32.DWORD) -> IO FilePath
getPathNameWith cFunc = do
let getPathNameWithLen len = do
allocaArray (fromIntegral len) $ \ ptrPathOut -> do
len' <- Win32.failIfZero "" (cFunc ptrPathOut len)
if len' <= len
then Right <$> peekCWStringLen (ptrPathOut, fromIntegral len')
else pure (Left len')
r <- getPathNameWithLen ((260) * ((2)))
case r of
Right s -> pure s
Left len -> do
r' <- getPathNameWithLen len
case r' of
Right s -> pure s
Left _ -> throwIO (mkIOError OtherError "" Nothing Nothing
`ioeSetErrorString` "path changed unexpectedly")
win32_createSymbolicLink :: String -> String -> Bool -> IO ()
win32_createSymbolicLink link _target _isDir =
throwIO . (`ioeSetErrorString` unsupportedErrorMsg) $
mkIOError UnsupportedOperation "CreateSymbolicLink"
Nothing (Just link)
where unsupportedErrorMsg = "Not supported on Windows XP or older"
createSymbolicLink :: Bool -> FilePath -> FilePath -> IO ()
createSymbolicLink isDir target link =
(`ioeSetFileName` link) `modifyIOError` do
link' <- toExtendedLengthPath <$> prependCurrentDirectory link
win32_createSymbolicLink link' (normaliseSeparators target) isDir
type Metadata = Win32.BY_HANDLE_FILE_INFORMATION
getSymbolicLinkMetadata :: FilePath -> IO Metadata
getSymbolicLinkMetadata path =
(`ioeSetFileName` path) `modifyIOError` do
path' <- toNormalisedExtendedLengthPath <$> prependCurrentDirectory path
let open = Win32.createFile path' 0 maxShareMode Nothing Win32.oPEN_EXISTING
(Win32.fILE_FLAG_BACKUP_SEMANTICS .|.
win32_fILE_FLAG_OPEN_REPARSE_POINT) Nothing
bracket open Win32.closeHandle $ \ h -> do
Win32.getFileInformationByHandle h
getFileMetadata :: FilePath -> IO Metadata
getFileMetadata path =
(`ioeSetFileName` path) `modifyIOError` do
path' <- toNormalisedExtendedLengthPath <$> prependCurrentDirectory path
let open = Win32.createFile path' 0 maxShareMode Nothing Win32.oPEN_EXISTING
Win32.fILE_FLAG_BACKUP_SEMANTICS Nothing
bracket open Win32.closeHandle $ \ h -> do
Win32.getFileInformationByHandle h
fileTypeFromMetadata :: Metadata -> FileType
fileTypeFromMetadata info
| isLink = if isDir then DirectoryLink else SymbolicLink
| isDir = Directory
| otherwise = File
where
isLink = attrs .&. win32_fILE_ATTRIBUTE_REPARSE_POINT /= 0
isDir = attrs .&. Win32.fILE_ATTRIBUTE_DIRECTORY /= 0
attrs = Win32.bhfiFileAttributes info
fileSizeFromMetadata :: Metadata -> Integer
fileSizeFromMetadata = fromIntegral . Win32.bhfiSize
accessTimeFromMetadata :: Metadata -> UTCTime
accessTimeFromMetadata =
posixSecondsToUTCTime . windowsToPosixTime . Win32.bhfiLastAccessTime
modificationTimeFromMetadata :: Metadata -> UTCTime
modificationTimeFromMetadata =
posixSecondsToUTCTime . windowsToPosixTime . Win32.bhfiLastWriteTime
windowsPosixEpochDifference :: Num a => a
windowsPosixEpochDifference = 116444736000000000
windowsToPosixTime :: Win32.FILETIME -> POSIXTime
windowsToPosixTime (Win32.FILETIME t) =
(fromIntegral t windowsPosixEpochDifference) / 10000000
posixToWindowsTime :: POSIXTime -> Win32.FILETIME
posixToWindowsTime t = Win32.FILETIME $
truncate (t * 10000000 + windowsPosixEpochDifference)
type Mode = Win32.FileAttributeOrFlag
modeFromMetadata :: Metadata -> Mode
modeFromMetadata = Win32.bhfiFileAttributes
hasWriteMode :: Mode -> Bool
hasWriteMode m = m .&. Win32.fILE_ATTRIBUTE_READONLY == 0
setWriteMode :: Bool -> Mode -> Mode
setWriteMode False m = m .|. Win32.fILE_ATTRIBUTE_READONLY
setWriteMode True m = m .&. complement Win32.fILE_ATTRIBUTE_READONLY
setFileMode :: FilePath -> Mode -> IO ()
setFileMode path mode =
(`ioeSetFileName` path) `modifyIOError` do
path' <- toNormalisedExtendedLengthPath <$> prependCurrentDirectory path
Win32.setFileAttributes path' mode
setFilePermissions :: FilePath -> Mode -> IO ()
setFilePermissions path m = do
m' <- modeFromMetadata <$> getFileMetadata path
setFileMode path ((m' .&. complement Win32.fILE_ATTRIBUTE_READONLY) .|.
(m .&. Win32.fILE_ATTRIBUTE_READONLY))
getAccessPermissions :: FilePath -> IO Permissions
getAccessPermissions path = do
m <- getFileMetadata path
let isDir = fileTypeIsDirectory (fileTypeFromMetadata m)
let w = hasWriteMode (modeFromMetadata m)
let x = (toLower <$> takeExtension path)
`elem` [".bat", ".cmd", ".com", ".exe"]
return Permissions
{ readable = True
, writable = w
, executable = x && not isDir
, searchable = isDir
}
setAccessPermissions :: FilePath -> Permissions -> IO ()
setAccessPermissions path Permissions{writable = w} = do
setFilePermissions path (setWriteMode w 0)