{-# OPTIONS_GHC -optc-D_GNU_SOURCE #-}
{-# LINE 1 "src-ofd/Lukko/OFD.hsc" #-}
{-# 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 = True

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

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

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

-- | Lock using OFD locks.
fdLock :: FD -> LockMode -> IO ()
fdLock fd mode = void (lockImpl Nothing fd "fdLock" mode True)

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

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

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

-- | Lock using OFD locks.
hLock :: Handle -> LockMode -> IO ()
hLock h mode = do
    fd <- handleToFd h
    void (lockImpl (Just h) fd "hLock" mode True)

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

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

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

-- there is no alignment in old hsc2hs


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

foreign import ccall interruptible "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 131 "src-ofd/Lukko/OFD.hsc" #-}
    alignment _ = 8
{-# LINE 132 "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 135 "src-ofd/Lukko/OFD.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 2) ptr (l_whence x)
{-# LINE 136 "src-ofd/Lukko/OFD.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 8)  ptr (l_start x)
{-# LINE 137 "src-ofd/Lukko/OFD.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 16)    ptr (l_len x)
{-# LINE 138 "src-ofd/Lukko/OFD.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 24)    ptr (l_pid x)
{-# LINE 139 "src-ofd/Lukko/OFD.hsc" #-}
    peek ptr = do
        x1 <- (\hsc_ptr -> peekByteOff hsc_ptr 0)   ptr
{-# LINE 141 "src-ofd/Lukko/OFD.hsc" #-}
        x2 <- (\hsc_ptr -> peekByteOff hsc_ptr 2) ptr
{-# LINE 142 "src-ofd/Lukko/OFD.hsc" #-}
        x3 <- (\hsc_ptr -> peekByteOff hsc_ptr 8)  ptr
{-# LINE 143 "src-ofd/Lukko/OFD.hsc" #-}
        x4 <- (\hsc_ptr -> peekByteOff hsc_ptr 16)    ptr
{-# LINE 144 "src-ofd/Lukko/OFD.hsc" #-}
        x5 <- (\hsc_ptr -> peekByteOff hsc_ptr 24)    ptr
{-# LINE 145 "src-ofd/Lukko/OFD.hsc" #-}
        return (FLock x1 x2 x3 x4 x5)

lockImpl :: Maybe Handle -> FD -> String -> LockMode -> Bool -> IO Bool
lockImpl mh (FD fd) ctx mode block = do
  with flock $ \flock_ptr -> fix $ \retry -> do
      ret <- c_fcntl fd mode' flock_ptr
      case ret of
        0 -> return True
        _ -> getErrno >>= \errno -> case () of
          _ | not block && errno == eWOULDBLOCK -> return False
            | errno == eINTR -> retry
            | otherwise -> ioException $ errnoToIOError ctx errno mh Nothing
  where
    flock = FLock { l_type = case mode of
                               SharedLock -> 0
{-# LINE 160 "src-ofd/Lukko/OFD.hsc" #-}
                               ExclusiveLock -> 1
{-# LINE 161 "src-ofd/Lukko/OFD.hsc" #-}
                  , l_whence = 0
{-# LINE 162 "src-ofd/Lukko/OFD.hsc" #-}
                  , l_start = 0
                  , l_len = 0
                  , l_pid = 0
                  }
    mode'
      | block     = 38
{-# LINE 168 "src-ofd/Lukko/OFD.hsc" #-}
      | otherwise = 37
{-# LINE 169 "src-ofd/Lukko/OFD.hsc" #-}

unlockImpl :: FD -> IO ()
unlockImpl (FD fd) = do
  let flock = FLock { l_type = 2
{-# LINE 173 "src-ofd/Lukko/OFD.hsc" #-}
                    , l_whence = 0
{-# LINE 174 "src-ofd/Lukko/OFD.hsc" #-}
                    , l_start = 0
                    , l_len = 0
                    , l_pid = 0
                    }
  throwErrnoIfMinus1_ "hUnlock"
      $ with flock $ c_fcntl fd 37
{-# LINE 180 "src-ofd/Lukko/OFD.hsc" #-}