{-# LINE 1 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Handle\\Lock\\Windows.hsc" #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE InterruptibleFFI #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}

-- | File locking for Windows.

module GHC.Internal.IO.Handle.Lock.Windows where




{-# LINE 16 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Handle\\Lock\\Windows.hsc" #-}



import GHC.Internal.Data.Bits
import GHC.Internal.Data.Function
import GHC.Internal.IO.Handle.Windows (handleToHANDLE)
import GHC.Internal.Foreign.C.Error
import GHC.Internal.Foreign.C.Types
import GHC.Internal.Foreign.Marshal.Alloc
import GHC.Internal.Foreign.Marshal.Utils
import GHC.Internal.Base
import qualified GHC.Internal.Event.Windows as Mgr
import GHC.Internal.Event.Windows (LPOVERLAPPED, withOverlapped)
import GHC.Internal.IO.FD
import GHC.Internal.IO.Handle.FD
import GHC.Internal.IO.Handle.Types (Handle)
import GHC.Internal.IO.Handle.Lock.Common (LockMode(..))
import GHC.Internal.IO.SubSystem
import GHC.Internal.Windows

lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
lockImpl = Handle -> String -> LockMode -> Bool -> IO Bool
lockImplPOSIX (Handle -> String -> LockMode -> Bool -> IO Bool)
-> (Handle -> String -> LockMode -> Bool -> IO Bool)
-> Handle
-> String
-> LockMode
-> Bool
-> IO Bool
forall a. a -> a -> a
<!> Handle -> String -> LockMode -> Bool -> IO Bool
lockImplWinIO

lockImplWinIO :: Handle -> String -> LockMode -> Bool -> IO Bool
lockImplWinIO :: Handle -> String -> LockMode -> Bool -> IO Bool
lockImplWinIO Handle
h String
ctx LockMode
mode Bool
block = do
  wh      <- Handle -> IO HANDLE
handleToHANDLE Handle
h
  fix $ \IO Bool
retry ->
          do retcode <- String -> IO (IOResult Word32) -> IO Word32
forall a. String -> IO (IOResult a) -> IO a
Mgr.withException String
ctx (IO (IOResult Word32) -> IO Word32)
-> IO (IOResult Word32) -> IO Word32
forall a b. (a -> b) -> a -> b
$
                          String
-> HANDLE
-> Word64
-> StartIOCallback Int
-> CompletionCallback (IOResult Word32)
-> IO (IOResult Word32)
forall a.
String
-> HANDLE
-> Word64
-> StartIOCallback Int
-> CompletionCallback (IOResult a)
-> IO (IOResult a)
withOverlapped String
ctx HANDLE
wh Word64
0 (HANDLE -> StartIOCallback Int
forall {a}. HANDLE -> Ptr OVERLAPPED -> IO (CbResult a)
startCB HANDLE
wh) CompletionCallback (IOResult Word32)
forall {a} {p}. Integral a => a -> p -> IO (IOResult a)
completionCB
             case () of
              ()
_ | Word32
retcode Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
995 -> IO Bool
retry
{-# LINE 47 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Handle\\Lock\\Windows.hsc" #-}
                | Word32
retcode Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0           -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
{-# LINE 48 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Handle\\Lock\\Windows.hsc" #-}
                | Word32
retcode Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
33 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
block
{-# LINE 49 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Handle\\Lock\\Windows.hsc" #-}
                    -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                | Bool
otherwise -> String -> Word32 -> IO Bool
forall a. String -> Word32 -> IO a
failWith String
ctx Word32
retcode
    where
      cmode :: Word32
cmode = case LockMode
mode of
                LockMode
SharedLock    -> Word32
0
                LockMode
ExclusiveLock -> Word32
2
{-# LINE 55 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Handle\\Lock\\Windows.hsc" #-}
      flags = if block
                 then cmode
                 else cmode .|. 1
{-# LINE 58 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Handle\\Lock\\Windows.hsc" #-}

      startCB :: HANDLE -> Ptr OVERLAPPED -> IO (CbResult a)
startCB HANDLE
wh Ptr OVERLAPPED
lpOverlapped = do
        ret <- HANDLE
-> Word32
-> Word32
-> Word32
-> Word32
-> Ptr OVERLAPPED
-> IO Bool
c_LockFileEx HANDLE
wh Word32
flags Word32
0 Word32
4294967295 Word32
4294967295
{-# LINE 61 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Handle\\Lock\\Windows.hsc" #-}
                            Ptr OVERLAPPED
lpOverlapped
        return $ Mgr.CbNone ret

      completionCB :: a -> p -> IO (IOResult a)
completionCB a
err p
_dwBytes
        | a
err a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 = a -> IO (IOResult a)
forall a. a -> IO (IOResult a)
Mgr.ioSuccess a
0
{-# LINE 66 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Handle\\Lock\\Windows.hsc" #-}
        | Bool
otherwise                     = a -> IO (IOResult a)
forall a. Integral a => a -> IO (IOResult a)
Mgr.ioFailed a
err

lockImplPOSIX :: Handle -> String -> LockMode -> Bool -> IO Bool
lockImplPOSIX :: Handle -> String -> LockMode -> Bool -> IO Bool
lockImplPOSIX Handle
h String
ctx LockMode
mode Bool
block = do
  FD{fdFD = fd} <- Handle -> IO FD
handleToFd Handle
h
  wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) ctx $ c_get_osfhandle fd
  allocaBytes sizeof_OVERLAPPED $ \Ptr OVERLAPPED
ovrlpd -> do
    Ptr OVERLAPPED -> Word8 -> Int -> IO ()
forall a. Ptr a -> Word8 -> Int -> IO ()
fillBytes Ptr OVERLAPPED
ovrlpd Word8
0 Int
sizeof_OVERLAPPED
    let flags :: Word32
flags = Word32
cmode Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (if Bool
block then Word32
0 else Word32
1)
{-# LINE 75 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Handle\\Lock\\Windows.hsc" #-}
    -- We want to lock the whole file without looking up its size to be

    -- consistent with what flock does. According to documentation of LockFileEx

    -- "locking a region that goes beyond the current end-of-file position is

    -- not an error", hence we pass maximum value as the number of bytes to

    -- lock.

    (IO Bool -> IO Bool) -> IO Bool
forall a. (a -> a) -> a
fix ((IO Bool -> IO Bool) -> IO Bool)
-> (IO Bool -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \IO Bool
retry -> HANDLE
-> Word32
-> Word32
-> Word32
-> Word32
-> Ptr OVERLAPPED
-> IO Bool
c_LockFileEx HANDLE
wh Word32
flags Word32
0 Word32
4294967295 Word32
4294967295
{-# LINE 81 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Handle\\Lock\\Windows.hsc" #-}
                                 Ptr OVERLAPPED
ovrlpd IO Bool -> (Bool -> IO Bool) -> IO Bool
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
True  -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      Bool
False -> IO Word32
getLastError IO Word32 -> (Word32 -> IO Bool) -> IO Bool
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Word32
err -> if
        | Bool -> Bool
not Bool
block Bool -> Bool -> Bool
&& Word32
err Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
33 -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
{-# LINE 85 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Handle\\Lock\\Windows.hsc" #-}
        | Word32
err Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
995           -> IO Bool
retry
{-# LINE 86 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Handle\\Lock\\Windows.hsc" #-}
        | Bool
otherwise                                         -> String -> Word32 -> IO Bool
forall a. String -> Word32 -> IO a
failWith String
ctx Word32
err
  where
    sizeof_OVERLAPPED :: Int
sizeof_OVERLAPPED = (Int
32)
{-# LINE 89 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Handle\\Lock\\Windows.hsc" #-}

    cmode :: Word32
cmode = case LockMode
mode of
      LockMode
SharedLock    -> Word32
0
      LockMode
ExclusiveLock -> Word32
2
{-# LINE 93 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Handle\\Lock\\Windows.hsc" #-}

unlockImpl :: Handle -> IO ()
unlockImpl :: Handle -> IO ()
unlockImpl = Handle -> IO ()
unlockImplPOSIX (Handle -> IO ()) -> (Handle -> IO ()) -> Handle -> IO ()
forall a. a -> a -> a
<!> Handle -> IO ()
unlockImplWinIO

unlockImplWinIO :: Handle -> IO ()
unlockImplWinIO :: Handle -> IO ()
unlockImplWinIO Handle
h = do
  wh <- Handle -> IO HANDLE
handleToHANDLE Handle
h
  _ <- Mgr.withException "unlockImpl" $
          withOverlapped "unlockImpl" wh 0 (startCB wh) completionCB
  return ()
    where
      startCB :: HANDLE -> Ptr OVERLAPPED -> IO (CbResult a)
startCB HANDLE
wh Ptr OVERLAPPED
lpOverlapped = do
        ret <- HANDLE -> Word32 -> Word32 -> Word32 -> Ptr OVERLAPPED -> IO Bool
c_UnlockFileEx HANDLE
wh Word32
0 Word32
4294967295 Word32
4294967295
{-# LINE 106 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Handle\\Lock\\Windows.hsc" #-}
                              Ptr OVERLAPPED
lpOverlapped
        return $ Mgr.CbNone ret

      completionCB :: a -> p -> IO (IOResult a)
completionCB a
err p
_dwBytes
        | a
err a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 = a -> IO (IOResult a)
forall a. a -> IO (IOResult a)
Mgr.ioSuccess a
0
{-# LINE 111 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Handle\\Lock\\Windows.hsc" #-}
        | Bool
otherwise                     = a -> IO (IOResult a)
forall a. Integral a => a -> IO (IOResult a)
Mgr.ioFailed a
err

unlockImplPOSIX :: Handle -> IO ()
unlockImplPOSIX :: Handle -> IO ()
unlockImplPOSIX Handle
h = do
  FD{fdFD = fd} <- Handle -> IO FD
handleToFd Handle
h
  wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) "hUnlock" $ c_get_osfhandle fd
  allocaBytes sizeof_OVERLAPPED $ \Ptr OVERLAPPED
ovrlpd -> do
    Ptr OVERLAPPED -> Word8 -> Int -> IO ()
forall a. Ptr a -> Word8 -> Int -> IO ()
fillBytes Ptr OVERLAPPED
ovrlpd Word8
0 Int
sizeof_OVERLAPPED
    HANDLE -> Word32 -> Word32 -> Word32 -> Ptr OVERLAPPED -> IO Bool
c_UnlockFileEx HANDLE
wh Word32
0 Word32
4294967295 Word32
4294967295 Ptr OVERLAPPED
ovrlpd IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
{-# LINE 120 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Handle\\Lock\\Windows.hsc" #-}
      True  -> return ()
      False -> getLastError >>= failWith "hUnlock"
  where
    sizeof_OVERLAPPED :: Int
sizeof_OVERLAPPED = (Int
32)
{-# LINE 124 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Handle\\Lock\\Windows.hsc" #-}

-- https://msdn.microsoft.com/en-us/library/aa297958.aspx

foreign import ccall unsafe "_get_osfhandle"
  c_get_osfhandle :: CInt -> IO HANDLE

-- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365203.aspx

foreign import ccall interruptible "LockFileEx"
  c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED
               -> IO BOOL

-- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365716.aspx

foreign import ccall interruptible "UnlockFileEx"
  c_UnlockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO BOOL


{-# LINE 139 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Handle\\Lock\\Windows.hsc" #-}