{-# 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 DWORD) -> IO DWORD
forall a. String -> IO (IOResult a) -> IO a
Mgr.withException String
ctx (IO (IOResult DWORD) -> IO DWORD)
-> IO (IOResult DWORD) -> IO DWORD
forall a b. (a -> b) -> a -> b
$
                          String
-> HANDLE
-> Word64
-> StartIOCallback Int
-> CompletionCallback (IOResult DWORD)
-> IO (IOResult DWORD)
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 -> LPOVERLAPPED -> IO (CbResult a)
startCB HANDLE
wh) CompletionCallback (IOResult DWORD)
forall {a} {p}. Integral a => a -> p -> IO (IOResult a)
completionCB
             case () of
              ()
_ | DWORD
retcode DWORD -> DWORD -> Bool
forall a. Eq a => a -> a -> Bool
== DWORD
995 -> IO Bool
retry
{-# LINE 47 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Handle\\Lock\\Windows.hsc" #-}
                | DWORD
retcode DWORD -> DWORD -> Bool
forall a. Eq a => a -> a -> Bool
== DWORD
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" #-}
                | DWORD
retcode DWORD -> DWORD -> Bool
forall a. Eq a => a -> a -> Bool
== DWORD
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 -> DWORD -> IO Bool
forall a. String -> DWORD -> IO a
failWith String
ctx DWORD
retcode
    where
      cmode :: DWORD
cmode = case LockMode
mode of
                LockMode
SharedLock    -> DWORD
0
                LockMode
ExclusiveLock -> DWORD
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 -> LPOVERLAPPED -> IO (CbResult a)
startCB HANDLE
wh LPOVERLAPPED
lpOverlapped = do
        ret <- HANDLE
-> DWORD -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO Bool
c_LockFileEx HANDLE
wh DWORD
flags DWORD
0 DWORD
4294967295 DWORD
4294967295
{-# LINE 61 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Handle\\Lock\\Windows.hsc" #-}
                            LPOVERLAPPED
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 $ \LPOVERLAPPED
ovrlpd -> do
    LPOVERLAPPED -> Word8 -> Int -> IO ()
forall a. Ptr a -> Word8 -> Int -> IO ()
fillBytes LPOVERLAPPED
ovrlpd Word8
0 Int
sizeof_OVERLAPPED
    let flags :: DWORD
flags = DWORD
cmode DWORD -> DWORD -> DWORD
forall a. Bits a => a -> a -> a
.|. (if Bool
block then DWORD
0 else DWORD
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
-> DWORD -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO Bool
c_LockFileEx HANDLE
wh DWORD
flags DWORD
0 DWORD
4294967295 DWORD
4294967295
{-# LINE 81 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Handle\\Lock\\Windows.hsc" #-}
                                 LPOVERLAPPED
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 DWORD
getLastError IO DWORD -> (DWORD -> 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
>>= \DWORD
err -> if
        | Bool -> Bool
not Bool
block Bool -> Bool -> Bool
&& DWORD
err DWORD -> DWORD -> Bool
forall a. Eq a => a -> a -> Bool
== DWORD
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" #-}
        | DWORD
err DWORD -> DWORD -> Bool
forall a. Eq a => a -> a -> Bool
== DWORD
995           -> IO Bool
retry
{-# LINE 86 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Handle\\Lock\\Windows.hsc" #-}
        | Bool
otherwise                                         -> String -> DWORD -> IO Bool
forall a. String -> DWORD -> IO a
failWith String
ctx DWORD
err
  where
    sizeof_OVERLAPPED :: Int
sizeof_OVERLAPPED = (Int
32)
{-# LINE 89 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Handle\\Lock\\Windows.hsc" #-}

    cmode :: DWORD
cmode = case LockMode
mode of
      LockMode
SharedLock    -> DWORD
0
      LockMode
ExclusiveLock -> DWORD
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 -> LPOVERLAPPED -> IO (CbResult a)
startCB HANDLE
wh LPOVERLAPPED
lpOverlapped = do
        ret <- HANDLE -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO Bool
c_UnlockFileEx HANDLE
wh DWORD
0 DWORD
4294967295 DWORD
4294967295
{-# LINE 106 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Handle\\Lock\\Windows.hsc" #-}
                              LPOVERLAPPED
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 $ \LPOVERLAPPED
ovrlpd -> do
    LPOVERLAPPED -> Word8 -> Int -> IO ()
forall a. Ptr a -> Word8 -> Int -> IO ()
fillBytes LPOVERLAPPED
ovrlpd Word8
0 Int
sizeof_OVERLAPPED
    HANDLE -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO Bool
c_UnlockFileEx HANDLE
wh DWORD
0 DWORD
4294967295 DWORD
4294967295 LPOVERLAPPED
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" #-}