c458251 · typeable/postgresql-simple

17 ) where

18

19import Control.Concurrent ( threadWaitRead )

20−import Control.Concurrent.MVar ( takeMVar, putMVar )

20+import Control.Monad ( when )

21import qualified Data.ByteString as B

22import Database.PostgreSQL.Simple.Internal

23import qualified Database.PostgreSQL.LibPQ as PQ

31

32errfd = "Database.PostgreSQL.Simple.Notification.getNotification: \

33 \failed to fetch file descriptor"

34−errconn = "Database.PostgreSQL.Simple.Notification.getNotification: \

35− \not connected"

36−

37−lockConn :: Connection -> IO (PQ.Connection)

38−lockConn Connection{..} = do

39− mconn <- takeMVar connectionHandle

40− case mconn of

41− Nothing -> do

42− putMVar connectionHandle mconn

43− fail errconn

44− Just conn -> return conn

45−

46−unlockConn :: Connection -> PQ.Connection -> IO ()

47−unlockConn Connection{..} c = putMVar connectionHandle (Just c)

48

34

49getNotification :: Connection -> IO Notification

35getNotification :: Connection -> IO Notification

50−getNotification conn = do

36+getNotification = loop False

51− c <- lockConn conn

52− loop conn c

53 where

37 where

54− -- now, I believe the only ways that this code throws an exception is:

55− -- 1. lockConn/unlockConn when we are blocked on a GC'd MVar

56− -- 2. threadWaitRead when closeFdWith gets called

57− -- 3. and if we raise it ourself

58− -- If 1 happens, then it doesn't matter if the MVar is locked or not,

59− -- and if 2 or 3 happens then the connection should be unlocked.

60− --

61− -- Note, however, that this function is not safe from asynchronous

62− -- exceptions, which probably ought to be fixed.

63− loop conn c = do

38+ loop doConsume conn = do

39+ res <- withConnection conn $ \c -> do

40+ when doConsume (PQ.consumeInput c >> return ())

64− mmsg <- PQ.notifies c

41+ mmsg <- PQ.notifies c

65− case mmsg of

42+ case mmsg of

66− Nothing -> do

43+ Nothing -> do

67− mfd <- PQ.socket c

44+ mfd <- PQ.socket c

68− unlockConn conn c

69− case mfd of

45+ case mfd of

70− Nothing -> fail errfd

46+ Nothing -> fail errfd

71− Just fd -> do

47+ Just fd -> return (Left fd)

72− threadWaitRead fd

48+ Just x -> return (Right x)

73− c <- lockConn conn

49+ case res of

74− _ <- PQ.consumeInput c

50+ Left fd -> threadWaitRead fd >> loop True conn

75− -- FIXME? error handling

76− loop conn c

77− Just PQ.Notify{..} -> do

51+ Right PQ.Notify{..} -> do

78− unlockConn conn c

79 return Notification { notificationPid = notifyBePid

52 return Notification { notificationPid = notifyBePid

80 , notificationChannel = notifyRelname

53 , notificationChannel = notifyRelname

81 , notificationData = notifyExtra }

54 , notificationData = notifyExtra }