{-# LINE 1 "libraries\\base\\GHC\\IO\\Handle\\Lock.hsc" #-} {-# LANGUAGE CPP #-} {-# LANGUAGE InterruptibleFFI #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} module GHC.IO.Handle.Lock ( FileLockingNotSupported(..) , LockMode(..) , hLock , hTryLock , hUnlock ) where {-# LINE 29 "libraries\\base\\GHC\\IO\\Handle\\Lock.hsc" #-} {-# LINE 31 "libraries\\base\\GHC\\IO\\Handle\\Lock.hsc" #-} # define WINDOWS_CCONV stdcall {-# LINE 37 "libraries\\base\\GHC\\IO\\Handle\\Lock.hsc" #-} import Data.Bits import Data.Function import Foreign.C.Error import Foreign.C.Types import Foreign.Marshal.Alloc import Foreign.Marshal.Utils import GHC.IO.FD import GHC.IO.Handle.FD import GHC.Ptr import GHC.Windows {-# LINE 56 "libraries\\base\\GHC\\IO\\Handle\\Lock.hsc" #-} import Data.Functor import GHC.Base import GHC.Exception import GHC.IO.Handle.Types import GHC.Show -- | Exception thrown by 'hLock' on non-Windows platforms that don't support -- 'flock'. data FileLockingNotSupported = FileLockingNotSupported deriving Show instance Exception FileLockingNotSupported -- | Indicates a mode in which a file should be locked. data LockMode = SharedLock | ExclusiveLock -- | If a 'Handle' references a file descriptor, attempt to lock contents of the -- underlying file in appropriate mode. If the file is already locked in -- incompatible mode, this function blocks until the lock is established. The -- lock is automatically released upon closing a 'Handle'. -- -- Things to be aware of: -- -- 1) This function may block inside a C call. If it does, in order to be able -- to interrupt it with asynchronous exceptions and/or for other threads to -- continue working, you MUST use threaded version of the runtime system. -- -- 2) The implementation uses 'LockFileEx' on Windows and 'flock' otherwise, -- hence all of their caveats also apply here. -- -- 3) On non-Windows plaftorms that don't support 'flock' (e.g. Solaris) this -- function throws 'FileLockingNotImplemented'. We deliberately choose to not -- provide fcntl based locking instead because of its broken semantics. -- -- @since 4.10.0.0 hLock :: Handle -> LockMode -> IO () hLock h mode = void $ lockImpl h "hLock" mode True -- | Non-blocking version of 'hLock'. -- -- @since 4.10.0.0 hTryLock :: Handle -> LockMode -> IO Bool hTryLock h mode = lockImpl h "hTryLock" mode False -- | Release a lock taken with 'hLock' or 'hTryLock'. hUnlock :: Handle -> IO () hUnlock = unlockImpl ---------------------------------------- {-# LINE 203 "libraries\\base\\GHC\\IO\\Handle\\Lock.hsc" #-} lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool lockImpl h ctx mode block = do FD{fdFD = fd} <- handleToFd h wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) ctx $ c_get_osfhandle fd allocaBytes sizeof_OVERLAPPED $ \ovrlpd -> do fillBytes ovrlpd 0 sizeof_OVERLAPPED let flags = cmode .|. (if block then 0 else 1) {-# LINE 211 "libraries\\base\\GHC\\IO\\Handle\\Lock.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. fix $ \retry -> c_LockFileEx wh flags 0 0xffffffff 0xffffffff ovrlpd >>= \case True -> return True False -> getLastError >>= \err -> if | not block && err == 33 -> return False {-# LINE 220 "libraries\\base\\GHC\\IO\\Handle\\Lock.hsc" #-} | err == 995 -> retry {-# LINE 221 "libraries\\base\\GHC\\IO\\Handle\\Lock.hsc" #-} | otherwise -> failWith ctx err where sizeof_OVERLAPPED = (20) {-# LINE 224 "libraries\\base\\GHC\\IO\\Handle\\Lock.hsc" #-} cmode = case mode of SharedLock -> 0 ExclusiveLock -> 2 {-# LINE 228 "libraries\\base\\GHC\\IO\\Handle\\Lock.hsc" #-} unlockImpl :: Handle -> IO () unlockImpl h = do FD{fdFD = fd} <- handleToFd h wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) "hUnlock" $ c_get_osfhandle fd allocaBytes sizeof_OVERLAPPED $ \ovrlpd -> do fillBytes ovrlpd 0 sizeof_OVERLAPPED c_UnlockFileEx wh 0 0xffffffff 0xffffffff ovrlpd >>= \case True -> return () False -> getLastError >>= failWith "hUnlock" where sizeof_OVERLAPPED = (20) {-# LINE 240 "libraries\\base\\GHC\\IO\\Handle\\Lock.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 WINDOWS_CCONV interruptible "LockFileEx" c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> Ptr () -> IO BOOL -- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365716.aspx foreign import WINDOWS_CCONV interruptible "UnlockFileEx" c_UnlockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> Ptr () -> IO BOOL {-# LINE 264 "libraries\\base\\GHC\\IO\\Handle\\Lock.hsc" #-}