diff --git a/core/src/Streamly/Internal/FileSystem/Windows/File.hs b/core/src/Streamly/Internal/FileSystem/Windows/File.hs index b1f427354b..307aaa27f5 100644 --- a/core/src/Streamly/Internal/FileSystem/Windows/File.hs +++ b/core/src/Streamly/Internal/FileSystem/Windows/File.hs @@ -9,12 +9,78 @@ module Streamly.Internal.FileSystem.Windows.File -- Imports ------------------------------------------------------------------------------- --- XXX Add required imports +import Control.Exception (bracketOnError, try, SomeException, onException) +import Data.Bits +import System.IO (IOMode(..), Handle) +import System.OsPath.Windows ( WindowsPath ) +import Foreign.C.Types +import qualified System.Win32 as Win32 +import Control.Monad (when, void) +import Streamly.Internal.FileSystem.WindowsPath (WindowsPath) + +import System.Win32.Types + +#if defined(__IO_MANAGER_WINIO__) +import GHC.IO.SubSystem +#else +import GHC.IO.Handle.FD (fdToHandle') +#include +#endif + +import Foreign.C.String +import Foreign.Ptr +import Foreign.Marshal.Alloc +import Foreign.Storable + +import qualified Streamly.Internal.FileSystem.WindowsPath as Path + +#include "windows_cconv.h" ------------------------------------------------------------------------------- -- Windows ------------------------------------------------------------------------------- +foreign import WINDOWS_CCONV unsafe "windows.h CreateFileW" + c_CreateFile :: LPCTSTR -> AccessMode -> ShareMode -> LPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag -> HANDLE -> IO HANDLE + + +-- | like failIf, but retried on sharing violations. This is necessary for many +-- file operations; see +-- https://www.betaarchive.com/wiki/index.php/Microsoft_KB_Archive/316609 +-- +failIfWithRetry :: (a -> Bool) -> String -> IO a -> IO a +failIfWithRetry cond msg action = retryOrFail retries + where + delay = 100*1000 -- in ms, we use threadDelay + + retries = 20 :: Int + -- KB article recommends 250/5 + + + -- retryOrFail :: Int -> IO a + + retryOrFail times + | times <= 0 = errorWin msg + | otherwise = do + ret <- action + if not (cond ret) + then return ret + else do + err_code <- getLastError + if err_code == (32) + then do threadDelay delay; retryOrFail (times - 1) + else errorWin msg + +withFilePath :: WindowsPath -> (LPTSTR -> IO a) -> IO a +withFilePath p act = + Array.unsafePinnedAsPtr (Path.toChunk p) $ \ptr _ -> act (castPtr ptr) + +createFile :: WindowsPath -> AccessMode -> ShareMode -> Maybe LPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag -> Maybe HANDLE -> IO HANDLE +createFile name access share mb_attr mode flag mb_h = + withFilePath name $ \ c_name -> + failIfWithRetry (==iNVALID_HANDLE_VALUE) (unwords ["CreateFile",show name]) $ + c_CreateFile c_name access share (maybePtr mb_attr) mode flag (maybePtr mb_h) + -- | Open a file and return the 'Handle'. openFile :: WindowsPath -> IOMode -> IO Handle openFile fp iomode = bracketOnError @@ -125,6 +191,5 @@ toHandle _ iomode h = (`onException` Win32.closeHandle h) $ do toHandle fp iomode h = (`onException` Win32.closeHandle h) $ do when (iomode == AppendMode ) $ void $ Win32.setFilePointerEx h 0 Win32.fILE_END fd <- _open_osfhandle (fromIntegral (ptrToIntPtr h)) (#const _O_BINARY) - fp' <- either (const (fmap WS.toChar . WS.unpack $ fp)) id <$> try @SomeException (WS.decodeFS fp) - fdToHandle' fd Nothing False fp' iomode True + fdToHandle' fd Nothing False (Path.toString fp) iomode True #endif diff --git a/core/streamly-core.cabal b/core/streamly-core.cabal index 73db39aca3..df6fa3840d 100644 --- a/core/streamly-core.cabal +++ b/core/streamly-core.cabal @@ -392,6 +392,7 @@ library , Streamly.Internal.FileSystem.DirIO , Streamly.Internal.FileSystem.Posix.File , Streamly.Internal.FileSystem.Posix.ReadDir + , Streamly.Internal.FileSystem.Windows.File , Streamly.Internal.FileSystem.Windows.ReadDir -- RingArray Arrays