From b232bd4dc7f4b83c5f4e64ecb4bf5cfc661dbf31 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Tue, 9 Jul 2024 01:23:57 +0530 Subject: [PATCH] Replace Win32 functions with local impls --- .../Internal/FileSystem/Windows/ReadDir.hsc | 111 +++++++++++++++--- 1 file changed, 94 insertions(+), 17 deletions(-) diff --git a/core/src/Streamly/Internal/FileSystem/Windows/ReadDir.hsc b/core/src/Streamly/Internal/FileSystem/Windows/ReadDir.hsc index 883adf7885..d1f8672f53 100644 --- a/core/src/Streamly/Internal/FileSystem/Windows/ReadDir.hsc +++ b/core/src/Streamly/Internal/FileSystem/Windows/ReadDir.hsc @@ -19,21 +19,22 @@ where #if defined(mingw32_HOST_OS) || defined(__MINGW32__) +import Control.Exception (throwIO) import Control.Monad (void) import Control.Monad.IO.Class (MonadIO(..)) -import Data.Bits ((.&.)) -import Data.Char (ord) +import Data.Char (ord, isSpace) import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Foreign - ( Ptr, Word8, Word32, mallocForeignPtrBytes, withForeignPtr, peek - , peekByteOff , castPtr, ForeignPtr, plusPtr) -import Foreign.C (CWchar(..)) +import Foreign.C (CInt(..), CWchar(..), Errno(..), errnoToIOError, peekCWString) +import Numeric (showHex) import Streamly.Internal.Data.Array (Array(..)) import Streamly.Internal.FileSystem.WindowsPath (WindowsPath(..)) +import System.IO.Error (ioeSetErrorString) import qualified Streamly.Internal.Data.Array as Array import qualified Streamly.Internal.FileSystem.WindowsPath as Path -import qualified System.Win32 as Win32 +import qualified System.Win32 as Win32 (failWith) + +import Foreign hiding (void) #include @@ -43,22 +44,97 @@ import qualified System.Win32 as Win32 -- _UNICODE preprocessor macros) is enabled in your project. To ensure -- consistent Unicode support, explicitly use CreateFileW. +------------------------------------------------------------------------------ +-- Types +------------------------------------------------------------------------------ + +type BOOL = Bool +type DWORD = Word32 + +type UINT_PTR = Word +type ErrCode = DWORD +type LPCTSTR = Ptr CWchar type WIN32_FIND_DATA = () +type HANDLE = Ptr () --- XXX Define this as data and unpack three fields? -newtype DirStream = - DirStream (Win32.HANDLE, IORef Bool, ForeignPtr WIN32_FIND_DATA) +------------------------------------------------------------------------------ +-- Windows C APIs +------------------------------------------------------------------------------ -- XXX Note for i386, stdcall is needed instead of ccall, see Win32 -- package/windows_cconv.h. We support only x86_64 for now. foreign import ccall unsafe "windows.h FindFirstFileW" - c_FindFirstFileW :: Win32.LPCTSTR -> Ptr WIN32_FIND_DATA -> IO Win32.HANDLE + c_FindFirstFileW :: LPCTSTR -> Ptr WIN32_FIND_DATA -> IO HANDLE foreign import ccall unsafe "windows.h FindNextFileW" - c_FindNextFileW :: Win32.HANDLE -> Ptr WIN32_FIND_DATA -> IO Win32.BOOL + c_FindNextFileW :: HANDLE -> Ptr WIN32_FIND_DATA -> IO BOOL foreign import ccall unsafe "windows.h FindClose" - c_FindClose :: Win32.HANDLE -> IO Win32.BOOL + c_FindClose :: HANDLE -> IO BOOL + +foreign import ccall unsafe "windows.h GetLastError" + getLastError :: IO ErrCode + +foreign import ccall unsafe "windows.h LocalFree" + localFree :: Ptr a -> IO (Ptr a) + +------------------------------------------------------------------------------ +-- Haskell C APIs +------------------------------------------------------------------------------ + +foreign import ccall unsafe "maperrno_func" -- in base/cbits/Win32Utils.c + c_maperrno_func :: ErrCode -> IO Errno + +------------------------------------------------------------------------------ +-- Error Handling +------------------------------------------------------------------------------ + +-- XXX getErrorMessage and castUINTPtrToPtr require c code, so left out for +-- now. Once we replace these we can remove dependency on Win32. We can +-- possibly implement these in Haskell by directly calling the Windows API. + +foreign import ccall unsafe "getErrorMessage" + getErrorMessage :: DWORD -> IO (Ptr CWchar) + +foreign import ccall unsafe "castUINTPtrToPtr" + castUINTPtrToPtr :: UINT_PTR -> Ptr a + +failWith :: String -> ErrCode -> IO a +failWith fn_name err_code = do + c_msg <- getErrorMessage err_code + msg <- if c_msg == nullPtr + then return $ "Error 0x" ++ Numeric.showHex err_code "" + else do + msg <- peekCWString c_msg + -- We ignore failure of freeing c_msg, given we're already failing + _ <- localFree c_msg + return msg + errno <- c_maperrno_func err_code + let msg' = reverse $ dropWhile isSpace $ reverse msg -- drop trailing \n + ioerror = errnoToIOError fn_name errno Nothing Nothing + `ioeSetErrorString` msg' + throwIO ioerror + +errorWin :: String -> IO a +errorWin fn_name = do + err_code <- getLastError + failWith fn_name err_code + +failIf :: (a -> Bool) -> String -> IO a -> IO a +failIf p wh act = do + v <- act + if p v then errorWin wh else return v + +iNVALID_HANDLE_VALUE :: HANDLE +iNVALID_HANDLE_VALUE = castUINTPtrToPtr maxBound + +------------------------------------------------------------------------------ +-- Dir stream implementation +------------------------------------------------------------------------------ + +-- XXX Define this as data and unpack three fields? +newtype DirStream = + DirStream (HANDLE, IORef Bool, ForeignPtr WIN32_FIND_DATA) openDirStream :: WindowsPath -> IO DirStream openDirStream p = do @@ -67,10 +143,11 @@ openDirStream p = do withForeignPtr fp_finddata $ \dataPtr -> do handle <- Array.asCStringUnsafe (Path.toChunk path) $ \pathPtr -> do - -- XXX print the path in the error message -- XXX Use getLastError to distinguish the case when no - -- matching file is found. - Win32.failIf (== Win32.iNVALID_HANDLE_VALUE) "FindFirstFileW" + -- matching file is found. See the doc of FindFirstFileW. + failIf + (== iNVALID_HANDLE_VALUE) + ("FindFirstFileW: " ++ Path.toString path) $ c_FindFirstFileW (castPtr pathPtr) dataPtr ref <- newIORef True return $ DirStream (handle, ref, fp_finddata) @@ -130,7 +207,7 @@ readDirStreamEither (DirStream (h, ref, fdata)) = if (retval) then processEntry ptr else do - err <- Win32.getLastError + err <- getLastError if err == (# const ERROR_NO_MORE_FILES ) then return Nothing -- XXX Print the path in the error message