Fix deadlock when exiting withFluentLogger block

fluent-logger.cabal

@@ -21,6 +21,7 @@ library
   hs-source-dirs:      src
   exposed-modules:     Network.Fluent.Logger
                      , Network.Fluent.Logger.Packable
+  other-modules:       Network.Fluent.Logger.ForkWrapper
   ghc-options:         -Wall
   build-depends:       base ==4.*
                      , bytestring

src/Network/Fluent/Logger.hs

@@ -37,7 +37,7 @@ import Network.Socket.Options ( setRecvTimeout, setSendTimeout )
 import Network.Socket.ByteString.Lazy ( sendAll, recv )
 import Control.Monad ( void, forever, when )
 import Control.Applicative ( (<$>) )
-import Control.Concurrent ( ThreadId, forkIO, killThread, threadDelay )
+import Control.Concurrent ( ThreadId, killThread, threadDelay )
 import Control.Concurrent.STM ( atomically, orElse
                               , TChan, newTChanIO, readTChan, peekTChan, writeTChan
                               , TVar, newTVarIO, readTVar, modifyTVar
@@ -50,6 +50,7 @@ import Data.Time.Clock.POSIX ( getPOSIXTime )
 import System.Random ( randomRIO )
 
 import Network.Fluent.Logger.Packable
+import Network.Fluent.Logger.ForkWrapper (forkIOUnmasked)
 
 -- | Wrap close / sClose (deprecated)
 close :: NS.Socket -> IO ()
@@ -139,7 +140,7 @@ runSender logger = forever $ filterException $ bracket (connectFluent logger) cl
   filterException action = catches action [Handler passAsyncException, Handler dropOtherExceptions]
   handleSocket sock = do
     flag <- newEmptyTMVarIO
-    bracket (forkIO $ setFlagWhenClose sock flag) killThread (const $ sendFluent logger sock flag)
+    bracket (forkIOUnmasked $ setFlagWhenClose sock flag) killThread (const $ sendFluent logger sock flag)
 
 connectFluent :: FluentLoggerSender -> IO NS.Socket
 connectFluent logger = exponentialBackoff $ getSocket host port timeout where
@@ -190,7 +191,7 @@ newFluentLogger set = do
                , fluentLoggerSenderBuffered = tvar
                , fluentLoggerSenderSettings = set
                }
-  tid <- forkIO $ runSender sender
+  tid <- forkIOUnmasked $ runSender sender
   let logger = FluentLogger
                { fluentLoggerSender = sender
                , fluentLoggerThread = tid

src/Network/Fluent/Logger/ForkWrapper.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE CPP #-}
+module Network.Fluent.Logger.ForkWrapper (forkIOUnmasked) where
+
+import qualified Control.Concurrent as CC
+#if MIN_VERSION_base(4,3,0)
+#else
+import qualified Control.Exception as CE
+#endif
+
+forkIOUnmasked :: IO () -> IO CC.ThreadId
+#if MIN_VERSION_base(4,4,0)
+forkIOUnmasked action = CC.forkIOWithUnmask (\unmask -> unmask action)
+#elif MIN_VERSION_base(4,3,0)
+forkIOUnmasked action = CC.forkIOUnmasked
+#else
+forkIOUnmasked action = if CE.blocked then CE.unblock $ CC.forkIO action else CC.forkIO action
+#endif
+

test/Network/Fluent/LoggerSpec.hs

@@ -24,6 +24,7 @@ spec = do
     it "posts a message with given time" postWithTimePostsMessageWithGivenTime
   describe "withFluentLogger" $ do
     it "disconnects when the scope is over" withFluentLoggerDisconnect
+    it "exits normally even if you don't wait for the message to be received" withFluentLoggerExit
 
 
 postSettings =
@@ -131,4 +132,12 @@ withFluentLoggerDisconnect =
       content `shouldBe` "foobar"
     threadDelay 5000
     server `shouldHaveConns` 0
-
+
+withFluentLoggerExit :: IO ()
+withFluentLoggerExit =
+  (withMockServer :: (MockServer Object -> IO ()) -> IO ()) $ \server -> do
+    withFluentLogger postSettings $ \logger -> do
+      post logger "hoge" ("foobar" :: String)
+      -- immediately exit the block without waiting for the message
+    threadDelay 5000
+    server `shouldHaveConns` 0