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