Lock.hsc

{-# OPTIONS_GHC -fglasgow-exts #-}

-- | "System.IO.Lock" provides thread-friendly file locks. The locking functions in
-- "System.Posix.IO" (actually, it's just 'System.Posix.IO.waitToSetLock') will
-- block the entire program, not just the calling thread (even with the
-- threaded runtime). This module avoids the problem by spawning a new process
-- for each lock and communicating with it over pipes.
--
-- Advantages:
--
-- * Only blocks the calling thread
--
-- * Works both with and without @-threaded@
--
-- Disadvantages:
--
-- * Forks one new process per lock
--
-- * Consumes one file descriptor per lock
--
-- Oddities:
--
-- * Closing the file descriptor doesn't affect the lock (because it's really in
--   a separate process); you must call 'unLock' instead.

module System.IO.Lock (
    LockMode(..),
    LockDescriptor,
    setLock,
    setLockAll,
    unLock
) where

import Control.Concurrent
import Control.Monad

import Data.Typeable

import Foreign.C.Error
import Foreign.C.Types
import Foreign

import System.IO
import System.Posix.IO hiding (getLock, setLock, waitToSetLock, LockRequest(..))
import System.Posix.Types

#include <unistd.h>

data LockMode = LockRead | LockWrite
    deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable)

newtype LockDescriptor = LD CInt
    deriving (Show, Typeable)


foreign import ccall "System_IO_Lock.h System_IO_Lock_get_lock_async"
    c_lock :: Ptr CInt -> Ptr CInt -> CInt -> CInt -> CShort -> COff -> COff -> IO CInt

foreign import ccall "unistd.h read"
    c_read :: CInt -> Ptr a -> CSize -> IO CSsize

-- | 'setLock' locks the specified region of the file. It blocks the calling thread
-- until the lock is granted.
setLock :: Fd -> (LockMode, SeekMode, FileOffset, FileOffset) -> IO LockDescriptor
setLock (Fd fd) (lockmode, seekmode, off, len) =
    alloca $ \p_in ->
    alloca $ \p_out ->
    alloca $ \p_e ->
    do
        throwErrnoIfMinus1_ __func__ $ c_lock p_in p_out fd lm sm off len
        fd_in <- peek p_in
        fd_out <- peek p_out
        threadWaitRead (Fd fd_in)
        throwErrnoIfMinus1Retry_ __func__ $ c_read fd_in p_e (fromIntegral . sizeOf . derefT $ p_e)
        e <- peek p_e
        closeFd (Fd fd_in)
        when (e /= (0 :: CInt)) $ do
            closeFd (Fd fd_out)
            ioError $ errnoToIOError __func__ (Errno e) Nothing Nothing
        return $ LD fd_out
    where
    __func__ = "System.IO.Lock.setLock"
    lm = case lockmode of
        LockRead  -> 0
        LockWrite -> 1
    sm = case seekmode of
        AbsoluteSeek -> #const SEEK_SET
        RelativeSeek -> #const SEEK_CUR
        SeekFromEnd  -> #const SEEK_END
    derefT :: Ptr a -> a
    derefT _ = undefined

-- | @'setLockAll' fd lm@ is equivalent to @'setLock' fd
-- (lm, 'System.IO.AbsoluteSeek', 0, 0)@. It locks the entire file, no matter
-- how big it is.
setLockAll :: Fd -> LockMode -> IO LockDescriptor
setLockAll fd lm = setLock fd (lm, AbsoluteSeek, 0, 0)

-- | 'unLock' destroys the given lock.
unLock :: LockDescriptor -> IO ()
unLock (LD fd) = do
    closeFd (Fd fd)