{-# OPTIONS_GHC -optc-D_GNU_SOURCE #-}
{-# LINE 1 "src-ofd/Lukko/OFD.hsc" #-}
{-# LANGUAGE CApiFFI #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE InterruptibleFFI #-}
{-# LANGUAGE Trustworthy #-}
-- | Linux open file descriptor locking.
-- 
-- <https://www.gnu.org/software/libc/manual/html_node/Open-File-Description-Locks.html>
--
-- 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.
--
module Lukko.OFD (
    -- * Types
    FileLockingNotSupported(..),
    fileLockingSupported,
    FileLockingSupported,
    FileLockingMethod (..),
    fileLockingMethod,
    LockMode(..),
    -- * File descriptors
    FD,
    fdOpen,
    fdClose,
    fdLock,
    fdTryLock,
    fdUnlock,
    -- * Handles
    hLock,
    hTryLock,
    hUnlock,
    ) where




-- Support for file description locks (F_OFD_SETLKW and F_OFD_SETLK) was added
-- to glibc in version 2.20. If we have an older version then we must get the
-- functionality directly from the linux headers.
--
-- See glibc 2.20 release notes: <https://sourceware.org/legacy-ml/libc-alpha/2014-09/msg00088.html>

{-# LINE 45 "src-ofd/Lukko/OFD.hsc" #-}

{-# LINE 46 "src-ofd/Lukko/OFD.hsc" #-}


{-# LINE 50 "src-ofd/Lukko/OFD.hsc" #-}

{-# LINE 53 "src-ofd/Lukko/OFD.hsc" #-}

import Control.Monad (void)
import System.IO (Handle)

import Data.Function
import Foreign.C.Error
import Foreign.C.Types
import Foreign.Marshal.Utils
import Foreign.Storable
import GHC.IO.Exception
import GHC.Ptr
import System.Posix.Types (COff, CPid)

import Lukko.Internal.FD
import Lukko.Internal.FillBytes
import Lukko.Internal.Types

-------------------------------------------------------------------------------
-- Support constants
-------------------------------------------------------------------------------

-- | A constants specifying whether file locking is supported.
fileLockingSupported :: Bool
fileLockingSupported :: Bool
fileLockingSupported = Bool
True

-- | A type level 'fileLockingSupported'.
type FileLockingSupported = True

-- | A constant specifying this method
fileLockingMethod :: FileLockingMethod
fileLockingMethod :: FileLockingMethod
fileLockingMethod = FileLockingMethod
MethodOFD

-------------------------------------------------------------------------------
-- FD
-------------------------------------------------------------------------------

-- | Lock using OFD locks.
fdLock :: FD -> LockMode -> IO ()
fdLock :: FD -> LockMode -> IO ()
fdLock FD
fd LockMode
mode = IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Maybe Handle -> FD -> String -> LockMode -> Bool -> IO Bool
lockImpl Maybe Handle
forall a. Maybe a
Nothing FD
fd String
"fdLock" LockMode
mode Bool
True)

-- | Try to lock using OFD locks.
fdTryLock :: FD -> LockMode -> IO Bool
fdTryLock :: FD -> LockMode -> IO Bool
fdTryLock FD
fd LockMode
mode = Maybe Handle -> FD -> String -> LockMode -> Bool -> IO Bool
lockImpl Maybe Handle
forall a. Maybe a
Nothing FD
fd String
"fdTryLock" LockMode
mode Bool
False

-- | Unlock using OFD locks.
fdUnlock :: FD -> IO ()
fdUnlock :: FD -> IO ()
fdUnlock = FD -> IO ()
unlockImpl

-------------------------------------------------------------------------------
-- Handle
-------------------------------------------------------------------------------

-- | Lock using OFD locks.
hLock :: Handle -> LockMode -> IO ()
hLock :: Handle -> LockMode -> IO ()
hLock Handle
h LockMode
mode = do
    FD
fd <- Handle -> IO FD
handleToFd Handle
h
    IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Maybe Handle -> FD -> String -> LockMode -> Bool -> IO Bool
lockImpl (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
h) FD
fd String
"hLock" LockMode
mode Bool
True)

-- | Try to lock using OFD locks.
hTryLock :: Handle -> LockMode -> IO Bool
hTryLock :: Handle -> LockMode -> IO Bool
hTryLock Handle
h LockMode
mode = do
    FD
fd <- Handle -> IO FD
handleToFd Handle
h
    Maybe Handle -> FD -> String -> LockMode -> Bool -> IO Bool
lockImpl (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
h) FD
fd String
"hTryLock" LockMode
mode Bool
False

-- | Unlock using OFD locks.
hUnlock :: Handle -> IO ()
hUnlock :: Handle -> IO ()
hUnlock Handle
h = do
    FD
fd <- Handle -> IO FD
handleToFd Handle
h
    FD -> IO ()
unlockImpl FD
fd

-------------------------------------------------------------------------------
-- Compat
-------------------------------------------------------------------------------

-- there is no alignment in old hsc2hs

{-# LINE 129 "src-ofd/Lukko/OFD.hsc" #-}

{-# LINE 132 "src-ofd/Lukko/OFD.hsc" #-}

{-# LINE 137 "src-ofd/Lukko/OFD.hsc" #-}


{-# LINE 141 "src-ofd/Lukko/OFD.hsc" #-}

-------------------------------------------------------------------------------
-- implementation
-------------------------------------------------------------------------------

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 158 "src-ofd/Lukko/OFD.hsc" #-}
    alignment _ = 8
{-# LINE 159 "src-ofd/Lukko/OFD.hsc" #-}
    poke ptr x = do
        fillBytes ptr 0 (sizeOf x)
        (\hsc_ptr -> pokeByteOff hsc_ptr 0)   ptr (l_type x)
{-# LINE 162 "src-ofd/Lukko/OFD.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 2) ptr (l_whence x)
{-# LINE 163 "src-ofd/Lukko/OFD.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 8)  ptr (l_start x)
{-# LINE 164 "src-ofd/Lukko/OFD.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 16)    ptr (l_len x)
{-# LINE 165 "src-ofd/Lukko/OFD.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 24)    ptr (l_pid x)
{-# LINE 166 "src-ofd/Lukko/OFD.hsc" #-}
    peek ptr = do
        x1 <- (\hsc_ptr -> peekByteOff hsc_ptr 0)   ptr
{-# LINE 168 "src-ofd/Lukko/OFD.hsc" #-}
        x2 <- (\hsc_ptr -> peekByteOff hsc_ptr 2) ptr
{-# LINE 169 "src-ofd/Lukko/OFD.hsc" #-}
        x3 <- (\hsc_ptr -> peekByteOff hsc_ptr 8)  ptr
{-# LINE 170 "src-ofd/Lukko/OFD.hsc" #-}
        x4 <- (\hsc_ptr -> peekByteOff hsc_ptr 16)    ptr
{-# LINE 171 "src-ofd/Lukko/OFD.hsc" #-}
        x5 <- (\hsc_ptr -> peekByteOff hsc_ptr 24)    ptr
{-# LINE 172 "src-ofd/Lukko/OFD.hsc" #-}
        return (FLock x1 x2 x3 x4 x5)

lockImpl :: Maybe Handle -> FD -> String -> LockMode -> Bool -> IO Bool
lockImpl :: Maybe Handle -> FD -> String -> LockMode -> Bool -> IO Bool
lockImpl Maybe Handle
mh (FD CInt
fd) String
ctx LockMode
mode Bool
block = do
  FLock -> (Ptr FLock -> IO Bool) -> IO Bool
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
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 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 -> case () of
          ()
_ | 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. 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 Maybe Handle
mh 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 187 "src-ofd/Lukko/OFD.hsc" #-}
                               LockMode
ExclusiveLock -> CShort
1
{-# LINE 188 "src-ofd/Lukko/OFD.hsc" #-}
                  , l_whence :: CShort
l_whence = CShort
0
{-# LINE 189 "src-ofd/Lukko/OFD.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 195 "src-ofd/Lukko/OFD.hsc" #-}
      | otherwise = 37
{-# LINE 196 "src-ofd/Lukko/OFD.hsc" #-}

unlockImpl :: FD -> IO ()
unlockImpl :: FD -> IO ()
unlockImpl (FD CInt
fd) = do
  let flock :: FLock
flock = FLock { l_type :: CShort
l_type = CShort
2
{-# LINE 200 "src-ofd/Lukko/OFD.hsc" #-}
                    , l_whence :: CShort
l_whence = CShort
0
{-# LINE 201 "src-ofd/Lukko/OFD.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 ()
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
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 207 "src-ofd/Lukko/OFD.hsc" #-}