Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

82 lines (73 sloc) 3.082 kB
{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
-----------------------------------------------------------------------------
-- |
-- Module : Database.PostgreSQL.Simple.Notification
-- Copyright : (c) 2011 Leon P Smith
-- License : BSD3
--
-- Maintainer : leon@melding-monads.com
-- Stability : experimental
--
-----------------------------------------------------------------------------
module Database.PostgreSQL.Simple.Notification
( Notification(..)
, getNotification
) where
import Control.Concurrent ( threadWaitRead )
import Control.Concurrent.MVar ( takeMVar, putMVar )
import qualified Data.ByteString as B
import Database.PostgreSQL.Simple.Internal
import qualified Database.PostgreSQL.LibPQ as PQ
import System.Posix.Types ( CPid )
data Notification = Notification
{ notificationPid :: CPid
, notificationChannel :: B.ByteString
, notificationData :: B.ByteString
}
errfd = "Database.PostgreSQL.Simple.Notification.getNotification: \
\failed to fetch file descriptor"
errconn = "Database.PostgreSQL.Simple.Notification.getNotification: \
\not connected"
lockConn :: Connection -> IO (PQ.Connection)
lockConn Connection{..} = do
mconn <- takeMVar connectionHandle
case mconn of
Nothing -> do
putMVar connectionHandle mconn
fail errconn
Just conn -> return conn
unlockConn :: Connection -> PQ.Connection -> IO ()
unlockConn Connection{..} c = putMVar connectionHandle (Just c)
getNotification :: Connection -> IO Notification
getNotification conn = do
c <- lockConn conn
loop conn c
where
-- now, I believe the only ways that this code throws an exception is:
-- 1. lockConn/unlockConn when we are blocked on a GC'd MVar
-- 2. threadWaitRead when closeFdWith gets called
-- 3. and if we raise it ourself
-- If 1 happens, then it doesn't matter if the MVar is locked or not,
-- and if 2 or 3 happens then the connection should be unlocked.
--
-- Note, however, that this function is not safe from asynchronous
-- exceptions, which probably ought to be fixed.
loop conn c = do
mmsg <- PQ.notifies c
case mmsg of
Nothing -> do
mfd <- PQ.socket c
unlockConn conn c
case mfd of
Nothing -> fail errfd
Just fd -> do
threadWaitRead fd
c <- lockConn conn
_ <- PQ.consumeInput c
-- FIXME? error handling
loop conn c
Just PQ.Notify{..} -> do
unlockConn conn c
return Notification { notificationPid = notifyBePid
, notificationChannel = notifyRelname
, notificationData = notifyExtra }
Jump to Line
Something went wrong with that request. Please try again.