{-# 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





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 115 "src-ofd/Lukko/OFD.hsc" #-}

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

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


{-# LINE 127 "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 144 "src-ofd/Lukko/OFD.hsc" #-}
    alignment _ = 8
{-# LINE 145 "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 148 "src-ofd/Lukko/OFD.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 2) ptr (l_whence x)
{-# LINE 149 "src-ofd/Lukko/OFD.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 8)  ptr (l_start x)
{-# LINE 150 "src-ofd/Lukko/OFD.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 16)    ptr (l_len x)
{-# LINE 151 "src-ofd/Lukko/OFD.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 24)    ptr (l_pid x)
{-# LINE 152 "src-ofd/Lukko/OFD.hsc" #-}
    peek ptr = do
        x1 <- (\hsc_ptr -> peekByteOff hsc_ptr 0)   ptr
{-# LINE 154 "src-ofd/Lukko/OFD.hsc" #-}
        x2 <- (\hsc_ptr -> peekByteOff hsc_ptr 2) ptr
{-# LINE 155 "src-ofd/Lukko/OFD.hsc" #-}
        x3 <- (\hsc_ptr -> peekByteOff hsc_ptr 8)  ptr
{-# LINE 156 "src-ofd/Lukko/OFD.hsc" #-}
        x4 <- (\hsc_ptr -> peekByteOff hsc_ptr 16)    ptr
{-# LINE 157 "src-ofd/Lukko/OFD.hsc" #-}
        x5 <- (\hsc_ptr -> peekByteOff hsc_ptr 24)    ptr
{-# LINE 158 "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 (m :: * -> *) a. Monad m => a -> m a
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
>>= \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 (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 :: CShort -> CShort -> COff -> COff -> CPid -> FLock
FLock { l_type :: CShort
l_type = case LockMode
mode of
                               LockMode
SharedLock -> CShort
0
{-# LINE 173 "src-ofd/Lukko/OFD.hsc" #-}
                               LockMode
ExclusiveLock -> CShort
1
{-# LINE 174 "src-ofd/Lukko/OFD.hsc" #-}
                  , l_whence :: CShort
l_whence = CShort
0
{-# LINE 175 "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 181 "src-ofd/Lukko/OFD.hsc" #-}
      | otherwise = 37
{-# LINE 182 "src-ofd/Lukko/OFD.hsc" #-}

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