ngx-export 1.7.3 → 1.7.4
raw patch · 4 files changed
+144/−77 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- Changelog.md +12/−0
- NgxExport.hs +43/−75
- NgxExport/Internal/SafeFileLock.hsc +85/−0
- ngx-export.cabal +4/−2
Changelog.md view
@@ -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.
NgxExport.hs view
@@ -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 ()
+ NgxExport/Internal/SafeFileLock.hsc view
@@ -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 <HsFFI.h>++#ifndef HAVE_FCNTL_H+#error HsFFI claims that required C header file fcntl.h is missing+#endif++#include <fcntl.h>++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+
ngx-export.cabal view
@@ -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 <http://github.com/lyokha/nginx-haskell-module Nginx haskell module>.@@ -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