dbus-core-0.8.3: src/connections.anansi

:# Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com>
:# 
:# This program is free software: you can redistribute it and/or modify
:# it under the terms of the GNU General Public License as published by
:# the Free Software Foundation, either version 3 of the License, or
:# any later version.
:# 
:# This program is distributed in the hope that it will be useful,
:# but WITHOUT ANY WARRANTY; without even the implied warranty of
:# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
:# GNU General Public License for more details.
:# 
:# You should have received a copy of the GNU General Public License
:# along with this program.  If not, see <http://www.gnu.org/licenses/>.

\section{Connections}

:f DBus/Connection.hs
|copyright|
|text extensions|
{-# LANGUAGE DeriveDataTypeable #-}
module DBus.Connection (
	|connection exports|
	) where
|text imports|
|connection imports|
:

A {\tt Connection} is an opaque handle to an open D-Bus channel, with
an internal state for maintaining the current message serial.

The second {\tt MVar} doesn't really store a value, it's just used to
prevent two separate threads from reading from the transport at once.

:d connection imports
import qualified Control.Concurrent as C
import qualified DBus.Address as A
import qualified DBus.Message as M
import qualified DBus.UUID as UUID
:

:f DBus/Connection.hs
data Connection = Connection
	{ connectionAddress    :: A.Address
	, connectionTransport  :: Transport
	, connectionSerialMVar :: C.MVar M.Serial
	, connectionReadMVar   :: C.MVar ()
	, connectionUUID       :: UUID.UUID
	}
:

:d connection exports
  Connection
, connectionAddress
, connectionUUID
:

While not particularly useful for other functions, being able to
{\tt show} a {\tt Connection} is useful when debugging.

:f DBus/Connection.hs
instance Show Connection where
	showsPrec d con = showParen (d > 10) strCon where
		addr = A.strAddress $ connectionAddress con
		strCon = s "<Connection " . shows addr . s ">"
		s = showString
:

\subsection{Transports}

A transport is anything which can send and receive bytestrings, typically
via a socket.

:d connection imports
import qualified Data.ByteString.Lazy as L
import Data.Word (Word32)
:

:f DBus/Connection.hs
|apidoc Transport|
data Transport = Transport
	{ transportSend :: L.ByteString -> IO ()
	, transportRecv :: Word32 -> IO L.ByteString
	, transportClose :: IO ()
	}
:

If a method has no known transport, attempting to connect using it will
just result in an exception.

:f DBus/Connection.hs
connectTransport :: A.Address -> IO Transport
connectTransport a = transport' (A.addressMethod a) a where
	transport' "unix" = unix
	transport' "tcp"  = tcp
	transport' _      = E.throwIO . UnknownMethod
:

\subsubsection{UNIX}

The {\sc unix} transport accepts two parameters: {\tt path}, which is a
simple filesystem path, and {\tt abstract}, which is a path in the
Linux-specific abstract domain. One, and only one, of these parameters must
be specified.

:d connection imports
import qualified Network as N
import qualified Data.Map as Map
:

:f DBus/Connection.hs
unix :: A.Address -> IO Transport
unix a = port >>= N.connectTo "localhost" >>= handleTransport where
	params = A.addressParameters a
	path = Map.lookup "path" params
	abstract = Map.lookup "abstract" params
	
	tooMany = "Only one of `path' or `abstract' may be specified for the\
	          \ `unix' transport."
	tooFew = "One of `path' or `abstract' must be specified for the\
	         \ `unix' transport."
	
	port = fmap N.UnixSocket path'
	path' = case (path, abstract) of
		(Just _, Just _) -> E.throwIO $ BadParameters a tooMany
		(Nothing, Nothing) -> E.throwIO $ BadParameters a tooFew
		(Just x, Nothing) -> return $ TL.unpack x
		(Nothing, Just x) -> return $ '\x00' : TL.unpack x
:

\subsubsection{TCP}

The {\sc tcp} transport has three parameters:

\begin{itemize}
\item {\tt host} -- optional, defaults to {\tt "localhost"}
\item {\tt port} -- unsigned 16-bit integer
\item {\tt family} -- optional, defaults to {\sc unspec}, choices are
      {\tt "ipv4"} or {\tt "ipv6"}
\end{itemize}

The high-level {\tt Network} module doesn't provide enough control over
socket construction for this transport, so {\tt Network.Socket} must be
imported.

:d connection imports
import qualified Network.Socket as NS
:

:f DBus/Connection.hs
tcp :: A.Address -> IO Transport
tcp a = openHandle >>= handleTransport where
	params = A.addressParameters a
	openHandle = do
		port <- getPort
		family <- getFamily
		addresses <- getAddresses family
		socket <- openSocket port addresses
		NS.socketToHandle socket I.ReadWriteMode
:

Parameter parsing...

:f DBus/Connection.hs
	hostname = maybe "localhost" TL.unpack $ Map.lookup "host" params
:

:f DBus/Connection.hs
	unknownFamily x = TL.concat ["Unknown socket family for TCP transport: ", x]
	getFamily = case Map.lookup "family" params of
		Just "ipv4" -> return NS.AF_INET
		Just "ipv6" -> return NS.AF_INET6
		Nothing     -> return NS.AF_UNSPEC
		Just x      -> E.throwIO $ BadParameters a $ unknownFamily x
:

:f DBus/Connection.hs
	missingPort = "TCP transport requires the ``port'' parameter."
	badPort x = TL.concat ["Invalid socket port for TCP transport: ", x]
	getPort = case Map.lookup "port" params of
		Nothing -> E.throwIO $ BadParameters a missingPort
		Just x -> case P.parse parseWord16 "" (TL.unpack x) of
			Right x' -> return $ NS.PortNum x'
			Left  _  -> E.throwIO $ BadParameters a $ badPort x
:

Parsing the port is a bit complicated; assuming every character is an ASCII
digit, the port is converted to an {\tt Integer} and confirmed valid.
{\tt PortNumber} is expected to be in big-endian byte order, so the parsed
value must be converted from host order using {\tt Data.Binary}.

:d connection imports
import qualified Text.Parsec as P
import Control.Monad (unless)
import Data.Binary.Get (runGet, getWord16host)
import Data.Binary.Put (runPut, putWord16be)
:

:f DBus/Connection.hs
	parseWord16 = do
		chars <- P.many1 P.digit
		P.eof
		let value = read chars :: Integer
		unless (value > 0 && value <= 65535) $
			P.parserFail "bad port" >> return ()
		let word = fromIntegral value
		return $ runGet getWord16host (runPut (putWord16be word))
:

:f DBus/Connection.hs
	getAddresses family = do
		let hints = NS.defaultHints
			{ NS.addrFlags = [NS.AI_ADDRCONFIG]
			, NS.addrFamily = family
			, NS.addrSocketType = NS.Stream
			}
		NS.getAddrInfo (Just hints) (Just hostname) Nothing
:

The {\tt SockAddr} values returned from {\tt getAddrInfo} don't have any
port set, so it must be manually changed to whatever was in the {\tt port}
option.

:f DBus/Connection.hs
	setPort port (NS.SockAddrInet  _ x)     = NS.SockAddrInet port x
	setPort port (NS.SockAddrInet6 _ x y z) = NS.SockAddrInet6 port x y z
	setPort _    addr                       = addr
:

{\tt getAddrInfo} returns multiple addresses; each one is tried in turn,
until a valid address is found. If none are found, or are usable, an
exception will be thrown.

:f DBus/Connection.hs
	openSocket _ [] = E.throwIO $ NoWorkingAddress [a]
	openSocket port (addr:addrs) = E.catch (openSocket' port addr) $
		\(E.SomeException _) -> openSocket port addrs
	openSocket' port addr = do
		sock <- NS.socket (NS.addrFamily addr)
		                  (NS.addrSocketType addr)
		                  (NS.addrProtocol addr)
		NS.connect sock . setPort port . NS.addrAddress $ addr
		return sock
:

\subsubsection{Generic handle-based transport}

Both UNIX and TCP are backed by standard handles, and can therefore use
a shared handle-based transport backend.

:d connection imports
import qualified System.IO as I
:

:f DBus/Connection.hs
handleTransport :: I.Handle -> IO Transport
handleTransport h = do
	I.hSetBuffering h I.NoBuffering
	I.hSetBinaryMode h True
	return $ Transport (L.hPut h) (L.hGet h . fromIntegral) (I.hClose h)
:

\subsection{Errors}

If connecting to D-Bus fails, a {\tt ConnectionError} will be thrown.
The constructor describes which exception occurred.

:d connection imports
import qualified Control.Exception as E
import Data.Typeable (Typeable)
:

:f DBus/Connection.hs
data ConnectionError
	= InvalidAddress Text
	| BadParameters A.Address Text
	| UnknownMethod A.Address
	| NoWorkingAddress [A.Address]
	deriving (Show, Typeable)

instance E.Exception ConnectionError
:

:d connection exports
, ConnectionError (..)
:

\subsection{Establishing a connection}

A connection can be opened to any valid address, though actually connecting
might fail due to external factors.

:d connection imports
import qualified DBus.Authentication as Auth
:

:f DBus/Connection.hs
|apidoc connect|
connect :: Auth.Mechanism -> A.Address -> IO Connection
connect mechanism a = do
	t <- connectTransport a
	let getByte = L.head `fmap` transportRecv t 1
	uuid <- Auth.authenticate mechanism (transportSend t) getByte
	readLock <- C.newMVar ()
	serialMVar <- C.newMVar M.firstSerial
	return $ Connection a t serialMVar readLock uuid
:

Since addresses usually come in a list, it's sensible to have a variant
of {\tt connect} which tries multiple addresses. The first successfully
opened {\tt Connection} is returned.

:f DBus/Connection.hs
|apidoc connectFirst|
connectFirst :: [(Auth.Mechanism, A.Address)] -> IO Connection
connectFirst orig = connectFirst' orig where
	allAddrs = [a | (_, a) <- orig]
	connectFirst'     [] = E.throwIO $ NoWorkingAddress allAddrs
	connectFirst' ((mech, a):as) = E.catch (connect mech a) $
		\(E.SomeException _) -> connectFirst' as
:

:d connection exports
, connect
, connectFirst
:

\subsection{Closing connections}

:f DBus/Connection.hs
|apidoc connectionClose|
connectionClose :: Connection -> IO ()
connectionClose = transportClose . connectionTransport
:

:d connection exports
, connectionClose
:

:i authentication.anansi

\subsection{Sending and receiving messages}

Sending a message will increment the connection's internal serial state.
The second parameter is present to allow registration of a callback before
the message has actually been sent, which avoids race conditions in
multi-threaded clients.

:d connection imports
import qualified DBus.Wire as W
:

:f DBus/Connection.hs
|apidoc send|
send :: M.Message a => Connection -> (M.Serial -> IO b) -> a
     -> IO (Either W.MarshalError b)
send (Connection _ t mvar _ _) io msg = withSerial mvar $ \serial ->
	case W.marshalMessage W.LittleEndian serial msg of
		Right bytes -> do
			x <- io serial
			transportSend t bytes
			return $ Right x
		Left  err   -> return $ Left err
:

:d connection exports
, send
:

:f DBus/Connection.hs
withSerial :: C.MVar M.Serial -> (M.Serial -> IO a) -> IO a
withSerial m io = E.block $ do
	s <- C.takeMVar m
	let s' = M.nextSerial s
	x <- E.unblock (io s) `E.onException` C.putMVar m s'
	C.putMVar m s'
	return x
:

Messages are received wrapped in a {\tt ReceivedMessage} value. If an
error is encountered while unmarshaling, an exception will be thrown.

:f DBus/Connection.hs
|apidoc receive|
receive :: Connection -> IO (Either W.UnmarshalError M.ReceivedMessage)
receive (Connection _ t _ lock _) = C.withMVar lock $ \_ ->
	W.unmarshalMessage $ transportRecv t
:

:d connection exports
, receive
: