{-# 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 { 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 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 :: Handle -> String -> LockMode -> Bool -> IO Bool
lockImpl Handle
h String
ctx LockMode
mode Bool
block = do
  FD{fdFD :: FD -> CInt
fdFD = CInt
fd} <- Handle -> IO FD
handleToFd Handle
h
  FLock -> (Ptr FLock -> IO Bool) -> IO Bool
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
Instance of class: Storable of the constraint type Storable FLock
with FLock
flock ((Ptr FLock -> IO Bool) -> IO Bool)
-> (Ptr FLock -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \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
      CInt
ret <- CInt -> CInt -> Ptr FLock -> IO CInt
c_fcntl CInt
fd CInt
mode' Ptr FLock
flock_ptr
      case CInt
ret of
        CInt
0 -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad IO
return Bool
True
        CInt
_ -> IO Errno
getErrno IO Errno -> (Errno -> IO Bool) -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
External instance of the constraint type Monad IO
>>= \Errno
errno -> if
          | Bool -> Bool
not Bool
block Bool -> Bool -> Bool
&& Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq Errno
== Errno
eWOULDBLOCK -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad IO
return Bool
False
          | Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq Errno
== Errno
eINTR -> IO Bool
retry
          | Bool
otherwise -> IOException -> IO Bool
forall a. 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 :: CShort -> CShort -> COff -> COff -> CPid -> FLock
FLock { l_type :: CShort
l_type = case LockMode
mode of
                               LockMode
SharedLock -> CShort
0
{-# LINE 84 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-}
                               LockMode
ExclusiveLock -> CShort
1
{-# LINE 85 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-}
                  , l_whence :: CShort
l_whence = CShort
0
{-# LINE 86 "libraries/base/GHC/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 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 :: Handle -> IO ()
unlockImpl Handle
h = do
  FD{fdFD :: FD -> CInt
fdFD = CInt
fd} <- Handle -> IO FD
handleToFd Handle
h
  let flock :: FLock
flock = FLock :: CShort -> CShort -> COff -> COff -> CPid -> FLock
FLock { l_type :: CShort
l_type = CShort
2
{-# LINE 98 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-}
                    , l_whence :: CShort
l_whence = CShort
0
{-# LINE 99 "libraries/base/GHC/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
                    }
  String -> IO CInt -> IO ()
forall a. (Eq a, Num a) => String -> IO a -> IO ()
External instance of the constraint type Num CInt
External instance of the constraint type Eq CInt
throwErrnoIfMinus1_ String
"hUnlock"
      (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ FLock -> (Ptr FLock -> IO CInt) -> IO CInt
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
Instance of class: Storable of the constraint type Storable FLock
with FLock
flock ((Ptr FLock -> IO CInt) -> IO CInt)
-> (Ptr FLock -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ CInt -> CInt -> Ptr FLock -> IO CInt
c_fcntl CInt
fd CInt
37
{-# LINE 105 "libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc" #-}


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