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

import Control.Monad.IO.Class (MonadIO (..))
import Data.Bits ((.|.))

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

{-# LINE 13 "System/Lock/FLock.hsc" #-}
import System.Posix.Error (throwErrnoPathIfMinus1_)
import System.Posix.IO (openFd, defaultFileFlags, closeFd,
                        OpenMode(ReadOnly, WriteOnly))
import System.Posix.Types (Fd(Fd))
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Exception.Lifted (bracket)


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

c_LOCK_SH, c_LOCK_EX, c_LOCK_UN, c_LOCK_NB :: CInt
c_LOCK_SH = 1
{-# LINE 24 "System/Lock/FLock.hsc" #-}
c_LOCK_EX = 2
{-# LINE 25 "System/Lock/FLock.hsc" #-}
c_LOCK_UN = 8
{-# LINE 26 "System/Lock/FLock.hsc" #-}
c_LOCK_NB = 4
{-# LINE 27 "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)

lock :: MonadIO m => FilePath -> SharedExclusive -> Block -> m Lock
lock fp se b = liftIO
             $ do Fd fd <- openFd fp om Nothing defaultFileFlags
                  throwErrnoPathIfMinus1_ "flock" fp $ flock fd op'
                  return (Lock fd)
    where (om, op) = case se of
                         Shared -> (ReadOnly, c_LOCK_SH)
                         Exclusive -> (WriteOnly, c_LOCK_EX)
          op' = case b of
                    Block -> op
                    NoBlock -> op .|. c_LOCK_NB

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