1{-# LANGUAGE CPP #-} 2{-# LANGUAGE DataKinds #-} 3{-# LANGUAGE InterruptibleFFI #-} 4{-# LANGUAGE Trustworthy #-} 5-- | File locking via BSD-style @flock(2)@. 6module Lukko.FLock ( 7 -- * Types 8 FileLockingNotSupported(..), 9 fileLockingSupported, 10 FileLockingSupported, 11 FileLockingMethod (..), 12 fileLockingMethod, 13 LockMode(..), 14 -- * File descriptors 15 FD, 16 fdOpen, 17 fdClose, 18 fdLock, 19 fdTryLock, 20 fdUnlock, 21 -- * Handles 22 hLock, 23 hTryLock, 24 hUnlock, 25 ) where 26 27#include <sys/file.h> 28 29import Control.Monad (void) 30import System.IO (Handle) 31 32import Data.Bits 33import Data.Function 34import Foreign.C.Error 35import Foreign.C.Types 36import GHC.Base 37import GHC.IO.Exception 38 39import Lukko.Internal.FD 40import Lukko.Internal.Types 41 42------------------------------------------------------------------------------- 43-- Support constants 44------------------------------------------------------------------------------- 45 46-- | A constants specifying whether file locking is supported. 47fileLockingSupported :: Bool 48fileLockingSupported = True 49 50-- | A type level 'fileLockingSupported'. 51type FileLockingSupported = True 52 53-- | A constant specifying this method 54fileLockingMethod :: FileLockingMethod 55fileLockingMethod = MethodFLock 56 57------------------------------------------------------------------------------- 58-- FD 59------------------------------------------------------------------------------- 60 61-- | Lock using BSD-style locks. 62fdLock :: FD -> LockMode -> IO () 63fdLock fd mode = void (lockImpl Nothing fd "fdLock" mode True) 64 65-- | Try to lock using BSD-style locks. 66fdTryLock :: FD -> LockMode -> IO Bool 67fdTryLock fd mode = lockImpl Nothing fd "fdTryLock" mode False 68 69-- | Unlock using BSD-style locks. 70fdUnlock :: FD -> IO () 71fdUnlock = unlockImpl 72 73------------------------------------------------------------------------------- 74-- Handle 75------------------------------------------------------------------------------- 76 77-- | Lock using BSD-style locks. 78hLock :: Handle -> LockMode -> IO () 79hLock h mode = do 80 fd <- handleToFd h 81 void (lockImpl (Just h) fd "hLock" mode True) 82 83-- | Try to lock using BSD-style locks. 84hTryLock :: Handle -> LockMode -> IO Bool 85hTryLock h mode = do 86 fd <- handleToFd h 87 lockImpl (Just h) fd "hTryLock" mode False 88 89-- | Unlock using BSD-style locks. 90hUnlock :: Handle -> IO () 91hUnlock h = do 92 fd <- handleToFd h 93 unlockImpl fd 94 95------------------------------------------------------------------------------- 96-- Compat stuff 97------------------------------------------------------------------------------- 98 99------------------------------------------------------------------------------- 100-- implementation 101------------------------------------------------------------------------------- 102 103lockImpl :: Maybe Handle -> FD -> String -> LockMode -> Bool -> IO Bool 104lockImpl mh (FD fd) ctx mode block = do 105 let flags = cmode .|. (if block then 0 else #{const LOCK_NB}) 106 fix $ \retry -> c_flock fd flags >>= \res -> case res of 107 0 -> return True 108 _ -> getErrno >>= \errno -> case () of 109 _ | not block 110 , errno == eAGAIN || errno == eACCES -> return False 111 | errno == eINTR -> retry 112 | otherwise -> ioException $ errnoToIOError ctx errno mh Nothing 113 where 114 cmode = case mode of 115 SharedLock -> #{const LOCK_SH} 116 ExclusiveLock -> #{const LOCK_EX} 117 118unlockImpl :: FD -> IO () 119unlockImpl (FD fd) = do 120 throwErrnoIfMinus1_ "flock" $ c_flock fd #{const LOCK_UN} 121 122foreign import ccall interruptible "flock" 123 c_flock :: CInt -> CInt -> IO CInt 124