diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,15 @@ +### 1.7.4 + +- Function *safeWaitToSetLock* was moved into a new internal module + *NgxExport.Internal.SafeFileLock*. +- Implemented run-time choice of the best available file-lock implementation + (i.e. standard POSIX *F_SETLKW* or *F_OFD_SETLKW* which is a better choice as + it does not involve deadlock detection and thus better matches our purposes). +- Catch *EDEADLK* inside *safeWaitToSetLock* to make file-locks with *F_SETLKW* + behave more nicely. +- Calculate positions of fields in *struct flock* correctly using *hsc2hs* + directives. + ### 1.7.3 - Further fixes for inactive shared services waiting on file-locks. diff --git a/NgxExport.hs b/NgxExport.hs --- a/NgxExport.hs +++ b/NgxExport.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell, ForeignFunctionInterface, InterruptibleFFI #-} +{-# LANGUAGE TemplateHaskell, ForeignFunctionInterface #-} {-# LANGUAGE ViewPatterns, PatternSynonyms, TupleSections #-} ----------------------------------------------------------------------------- @@ -62,6 +62,8 @@ ,Foreign.C.CUInt (..) ) where +import NgxExport.Internal.SafeFileLock + #if MIN_VERSION_template_haskell(2,12,0) import Language.Haskell.TH hiding (interruptible) #else @@ -79,14 +81,12 @@ import System.Posix.IO import System.Posix.Types import System.Posix.Signals hiding (Handler) -import System.Posix.Internals import Control.Monad import Control.Monad.Loops import Control.DeepSeq import qualified Control.Exception as E import Control.Exception hiding (Handler) import GHC.IO.Exception (ioe_errno) -import GHC.IO.Device (SeekMode (..)) import Control.Concurrent import Control.Concurrent.Async import qualified Data.ByteString as B @@ -706,10 +706,18 @@ where z s | B.null s = B.singleton 0 | otherwise = s +isIOError :: Errno -> IOError -> Bool +isIOError e = (Just ((\(Errno i) -> i) e) ==) . ioe_errno +{-# INLINE isIOError #-} + isEINTR :: IOError -> Bool -isEINTR = (Just ((\(Errno i) -> i) eINTR) ==) . ioe_errno +isEINTR = isIOError eINTR {-# INLINE isEINTR #-} +isEDEADLK :: IOError -> Bool +isEDEADLK = isIOError eDEADLK +{-# INLINE isEDEADLK #-} + sS :: SS -> CString -> CInt -> Ptr CString -> Ptr CInt -> IO CUInt sS f x (I n) p pl = @@ -821,46 +829,7 @@ asyncIOCommon (do exiting <- if fstRun && fdlk /= -1 - then snd <$> - iterateUntil fst - (interruptible - (safeWaitToSetLock fdlk - (WriteLock, AbsoluteSeek, 0, 0) >> - return (True, False) - ) - `catches` - [E.Handler $ \e -> - if isEINTR e - then return (False, False) - else do - -- wait some time to avoid fastly - -- repeated calls; threadDelay is - -- interruptible even in exception - -- handlers - exiting <- - (threadDelay 500000 >> - return False - ) - `catches` - [E.Handler $ return . - (== WorkerProcessIsExiting) - ,E.Handler - (const $ return False :: - SomeException -> IO Bool - ) - ] - if exiting - then return (True, True) - else throwIO $ - ServiceSomeInterrupt $ show e - ,E.Handler $ - return . (True, ) . (== WorkerProcessIsExiting) - ,E.Handler - (throwIO . ServiceSomeInterrupt . show :: - SomeException -> IO (Bool, Bool) - ) - ] - ) + then getBestLockImpl fdlk >>= acquireLock fdlk else return False if exiting then return (L.empty, True) @@ -869,6 +838,36 @@ x' <- B.unsafePackCStringLen (x, n) interruptible $ (, False) <$> f x' fstRun ) fd efd + where acquireLock lk cmd = snd <$> + iterateUntil fst + (interruptible (safeWaitToSetLock lk cmd >> return (True, False)) + `catches` + [E.Handler $ \e -> + if isEINTR e + then return (False, False) + else do + -- wait some time to avoid fastly repeated calls; + -- threadDelay is interruptible even in exception + -- handlers + exiting <- (threadDelay 500000 >> return False) + `catches` + [E.Handler $ return . (== WorkerProcessIsExiting) + ,E.Handler (const $ return False :: + SomeException -> IO Bool + ) + ] + if exiting + then return (True, True) + else if isEDEADLK e + then return (False, False) + else throwIO $ + ServiceSomeInterrupt $ show e + ,E.Handler $ return . (True, ) . (== WorkerProcessIsExiting) + ,E.Handler (throwIO . ServiceSomeInterrupt . show :: + SomeException -> IO (Bool, Bool) + ) + ] + ) asyncIOYYY :: IOYYY -> Ptr NgxStrType -> Ptr NgxStrType -> CInt -> CString -> CInt -> CInt -> CUInt -> Ptr (Ptr NgxStrType) -> Ptr CInt -> @@ -983,37 +982,6 @@ PtrLen t l <- B.unsafeUseAsCStringLen s return pokeCStringLen t l p pl return 0 - -{- SPLICE: safe version of waitToSetLock as defined in System.Posix.IO -} - -foreign import ccall interruptible "HsBase.h fcntl" - safe_c_fcntl_lock :: CInt -> CInt -> Ptr CFLock -> IO CInt - -mode2Int :: SeekMode -> CShort -mode2Int AbsoluteSeek = 0 -mode2Int RelativeSeek = 1 -mode2Int SeekFromEnd = 2 - -lockReq2Int :: LockRequest -> CShort -lockReq2Int ReadLock = 0 -lockReq2Int WriteLock = 1 -lockReq2Int Unlock = 2 - -allocaLock :: FileLock -> (Ptr CFLock -> IO a) -> IO a -allocaLock (lockreq, mode, start, len) io = - allocaBytes 32 $ \p -> do - (`pokeByteOff` 0) p (lockReq2Int lockreq) - (`pokeByteOff` 2) p (mode2Int mode) - (`pokeByteOff` 8) p start - (`pokeByteOff` 16) p len - io p - -safeWaitToSetLock :: Fd -> FileLock -> IO () -safeWaitToSetLock (Fd fd) lock = allocaLock lock $ - \p_flock -> throwErrnoIfMinus1_ "safeWaitToSetLock" $ - safe_c_fcntl_lock fd 7 p_flock - -{- SPLICE: END -} foreign export ccall ngxExportInstallSignalHandler :: IO () ngxExportInstallSignalHandler :: IO () diff --git a/NgxExport/Internal/SafeFileLock.hsc b/NgxExport/Internal/SafeFileLock.hsc new file mode 100644 --- /dev/null +++ b/NgxExport/Internal/SafeFileLock.hsc @@ -0,0 +1,85 @@ +{-# LANGUAGE ForeignFunctionInterface, InterruptibleFFI #-} + +module NgxExport.Internal.SafeFileLock (safeWaitToSetLock + ,getBestLockImpl + ) where + +import Foreign.C +import Foreign.Ptr +import Foreign.Storable +import Foreign.Marshal.Alloc +import System.Posix.IO +import System.Posix.Types +import System.Posix.Internals +import GHC.IO.Device + +#include + +#ifndef HAVE_FCNTL_H +#error HsFFI claims that required C header file fcntl.h is missing +#endif + +#include + +fcntlOfdSetlkw :: CInt +#ifdef F_OFD_SETLKW +fcntlOfdSetlkw = (#const F_OFD_SETLKW) +#else +fcntlOfdSetlkw = 38 +#endif + +fcntlOfdGetlk :: CInt +#ifdef F_OFD_SETLKW +fcntlOfdGetlk = (#const F_OFD_GETLK) +#else +fcntlOfdGetlk = 36 +#endif + +fcntlSetlkw :: CInt +fcntlSetlkw = (#const F_SETLKW) + +-- functions below were mostly adopted from System.Posix.IO.Common + +mode2Int :: SeekMode -> CInt +mode2Int AbsoluteSeek = (#const SEEK_SET) +mode2Int RelativeSeek = (#const SEEK_CUR) +mode2Int SeekFromEnd = (#const SEEK_END) + +lockReq2Int :: LockRequest -> CShort +lockReq2Int ReadLock = (#const F_RDLCK) +lockReq2Int WriteLock = (#const F_WRLCK) +lockReq2Int Unlock = (#const F_UNLCK) + +allocaLock :: FileLock -> (Ptr CFLock -> IO a) -> IO a +allocaLock (lockreq, mode, start, len) io = + allocaBytes (#const sizeof(struct flock)) $ \p -> do + (#poke struct flock, l_type) p (lockReq2Int lockreq :: CShort) + (#poke struct flock, l_whence) p (fromIntegral (mode2Int mode) :: CShort) + (#poke struct flock, l_start) p start + (#poke struct flock, l_len) p len + (#poke struct flock, l_pid) p (0 :: CPid) + io p + +writeLock :: FileLock +writeLock = (WriteLock, AbsoluteSeek, 0, 0) + +foreign import ccall interruptible "HsBase.h fcntl" + safe_c_fcntl_lock :: CInt -> CInt -> Ptr CFLock -> IO CInt + +-- interruptible version of waitToSetLock as defined in System.Posix.IO +safeWaitToSetLock :: Fd -> CInt -> IO () +safeWaitToSetLock (Fd fd) cmd = allocaLock writeLock $ \p_flock -> + throwErrnoIfMinus1_ "safeWaitToSetLock" $ safe_c_fcntl_lock fd cmd p_flock + +-- returns fcntlOfdSetlkw if OFD locks are available, or fcntlSetlkw otherwise +getBestLockImpl :: Fd -> IO CInt +getBestLockImpl (Fd fd) = allocaLock writeLock $ \p_flock -> do + res <- c_fcntl_lock fd fcntlOfdGetlk p_flock + if res == -1 + then do + errno <- getErrno + return $ if errno == eINVAL + then fcntlSetlkw + else fcntlOfdSetlkw + else return fcntlOfdSetlkw + diff --git a/ngx-export.cabal b/ngx-export.cabal --- a/ngx-export.cabal +++ b/ngx-export.cabal @@ -1,5 +1,5 @@ name: ngx-export -version: 1.7.3 +version: 1.7.4 synopsis: Helper module for Nginx haskell module description: Helper module for . @@ -27,7 +27,9 @@ , unix exposed-modules: NgxExport - other-modules: Paths_ngx_export + other-modules: NgxExport.Internal.SafeFileLock + Paths_ngx_export + default-extensions: CPP ghc-options: -Wall