{-# LINE 1 "System/Lock/FLock.hsc" #-}
{-# LANGUAGE ForeignFunctionInterface
{-# LINE 2 "System/Lock/FLock.hsc" #-}
           , CPP
           , FlexibleContexts
           #-}
module System.Lock.FLock
  ( withLock
  , withFdLock
  , lock
  , lockFd
  , unlock
  , SharedExclusive(Shared, Exclusive)
  , Block(Block, NoBlock)
  , Lock
  ) where

import Control.Exception.Lifted    ( bracket )
import Control.Monad.IO.Class      ( MonadIO (..) )
import Control.Monad.Trans.Control ( MonadBaseControl )
import Data.Bits                   ( (.|.) )
import Foreign.C.Error             ( throwErrnoIfMinus1Retry_ )

{-# LINE 22 "System/Lock/FLock.hsc" #-}
import Foreign.C.Types             ( CInt(..) )

{-# LINE 26 "System/Lock/FLock.hsc" #-}
import System.Posix.Error          ( throwErrnoPathIfMinus1Retry_ )
import System.Posix.IO             ( openFd
                                   , defaultFileFlags
                                   , closeFd
                                   , OpenMode(ReadOnly, WriteOnly)
                                   , dup
                                   )
import System.Posix.Types          ( Fd(Fd) )


{-# LINE 36 "System/Lock/FLock.hsc" #-}

c_LOCK_SH, c_LOCK_EX, c_LOCK_UN, c_LOCK_NB :: CInt
c_LOCK_SH = 1
{-# LINE 39 "System/Lock/FLock.hsc" #-}
c_LOCK_EX = 2
{-# LINE 40 "System/Lock/FLock.hsc" #-}
c_LOCK_UN = 8
{-# LINE 41 "System/Lock/FLock.hsc" #-}
c_LOCK_NB = 4
{-# LINE 42 "System/Lock/FLock.hsc" #-}

foreign import ccall safe "sys/file.h flock" flock :: CInt -> CInt -> IO CInt

data SharedExclusive = Shared | Exclusive

data Block = Block | NoBlock

newtype Lock = Lock CInt

withLock :: (MonadIO m, MonadBaseControl IO m) => FilePath -> SharedExclusive -> Block -> m a -> m a
withLock fp se b x =
  bracket
    (lock fp se b)
    unlock
    (const x)

withFdLock :: (MonadIO m, MonadBaseControl IO m) => Fd -> SharedExclusive -> Block -> m a -> m a
withFdLock fd se b x =
  bracket
    (lockFd fd se b)
    unlock
    (const x)

operation :: SharedExclusive -> Block -> CInt
operation se b =
  case b of
    Block   -> op
    NoBlock -> op .|. c_LOCK_NB
  where
    op = case se of
           Shared    -> c_LOCK_SH
           Exclusive -> c_LOCK_EX

lock :: MonadIO m => FilePath -> SharedExclusive -> Block -> m Lock
lock fp se b = liftIO $
  do Fd fd <- openFd fp om Nothing defaultFileFlags
     throwErrnoPathIfMinus1Retry_ "flock" fp $ flock fd (operation se b)
     return (Lock fd)
  where
    om = case se of
           Shared    -> ReadOnly
           Exclusive -> WriteOnly

lockFd :: MonadIO m => Fd -> SharedExclusive -> Block -> m Lock
lockFd fd se b = liftIO $
  do (Fd fd') <- dup fd
     throwErrnoIfMinus1Retry_ "flock" $ flock fd' (operation se b)
     return (Lock fd')

unlock :: MonadIO m => Lock -> m ()
unlock (Lock fd) = liftIO $
  do _ <- flock fd c_LOCK_UN
     closeFd (Fd fd)