@@ -0,0 +1,78 @@
1+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
2+
3+-----------------------------------------------------------------------------
4+-- |
5+-- Module : Database.HDBC.PostgreSQL.Notification
6+-- Copyright : (c) 2011 Leon P Smith
7+-- License : BSD3
8+--
9+-- Maintainer : leon@melding-monads.com
10+-- Stability : experimental
11+--
12+-----------------------------------------------------------------------------
13+
14+module Database.PostgreSQL.Simple.Notification
15+ ( Notification(..)
16+ , getNotification
17+ ) where
18+
19+import Control.Concurrent ( threadWaitRead )
20+import Control.Concurrent.MVar ( takeMVar, putMVar )
21+import qualified Data.ByteString as B
22+import Database.PostgreSQL.Simple.Implementation
23+import qualified Database.PostgreSQL.LibPQ as PQ
24+import System.Posix.Types ( CPid )
25+
26+data Notification = Notification
27+ { notificationPid :: CPid
28+ , notificationChannel :: B.ByteString
29+ , notificationData :: B.ByteString
30+ }
31+
32+errfd = "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+
49+getNotification :: Connection -> IO Notification
50+getNotification conn = do
51+ c <- lockConn conn
52+ loop conn c
53+ 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+ loop conn c = do
61+ mmsg <- PQ.notifies c
62+ case mmsg of
63+ Nothing -> do
64+ mfd <- PQ.socket c
65+ unlockConn conn c
66+ case mfd of
67+ Nothing -> fail errfd
68+ Just fd -> do
69+ threadWaitRead fd
70+ c <- lockConn conn
71+ _ <- PQ.consumeInput c
72+ -- FIXME? error handling
73+ loop conn c
74+ Just PQ.Notify{..} -> do
75+ unlockConn conn c
76+ return Notification { notificationPid = notifyBePid
77+ , notificationChannel = notifyRelname
78+ , notificationData = notifyExtra }