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

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




{-# LINE 16 "libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/LinuxOFD.hsc" #-}

-- Not only is this a good idea but it also works around #17950.





import GHC.Internal.Classes (Eq(..), not, (&&))
import GHC.Internal.Data.Function
import GHC.Internal.Data.Functor
import GHC.Internal.Foreign.C.Error
import GHC.Internal.Foreign.C.Types
import GHC.Internal.Foreign.Marshal.Utils
import GHC.Internal.Foreign.Storable
import GHC.Internal.Base (String, otherwise, return, (<*>), (>>=))
import GHC.Internal.IO.Exception
import GHC.Internal.IO.FD
import GHC.Internal.IO.Handle.FD
import GHC.Internal.IO.Handle.Lock.Common
import GHC.Internal.IO.Handle.Types (Handle)
import GHC.Internal.Maybe (Maybe(..))
import GHC.Internal.Ptr
import GHC.Internal.System.Posix.Types (COff, CPid)
import GHC.Internal.Types (Bool(..), IO)

-- 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 { FLock -> CShort
l_type   :: CShort
                    , FLock -> CShort
l_whence :: CShort
                    , FLock -> COff
l_start  :: COff
                    , FLock -> COff
l_len    :: COff
                    , FLock -> CPid
l_pid    :: CPid
                    }

instance Storable FLock where
    sizeOf :: FLock -> Int
sizeOf FLock
_ = (Int
32)
{-# LINE 60 "libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/LinuxOFD.hsc" #-}
    alignment _ = 8
{-# LINE 61 "libraries/ghc-internal/src/GHC/Internal/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 64 "libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/LinuxOFD.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 2) ptr (l_whence x)
{-# LINE 65 "libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/LinuxOFD.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 8)  ptr (l_start x)
{-# LINE 66 "libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/LinuxOFD.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 16)    ptr (l_len x)
{-# LINE 67 "libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/LinuxOFD.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 24)    ptr (l_pid x)
{-# LINE 68 "libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/LinuxOFD.hsc" #-}
    peek ptr =
        FLock <$> (\hsc_ptr -> peekByteOff hsc_ptr 0)   ptr
{-# LINE 70 "libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/LinuxOFD.hsc" #-}
              <*> (\hsc_ptr -> peekByteOff hsc_ptr 2) ptr
{-# LINE 71 "libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/LinuxOFD.hsc" #-}
              <*> (\hsc_ptr -> peekByteOff hsc_ptr 8)  ptr
{-# LINE 72 "libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/LinuxOFD.hsc" #-}
              <*> (\hsc_ptr -> peekByteOff hsc_ptr 16)    ptr
{-# LINE 73 "libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/LinuxOFD.hsc" #-}
              <*> (\hsc_ptr -> peekByteOff hsc_ptr 24)    ptr
{-# LINE 74 "libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/LinuxOFD.hsc" #-}

lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
lockImpl Handle
h String
ctx LockMode
mode Bool
block = do
  FD{fdFD = fd} <- Handle -> IO FD
handleToFd Handle
h
  with flock $ \Ptr FLock
flock_ptr -> (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 -> do
      ret <- CInt -> CInt -> Ptr FLock -> IO CInt
c_fcntl CInt
fd CInt
mode' Ptr FLock
flock_ptr
      case ret of
        CInt
0 -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        CInt
_ -> IO Errno
getErrno IO Errno -> (Errno -> 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
>>= \Errno
errno -> if
          | Bool -> Bool
not Bool
block Bool -> Bool -> Bool
&& Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eWOULDBLOCK -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
          | Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eINTR -> IO Bool
retry
          | Bool
otherwise -> IOException -> IO Bool
forall a. HasCallStack => IOException -> IO a
ioException (IOException -> IO Bool) -> IOException -> IO Bool
forall a b. (a -> b) -> a -> b
$ String -> Errno -> Maybe Handle -> Maybe String -> IOException
errnoToIOError String
ctx Errno
errno (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
h) Maybe String
forall a. Maybe a
Nothing
  where
    flock :: FLock
flock = FLock { l_type :: CShort
l_type = case LockMode
mode of
                               LockMode
SharedLock -> CShort
0
{-# LINE 89 "libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/LinuxOFD.hsc" #-}
                               LockMode
ExclusiveLock -> CShort
1
{-# LINE 90 "libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/LinuxOFD.hsc" #-}
                  , l_whence :: CShort
l_whence = CShort
0
{-# LINE 91 "libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/LinuxOFD.hsc" #-}
                  , l_start :: COff
l_start = COff
0
                  , l_len :: COff
l_len = COff
0
                  , l_pid :: CPid
l_pid = CPid
0
                  }
    mode' :: CInt
mode'
      | Bool
block     = CInt
38
{-# LINE 97 "libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/LinuxOFD.hsc" #-}
      | otherwise = 37
{-# LINE 98 "libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/LinuxOFD.hsc" #-}

unlockImpl :: Handle -> IO ()
unlockImpl :: Handle -> IO ()
unlockImpl Handle
h = do
  FD{fdFD = fd} <- Handle -> IO FD
handleToFd Handle
h
  let flock = FLock { l_type :: CShort
l_type = CShort
2
{-# LINE 103 "libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/LinuxOFD.hsc" #-}
                    , l_whence :: CShort
l_whence = CShort
0
{-# LINE 104 "libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/LinuxOFD.hsc" #-}
                    , l_start :: COff
l_start = COff
0
                    , l_len :: COff
l_len = COff
0
                    , l_pid :: CPid
l_pid = CPid
0
                    }
  throwErrnoIfMinus1_ "hUnlock"
      $ with flock $ c_fcntl fd 37
{-# LINE 110 "libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/LinuxOFD.hsc" #-}


{-# LINE 112 "libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/LinuxOFD.hsc" #-}