{-# 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 17 "libraries/base/GHC/IO/Handle/Lock.hsc" #-}
import Data.Bits
import Data.Function
import Foreign.C.Error
import Foreign.C.Types
import GHC.IO.Exception
import GHC.IO.FD
import GHC.IO.Handle.FD
{-# 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
data FileLockingNotSupported = FileLockingNotSupported
deriving Show
instance Exception FileLockingNotSupported
data LockMode = SharedLock | ExclusiveLock
hLock :: Handle -> LockMode -> IO ()
hLock h mode = void $ lockImpl h "hLock" mode True
hTryLock :: Handle -> LockMode -> IO Bool
hTryLock h mode = lockImpl h "hTryLock" mode False
hUnlock :: Handle -> IO ()
hUnlock = unlockImpl
{-# LINE 177 "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
let flags = cmode .|. (if block then 0 else 4)
{-# LINE 182 "libraries/base/GHC/IO/Handle/Lock.hsc" #-}
fix $ \retry -> c_flock fd flags >>= \case
0 -> return True
_ -> getErrno >>= \errno -> if
| not block
, errno == eAGAIN || errno == eACCES -> return False
| errno == eINTR -> retry
| otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing
where
cmode = case mode of
SharedLock -> 1
{-# LINE 192 "libraries/base/GHC/IO/Handle/Lock.hsc" #-}
ExclusiveLock -> 2
{-# LINE 193 "libraries/base/GHC/IO/Handle/Lock.hsc" #-}
unlockImpl :: Handle -> IO ()
unlockImpl h = do
FD{fdFD = fd} <- handleToFd h
throwErrnoIfMinus1_ "flock" $ c_flock fd 8
{-# LINE 198 "libraries/base/GHC/IO/Handle/Lock.hsc" #-}
foreign import ccall interruptible "flock"
c_flock :: CInt -> CInt -> IO CInt
{-# LINE 264 "libraries/base/GHC/IO/Handle/Lock.hsc" #-}