{-# LANGUAGE CPP #-} module System.Directory.Internal.Windows where #include #ifdef mingw32_HOST_OS ##if defined i386_HOST_ARCH ## define WINAPI stdcall ##elif defined x86_64_HOST_ARCH ## define WINAPI ccall ##else ## error unknown architecture ##endif #include #include #ifdef HAVE_SYS_STAT_H # include #endif #include #include import Prelude () import System.Directory.Internal.Prelude import System.FilePath (isPathSeparator, isRelative, normalise, pathSeparator, splitDirectories) import qualified Data.List as List import qualified System.Win32 as Win32 win32_cSIDL_LOCAL_APPDATA :: Win32.CSIDL #if MIN_VERSION_Win32(2, 3, 1) win32_cSIDL_LOCAL_APPDATA = Win32.cSIDL_LOCAL_APPDATA #else win32_cSIDL_LOCAL_APPDATA = (#const CSIDL_LOCAL_APPDATA) #endif win32_eRROR_INVALID_FUNCTION :: Win32.ErrCode win32_eRROR_INVALID_FUNCTION = 0x1 win32_fILE_ATTRIBUTE_REPARSE_POINT :: Win32.FileAttributeOrFlag win32_fILE_ATTRIBUTE_REPARSE_POINT = (#const FILE_ATTRIBUTE_REPARSE_POINT) win32_fILE_SHARE_DELETE :: Win32.ShareMode #if MIN_VERSION_Win32(2, 3, 1) win32_fILE_SHARE_DELETE = Win32.fILE_SHARE_DELETE -- added in 2.3.0.2 #else win32_fILE_SHARE_DELETE = (#const FILE_SHARE_DELETE) #endif win32_getLongPathName, win32_getShortPathName :: FilePath -> IO FilePath #if MIN_VERSION_Win32(2, 4, 0) win32_getLongPathName = Win32.getLongPathName win32_getShortPathName = Win32.getShortPathName #else win32_getLongPathName path = modifyIOError ((`ioeSetLocation` "GetLongPathName") . (`ioeSetFileName` path)) $ do withCWString path $ \ ptrPath -> do getPathNameWith (c_GetLongPathName ptrPath) win32_getShortPathName path = modifyIOError ((`ioeSetLocation` "GetShortPathName") . (`ioeSetFileName` path)) $ do withCWString path $ \ ptrPath -> do getPathNameWith (c_GetShortPathName ptrPath) foreign import WINAPI unsafe "windows.h GetLongPathNameW" c_GetLongPathName :: Ptr CWchar -> Ptr CWchar -> Win32.DWORD -> IO Win32.DWORD foreign import WINAPI unsafe "windows.h GetShortPathNameW" c_GetShortPathName :: Ptr CWchar -> Ptr CWchar -> Win32.DWORD -> IO Win32.DWORD #endif win32_getFinalPathNameByHandle :: Win32.HANDLE -> Win32.DWORD -> IO FilePath win32_getFinalPathNameByHandle _h _flags = modifyIOError (`ioeSetLocation` "GetFinalPathNameByHandle") $ do #ifdef HAVE_GETFINALPATHNAMEBYHANDLEW getPathNameWith $ \ ptr len -> do c_GetFinalPathNameByHandle _h ptr len _flags foreign import WINAPI unsafe "windows.h GetFinalPathNameByHandleW" c_GetFinalPathNameByHandle :: Win32.HANDLE -> Ptr CWchar -> Win32.DWORD -> Win32.DWORD -> IO Win32.DWORD #else throwIO (mkIOError UnsupportedOperation "platform does not support GetFinalPathNameByHandle" Nothing Nothing) #endif getFinalPathName :: FilePath -> IO FilePath getFinalPathName = (fromExtendedLengthPath <$>) . rawGetFinalPathName . toExtendedLengthPath where #ifdef HAVE_GETFINALPATHNAMEBYHANDLEW rawGetFinalPathName path = do let open = Win32.createFile path 0 shareMode Nothing Win32.oPEN_EXISTING Win32.fILE_FLAG_BACKUP_SEMANTICS Nothing bracket open Win32.closeHandle $ \ h -> do win32_getFinalPathNameByHandle h 0 shareMode = win32_fILE_SHARE_DELETE .|. Win32.fILE_SHARE_READ .|. Win32.fILE_SHARE_WRITE #else rawGetFinalPathName = win32_getLongPathName <=< win32_getShortPathName #endif 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 = (#const IO_REPARSE_TAG_MOUNT_POINT) win32_iO_REPARSE_TAG_SYMLINK = (#const IO_REPARSE_TAG_SYMLINK) win32_mAXIMUM_REPARSE_DATA_BUFFER_SIZE :: Win32.DWORD win32_mAXIMUM_REPARSE_DATA_BUFFER_SIZE = (#const MAXIMUM_REPARSE_DATA_BUFFER_SIZE) win32_sYMLINK_FLAG_RELATIVE :: CULong win32_sYMLINK_FLAG_RELATIVE = 0x00000001 data Win32_REPARSE_DATA_BUFFER = Win32_MOUNT_POINT_REPARSE_DATA_BUFFER String String -- ^ substituteName printName | Win32_SYMLINK_REPARSE_DATA_BUFFER String String Bool -- ^ substituteName printName isRelative | 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 -- workaround (hsc2hs for GHC < 8.0 don't support #{alignment ...}) align = #{size char[alignof(HsDirectory_REPARSE_DATA_BUFFER)]} win32_peek_REPARSE_DATA_BUFFER :: Ptr Win32_REPARSE_DATA_BUFFER -> IO Win32_REPARSE_DATA_BUFFER win32_peek_REPARSE_DATA_BUFFER p = do tag <- #{peek HsDirectory_REPARSE_DATA_BUFFER, ReparseTag} p case () of _ | tag == win32_iO_REPARSE_TAG_MOUNT_POINT -> do let buf = #{ptr HsDirectory_REPARSE_DATA_BUFFER, MountPointReparseBuffer.PathBuffer} p sni <- #{peek HsDirectory_REPARSE_DATA_BUFFER, MountPointReparseBuffer.SubstituteNameOffset} p sns <- #{peek HsDirectory_REPARSE_DATA_BUFFER, MountPointReparseBuffer.SubstituteNameLength} p sn <- peekName buf sni sns pni <- #{peek HsDirectory_REPARSE_DATA_BUFFER, MountPointReparseBuffer.PrintNameOffset} p pns <- #{peek HsDirectory_REPARSE_DATA_BUFFER, MountPointReparseBuffer.PrintNameLength} p pn <- peekName buf pni pns pure (Win32_MOUNT_POINT_REPARSE_DATA_BUFFER sn pn) | tag == win32_iO_REPARSE_TAG_SYMLINK -> do let buf = #{ptr HsDirectory_REPARSE_DATA_BUFFER, SymbolicLinkReparseBuffer.PathBuffer} p sni <- #{peek HsDirectory_REPARSE_DATA_BUFFER, SymbolicLinkReparseBuffer.SubstituteNameOffset} p sns <- #{peek HsDirectory_REPARSE_DATA_BUFFER, SymbolicLinkReparseBuffer.SubstituteNameLength} p sn <- peekName buf sni sns pni <- #{peek HsDirectory_REPARSE_DATA_BUFFER, SymbolicLinkReparseBuffer.PrintNameOffset} p pns <- #{peek HsDirectory_REPARSE_DATA_BUFFER, SymbolicLinkReparseBuffer.PrintNameLength} p pn <- peekName buf pni pns flags <- #{peek HsDirectory_REPARSE_DATA_BUFFER, SymbolicLinkReparseBuffer.Flags} 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 let open = Win32.createFile (toExtendedLengthPath path) 0 shareMode 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 shareMode = win32_fILE_SHARE_DELETE .|. Win32.fILE_SHARE_READ .|. Win32.fILE_SHARE_WRITE strip sn = fromMaybe sn (List.stripPrefix "\\??\\" sn) -- | Normalise the path separators and prepend the @"\\\\?\\"@ prefix if -- necessary or possible. normaliseSeparators :: FilePath -> FilePath normaliseSeparators path | isRelative path = normaliseSep <$> path | otherwise = toExtendedLengthPath path where normaliseSep c = if isPathSeparator c then pathSeparator else c -- | Add the @"\\\\?\\"@ prefix if necessary or possible. -- The path remains unchanged if the prefix is not added. toExtendedLengthPath :: FilePath -> FilePath toExtendedLengthPath path | isRelative path = path | otherwise = case normalise path of -- note: as of filepath-1.4.1.0 normalise doesn't honor \\?\ -- https://github.com/haskell/filepath/issues/56 -- this means we cannot trust the result of normalise on -- paths that start with \\?\ '\\' : '\\' : '?' : '\\' : _ -> path '\\' : '\\' : '.' : '\\' : _ -> path '\\' : subpath@('\\' : _) -> "\\\\?\\UNC" <> subpath normalisedPath -> "\\\\?\\" <> normalisedPath -- | Strip the @"\\\\?\\"@ prefix if possible. -- The prefix is kept if the meaning of the path would otherwise change. 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 | 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 ((#const MAX_PATH) * (#size wchar_t)) 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 = #ifdef HAVE_CREATESYMBOLICLINKW withCWString link $ \ pLink -> withCWString _target $ \ pTarget -> do let flags = if _isDir then win32_sYMBOLIC_LINK_FLAG_DIRECTORY else 0 status <- c_CreateSymbolicLink pLink pTarget flags if status == 0 then do e <- Win32.getLastError case () of _ | e == win32_eRROR_INVALID_FUNCTION -> do let msg = "Incorrect function. The underlying file system " <> "might not support symbolic links." throwIO (mkIOError illegalOperationErrorType "CreateSymbolicLink" Nothing (Just link) `ioeSetErrorString` msg) | e == win32_eRROR_PRIVILEGE_NOT_HELD -> do let msg = "A required privilege is not held by the client. " <> "Creating symbolic links usually requires " <> "administrative rights." throwIO (mkIOError permissionErrorType "CreateSymbolicLink" Nothing (Just link) `ioeSetErrorString` msg) | otherwise -> Win32.failWith "CreateSymbolicLink" e else return () where win32_eRROR_PRIVILEGE_NOT_HELD :: Win32.ErrCode win32_eRROR_PRIVILEGE_NOT_HELD = 0x522 win32_sYMBOLIC_LINK_FLAG_DIRECTORY :: Win32.DWORD win32_sYMBOLIC_LINK_FLAG_DIRECTORY = 0x1 foreign import WINAPI unsafe "windows.h CreateSymbolicLinkW" c_CreateSymbolicLink :: Ptr CWchar -> Ptr CWchar -> Win32.DWORD -> IO Win32.BYTE #else throwIO . (`ioeSetErrorString` unsupportedErrorMsg) $ mkIOError UnsupportedOperation "CreateSymbolicLink" Nothing (Just link) where unsupportedErrorMsg = "Not supported on Windows XP or older" #endif createSymbolicLink :: Bool -> String -> String -> IO () createSymbolicLink isDir target link = do -- toExtendedLengthPath ensures the target gets normalised properly win32_createSymbolicLink link (normaliseSeparators target) isDir foreign import ccall unsafe "_wchmod" c_wchmod :: CWString -> CMode -> IO CInt s_IRUSR :: CMode s_IRUSR = (#const S_IRUSR) s_IWUSR :: CMode s_IWUSR = (#const S_IWUSR) s_IXUSR :: CMode s_IXUSR = (#const S_IXUSR) s_IFDIR :: CMode s_IFDIR = (#const S_IFDIR) #endif