{-# OPTIONS_GHC -optc-D_FILE_OFFSET_BITS=64 #-} {-# LINE 1 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-} {-# LANGUAGE CPP #-} {-# LANGUAGE InterruptibleFFI #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -- | File locking via the Linux open-fd locking mechanism. module GHC.IO.Handle.Lock.LinuxOFD where {-# LINE 14 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-} -- Not only is this a good idea but it also works around #17950. import Data.Function import Data.Functor import Foreign.C.Error import Foreign.C.Types import Foreign.Marshal.Utils import Foreign.Storable import GHC.Base import GHC.IO.Exception import GHC.IO.FD import GHC.IO.Handle.FD import GHC.IO.Handle.Lock.Common import GHC.IO.Handle.Types (Handle) import GHC.Ptr import System.Posix.Types (COff, CPid) -- Linux open file descriptor locking. -- -- We prefer this over BSD locking (e.g. flock) since the latter appears to -- break in some NFS configurations. Note that we intentionally do not try to -- use ordinary POSIX file locking due to its peculiar semantics under -- multi-threaded environments. foreign import ccall interruptible "fcntl" c_fcntl :: CInt -> CInt -> Ptr FLock -> IO CInt data FLock = FLock { l_type :: CShort , l_whence :: CShort , l_start :: COff , l_len :: COff , l_pid :: CPid } instance Storable FLock where sizeOf _ = (32) {-# LINE 55 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-} alignment _ = 8 {-# LINE 56 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-} poke ptr x = do fillBytes ptr 0 (sizeOf x) (\hsc_ptr -> pokeByteOff hsc_ptr 0) ptr (l_type x) {-# LINE 59 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-} (\hsc_ptr -> pokeByteOff hsc_ptr 2) ptr (l_whence x) {-# LINE 60 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-} (\hsc_ptr -> pokeByteOff hsc_ptr 8) ptr (l_start x) {-# LINE 61 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-} (\hsc_ptr -> pokeByteOff hsc_ptr 16) ptr (l_len x) {-# LINE 62 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-} (\hsc_ptr -> pokeByteOff hsc_ptr 24) ptr (l_pid x) {-# LINE 63 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-} peek ptr = do FLock <$> (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr {-# LINE 65 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-} <*> (\hsc_ptr -> peekByteOff hsc_ptr 2) ptr {-# LINE 66 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-} <*> (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr {-# LINE 67 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-} <*> (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr {-# LINE 68 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-} <*> (\hsc_ptr -> peekByteOff hsc_ptr 24) ptr {-# LINE 69 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-} lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool lockImpl h ctx mode block = do FD{fdFD = fd} <- handleToFd h with flock $ \flock_ptr -> fix $ \retry -> do ret <- c_fcntl fd mode' flock_ptr case ret of 0 -> return True _ -> getErrno >>= \errno -> if | not block && errno == eWOULDBLOCK -> return False | errno == eINTR -> retry | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing where flock = FLock { l_type = case mode of SharedLock -> 0 {-# LINE 84 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-} ExclusiveLock -> 1 {-# LINE 85 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-} , l_whence = 0 {-# LINE 86 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-} , l_start = 0 , l_len = 0 , l_pid = 0 } mode' | block = 38 {-# LINE 92 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-} | otherwise = 37 {-# LINE 93 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-} unlockImpl :: Handle -> IO () unlockImpl h = do FD{fdFD = fd} <- handleToFd h let flock = FLock { l_type = 2 {-# LINE 98 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-} , l_whence = 0 {-# LINE 99 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-} , l_start = 0 , l_len = 0 , l_pid = 0 } throwErrnoIfMinus1_ "hUnlock" $ with flock $ c_fcntl fd 37 {-# LINE 105 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-} {-# LINE 107 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-}