1

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 <fcntl.h>
+#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

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