Remove IOStream from Internal.Protocol

This commit is contained in:
Victor Denisov 2016-04-10 17:55:58 -07:00
parent c011b1a23c
commit 73dfdb0b7f
2 changed files with 17 additions and 34 deletions

View file

@ -4,20 +4,13 @@
module Database.MongoDB.Internal.Connection (
Connection(..),
readExactly,
fromHandle,
) where
import Prelude hiding (read)
import Data.Monoid
import Data.IORef
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Lazy as Lazy (ByteString)
import qualified Data.ByteString.Lazy as Lazy.ByteString
import Control.Monad
import System.IO
import System.IO.Error (mkIOError, eofErrorType)
-- | Abstract connection interface
--

View file

@ -83,25 +83,17 @@ mkWeakMVar :: MVar a -> IO () -> IO ()
mkWeakMVar = addMVarFinalizer
#endif
-- * IOStream
-- | An IO sink and source where value of type @o@ are sent and values of type @i@ are received.
data IOStream i o = IOStream {
writeStream :: o -> IO (),
readStream :: IO i,
closeStream :: IO () }
-- * Pipeline
-- | Thread-safe and pipelined connection
data Pipeline i o = Pipeline {
vStream :: MVar (IOStream i o), -- ^ Mutex on handle, so only one thread at a time can write to it
responseQueue :: Chan (MVar (Either IOError i)), -- ^ Queue of threads waiting for responses. Every time a response arrive we pop the next thread and give it the response.
data Pipeline = Pipeline {
vStream :: MVar Connection, -- ^ Mutex on handle, so only one thread at a time can write to it
responseQueue :: Chan (MVar (Either IOError Response)), -- ^ Queue of threads waiting for responses. Every time a response arrive we pop the next thread and give it the response.
listenThread :: ThreadId
}
-- | Create new Pipeline over given handle. You should 'close' pipeline when finished, which will also close handle. If pipeline is not closed but eventually garbage collected, it will be closed along with handle.
newPipeline :: IOStream i o -> IO (Pipeline i o)
newPipeline :: Connection -> IO Pipeline
newPipeline stream = do
vStream <- newMVar stream
responseQueue <- newChan
@ -110,16 +102,16 @@ newPipeline stream = do
listenThread <- forkIO (listen pipe)
_ <- mkWeakMVar vStream $ do
killThread listenThread
closeStream stream
Connection.close stream
return pipe
close :: Pipeline i o -> IO ()
close :: Pipeline -> IO ()
-- ^ Close pipe and underlying connection
close Pipeline{..} = do
killThread listenThread
closeStream =<< readMVar vStream
Connection.close =<< readMVar vStream
isClosed :: Pipeline i o -> IO Bool
isClosed :: Pipeline -> IO Bool
isClosed Pipeline{listenThread} = do
status <- threadStatus listenThread
return $ case status of
@ -129,36 +121,36 @@ isClosed Pipeline{listenThread} = do
ThreadDied -> True
--isPipeClosed Pipeline{..} = isClosed =<< readMVar vHandle -- isClosed hangs while listen loop is waiting on read
listen :: Pipeline i o -> IO ()
listen :: Pipeline -> IO ()
-- ^ Listen for responses and supply them to waiting threads in order
listen Pipeline{..} = do
stream <- readMVar vStream
forever $ do
e <- try $ readStream stream
e <- try $ readMessage stream
var <- readChan responseQueue
putMVar var e
case e of
Left err -> closeStream stream >> ioError err -- close and stop looping
Left err -> Connection.close stream >> ioError err -- close and stop looping
Right _ -> return ()
psend :: Pipeline i o -> o -> IO ()
psend :: Pipeline -> Message -> IO ()
-- ^ Send message to destination; the destination must not response (otherwise future 'call's will get these responses instead of their own).
-- Throw IOError and close pipeline if send fails
psend p@Pipeline{..} message = withMVar vStream (flip writeStream message) `onException` close p
psend p@Pipeline{..} message = withMVar vStream (flip writeMessage message) `onException` close p
pcall :: Pipeline i o -> o -> IO (IO i)
pcall :: Pipeline -> Message -> IO (IO Response)
-- ^ Send message to destination and return /promise/ of response from one message only. The destination must reply to the message (otherwise promises will have the wrong responses in them).
-- Throw IOError and closes pipeline if send fails, likewise for promised response.
pcall p@Pipeline{..} message = withMVar vStream doCall `onException` close p where
doCall stream = do
writeStream stream message
writeMessage stream message
var <- newEmptyMVar
liftIO $ writeChan responseQueue var
return $ readMVar var >>= either throwIO return -- return promise
-- * Pipe
type Pipe = Pipeline Response Message
type Pipe = Pipeline
-- ^ Thread-safe TCP connection with pipelined requests
newPipe :: Handle -> IO Pipe
@ -167,9 +159,7 @@ newPipe handle = Connection.fromHandle handle >>= newPipeWith
newPipeWith :: Connection -> IO Pipe
-- ^ Create pipe over connection
newPipeWith conn = newPipeline $ IOStream (writeMessage conn)
(readMessage conn)
(Connection.close conn)
newPipeWith conn = newPipeline conn
send :: Pipe -> [Notice] -> IO ()
-- ^ Send notices as a contiguous batch to server with no reply. Throw IOError if connection fails.