{-# LINE 1 "src-flock/Lukko/FLock.hsc" #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE InterruptibleFFI #-}
{-# LANGUAGE Trustworthy #-}
-- | File locking via BSD-style @flock(2)@.
module Lukko.FLock (
    -- * 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.Bits
import Data.Function
import Foreign.C.Error
import Foreign.C.Types
import GHC.Base
import GHC.IO.Exception

import Lukko.Internal.FD
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
MethodFLock

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

-- | Lock using BSD-style 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 BSD-style 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 BSD-style locks.
fdUnlock :: FD -> IO ()
fdUnlock :: FD -> IO ()
fdUnlock = FD -> IO ()
unlockImpl

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

-- | Lock using BSD-style 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 BSD-style 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 BSD-style 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 stuff
-------------------------------------------------------------------------------

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

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
  let flags :: CInt
flags = CInt
cmode CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|. (if Bool
block then CInt
0 else CInt
4)
{-# LINE 106 "src-flock/Lukko/FLock.hsc" #-}
  fix $ \retry -> c_flock fd flags >>= \res -> case res of
    0 -> return True
    _ -> getErrno >>= \errno -> case () of
      _ | not block
        , errno == eAGAIN || errno == eACCES -> return False
        | errno == eINTR -> retry
        | otherwise -> ioException $ errnoToIOError ctx errno mh Nothing
  where
    cmode :: CInt
cmode = case LockMode
mode of
      LockMode
SharedLock    -> CInt
1
{-# LINE 116 "src-flock/Lukko/FLock.hsc" #-}
      ExclusiveLock -> 2
{-# LINE 117 "src-flock/Lukko/FLock.hsc" #-}

unlockImpl :: FD -> IO ()
unlockImpl :: FD -> IO ()
unlockImpl (FD CInt
fd) = do
  String -> IO CInt -> IO ()
forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1_ String
"flock" (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ CInt -> CInt -> IO CInt
c_flock CInt
fd CInt
8
{-# LINE 121 "src-flock/Lukko/FLock.hsc" #-}

foreign import ccall interruptible "flock"
  c_flock :: CInt -> CInt -> IO CInt