{-# LINE 1 "System/FileLock/Internal/Flock.hsc" #-}
{-# LANGUAGE InterruptibleFFI #-}

module System.FileLock.Internal.Flock

{-# LINE 7 "System/FileLock/Internal/Flock.hsc" #-}
  (Lock, lock, tryLock, unlock) where



import Control.Applicative
import Control.Concurrent (yield)
import qualified Control.Exception as E
import Data.Bits
import Foreign.C.Error
import Foreign.C.Types
import System.Posix.Files
import System.Posix.IO
  ( openFd, closeFd, defaultFileFlags, OpenMode(..)

{-# LINE 23 "System/FileLock/Internal/Flock.hsc" #-}
  , setFdOption, FdOption(..)

{-# LINE 25 "System/FileLock/Internal/Flock.hsc" #-}
  )
import System.Posix.Types
import Prelude

type Lock = Fd

lock :: FilePath -> Bool -> IO Lock
lock :: FilePath -> Bool -> IO Lock
lock FilePath
path Bool
exclusive = do
  Lock
fd <- FilePath -> IO Lock
open FilePath
path
  (IO Lock -> IO () -> IO Lock
forall a b. IO a -> IO b -> IO a
`E.onException` Lock -> IO ()
closeFd Lock
fd) (IO Lock -> IO Lock) -> IO Lock -> IO Lock
forall a b. (a -> b) -> a -> b
$ do
    Bool
True <- Lock -> Bool -> Bool -> IO Bool
flock Lock
fd Bool
exclusive Bool
True
    Lock -> IO Lock
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Lock
fd

tryLock :: FilePath -> Bool -> IO (Maybe Lock)
tryLock :: FilePath -> Bool -> IO (Maybe Lock)
tryLock FilePath
path Bool
exclusive = do
  Lock
fd <- FilePath -> IO Lock
open FilePath
path
  (IO (Maybe Lock) -> IO () -> IO (Maybe Lock)
forall a b. IO a -> IO b -> IO a
`E.onException` Lock -> IO ()
closeFd Lock
fd) (IO (Maybe Lock) -> IO (Maybe Lock))
-> IO (Maybe Lock) -> IO (Maybe Lock)
forall a b. (a -> b) -> a -> b
$ do
    Bool
success <- Lock -> Bool -> Bool -> IO Bool
flock Lock
fd Bool
exclusive Bool
False
    if Bool
success
      then Maybe Lock -> IO (Maybe Lock)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Lock -> IO (Maybe Lock)) -> Maybe Lock -> IO (Maybe Lock)
forall a b. (a -> b) -> a -> b
$ Lock -> Maybe Lock
forall a. a -> Maybe a
Just (Lock -> Maybe Lock) -> Lock -> Maybe Lock
forall a b. (a -> b) -> a -> b
$ Lock
fd
      else Maybe Lock
forall a. Maybe a
Nothing Maybe Lock -> IO () -> IO (Maybe Lock)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Lock -> IO ()
closeFd Lock
fd

unlock :: Lock -> IO ()
unlock :: Lock -> IO ()
unlock Lock
fd = Lock -> IO ()
closeFd Lock
fd

open :: FilePath -> IO Fd
open :: FilePath -> IO Lock
open FilePath
path = do

{-# LINE 56 "System/FileLock/Internal/Flock.hsc" #-}
  Lock
fd <- FilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Lock
openFd FilePath
path OpenMode
WriteOnly (FileMode -> Maybe FileMode
forall a. a -> Maybe a
Just FileMode
stdFileMode) OpenFileFlags
defaultFileFlags
  Lock -> FdOption -> Bool -> IO ()
setFdOption Lock
fd FdOption
CloseOnExec Bool
True
    -- Ideally, we would open the file descriptor with CLOEXEC enabled, but this
    -- is not available in unix < 2.9.
    -- So we set CLOEXEC after opening the file descriptor.  This
    -- may seem like a race condition at first. However, since the lock is always
    -- taken after CLOEXEC is set, the worst that can happen is that a child
    -- process inherits the open FD in an unlocked state. While non-ideal from a
    -- performance standpoint, it doesn't introduce any locking bugs.

{-# LINE 66 "System/FileLock/Internal/Flock.hsc" #-}
  return fd

flock :: Fd -> Bool -> Bool -> IO Bool
flock :: Lock -> Bool -> Bool -> IO Bool
flock (Fd CInt
fd) Bool
exclusive Bool
block = do
  CInt
r <- CInt -> CInt -> IO CInt
c_flock CInt
fd (CInt -> IO CInt) -> CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$ CInt
modeOp CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|. CInt
blockOp
  if CInt
r CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0
    then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True -- success
    else do
      Errno
errno <- IO Errno
getErrno
      case () of
        ()
_ | Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eWOULDBLOCK
            -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False -- already taken
          | Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eINTR -> do
              -- If InterruptibleFFI interrupted the syscall with EINTR,
              -- we need to give the accompanying Haskell exception a chance to bubble.
              -- See also https://gitlab.haskell.org/ghc/ghc/issues/8684#note_142404.
              IO () -> IO ()
forall a. IO a -> IO a
E.interruptible IO ()
yield
              Lock -> Bool -> Bool -> IO Bool
flock (CInt -> Lock
Fd CInt
fd) Bool
exclusive Bool
block
          | Bool
otherwise -> FilePath -> IO Bool
forall a. FilePath -> IO a
throwErrno FilePath
"flock"
  where
    modeOp :: CInt
modeOp = case Bool
exclusive of
      Bool
False -> CInt
1
{-# LINE 88 "System/FileLock/Internal/Flock.hsc" #-}
      True -> 2
{-# LINE 89 "System/FileLock/Internal/Flock.hsc" #-}
    blockOp = case block of
      True -> 0
      False -> 4
{-# LINE 92 "System/FileLock/Internal/Flock.hsc" #-}

-- `interruptible` so that async exceptions like `timeout` can stop it
-- when used in blocking mode (without `LOCK_NB`).
foreign import ccall interruptible "flock"
  c_flock :: CInt -> CInt -> IO CInt


{-# LINE 99 "System/FileLock/Internal/Flock.hsc" #-}