dist-install/build/GHC/IO/Handle/Lock/LinuxOFD.hs

    {-# OPTIONS_GHC -optc-D_FILE_OFFSET_BITS=64 #-}
    {-# LINE 1 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-}
    {-# LANGUAGE CApiFFI #-}
    {-# LANGUAGE CPP #-}
    {-# LANGUAGE CApiFFI #-}
    {-# LANGUAGE InterruptibleFFI #-}
    {-# LANGUAGE MultiWayIf #-}
    {-# LANGUAGE NoImplicitPrelude #-}

    -- | File locking via the Linux open-fd locking mechanism.
    module GHC.IO.Handle.Lock.LinuxOFD where

    {-# LINE 16 "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 capi interruptible "fcntl.h 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 57 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-}
        alignment _ = 8
    {-# LINE 58 "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 61 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-}
            (\hsc_ptr -> pokeByteOff hsc_ptr 2) ptr (l_whence x)
    {-# LINE 62 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-}
            (\hsc_ptr -> pokeByteOff hsc_ptr 8)  ptr (l_start x)
    {-# LINE 63 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-}
            (\hsc_ptr -> pokeByteOff hsc_ptr 16)    ptr (l_len x)
    {-# LINE 64 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-}
            (\hsc_ptr -> pokeByteOff hsc_ptr 24)    ptr (l_pid x)
    {-# LINE 65 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-}
        peek ptr =
            FLock <$> (\hsc_ptr -> peekByteOff hsc_ptr 0)   ptr
    {-# LINE 67 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-}
                  <*> (\hsc_ptr -> peekByteOff hsc_ptr 2) ptr
    {-# LINE 68 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-}
                  <*> (\hsc_ptr -> peekByteOff hsc_ptr 8)  ptr
    {-# LINE 69 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-}
                  <*> (\hsc_ptr -> peekByteOff hsc_ptr 16)    ptr
    {-# LINE 70 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-}
                  <*> (\hsc_ptr -> peekByteOff hsc_ptr 24)    ptr
    {-# LINE 71 "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 86 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-}
                                   ExclusiveLock -> 1
    {-# LINE 87 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-}
                      , l_whence = 0
    {-# LINE 88 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-}
                      , l_start = 0
                      , l_len = 0
                      , l_pid = 0
                      }
        mode'
          | block     = 38
    {-# LINE 94 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-}
          | otherwise = 37
    {-# LINE 95 "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 100 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-}
                        , l_whence = 0
    {-# LINE 101 "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 107 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-}

    {-# LINE 109 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-}