#line 19 "src/connections.anansi"

#line 30 "src/introduction.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/>.

#line 20 "src/connections.anansi"

#line 52 "src/introduction.anansi"
{-# LANGUAGE OverloadedStrings #-}

#line 21 "src/connections.anansi"
{-# LANGUAGE DeriveDataTypeable #-}
module DBus.Connection (

#line 53 "src/connections.anansi"
	  Connection
	, connectionAddress
	, connectionUUID

#line 288 "src/connections.anansi"
	, ConnectionError (..)

#line 327 "src/connections.anansi"
	, connect
	, connectFirst

#line 340 "src/connections.anansi"
	, connectionClose

#line 370 "src/connections.anansi"
	, send

#line 394 "src/connections.anansi"
	, receive

#line 24 "src/connections.anansi"
	) where

#line 56 "src/introduction.anansi"
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as TL

#line 26 "src/connections.anansi"

#line 36 "src/connections.anansi"
import qualified Control.Concurrent as C
import qualified DBus.Address as A
import qualified DBus.Message as M
import qualified DBus.UUID as UUID

#line 75 "src/connections.anansi"
import qualified Data.ByteString.Lazy as L
import Data.Word (Word32)

#line 107 "src/connections.anansi"
import qualified Network as N
import qualified Data.Map as Map

#line 147 "src/connections.anansi"
import qualified Network.Socket as NS

#line 193 "src/connections.anansi"
import qualified Text.ParserCombinators.Parsec as P
import Control.Monad (unless)
import Data.Binary.Get (runGet, getWord16host)
import Data.Binary.Put (runPut, putWord16be)

#line 255 "src/connections.anansi"
import qualified System.IO as I

#line 272 "src/connections.anansi"
import qualified Control.Exception as E
import Data.Typeable (Typeable)

#line 297 "src/connections.anansi"
import qualified DBus.Authentication as Auth

#line 353 "src/connections.anansi"
import qualified DBus.Wire as W

#line 43 "src/connections.anansi"
data Connection = Connection
	{ connectionAddress    :: A.Address
	, connectionTransport  :: Transport
	, connectionSerialMVar :: C.MVar M.Serial
	, connectionReadMVar   :: C.MVar ()
	, connectionUUID       :: UUID.UUID
	}

#line 62 "src/connections.anansi"
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

#line 80 "src/connections.anansi"

#line 59 "src/api-docs.anansi"
-- | A 'Transport' is anything which can send and receive bytestrings,
-- typically via a socket.

#line 81 "src/connections.anansi"
data Transport = Transport
	{ transportSend :: L.ByteString -> IO ()
	, transportRecv :: Word32 -> IO L.ByteString
	, transportClose :: IO ()
	}

#line 92 "src/connections.anansi"
connectTransport :: A.Address -> IO Transport
connectTransport a = transport' (A.addressMethod a) a where
	transport' "unix" = unix
	transport' "tcp"  = tcp
	transport' _      = E.throwIO . UnknownMethod

#line 112 "src/connections.anansi"
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

#line 151 "src/connections.anansi"
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

#line 165 "src/connections.anansi"
	hostname = maybe "localhost" TL.unpack $ Map.lookup "host" params

#line 169 "src/connections.anansi"
	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

#line 178 "src/connections.anansi"
	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

#line 200 "src/connections.anansi"
	parseWord16 = do
		chars <- P.many1 P.digit
		P.eof
		let value = read chars :: Integer
		unless (value > 0 && value <= 65535) $
			-- Calling 'fail' is acceptable here, because Parsec 2
			-- offers no other error reporting mechanism, and
			-- implements 'fail'.
			fail "bad port"
		let word = fromIntegral value
		return $ runGet getWord16host (runPut (putWord16be word))

#line 214 "src/connections.anansi"
	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

#line 228 "src/connections.anansi"
	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

#line 238 "src/connections.anansi"
	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

#line 259 "src/connections.anansi"
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)

#line 277 "src/connections.anansi"
data ConnectionError
	= InvalidAddress Text
	| BadParameters A.Address Text
	| UnknownMethod A.Address
	| NoWorkingAddress [A.Address]
	deriving (Show, Typeable)

instance E.Exception ConnectionError

#line 301 "src/connections.anansi"

#line 64 "src/api-docs.anansi"
-- | Open a connection to some address, using a given authentication
-- mechanism. If the connection fails, a 'ConnectionError' will be thrown.

#line 302 "src/connections.anansi"
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

#line 317 "src/connections.anansi"

#line 69 "src/api-docs.anansi"
-- | Try to open a connection to various addresses, returning the first
-- connection which could be successfully opened.

#line 318 "src/connections.anansi"
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

#line 334 "src/connections.anansi"

#line 74 "src/api-docs.anansi"
-- | Close an open connection. Once closed, the 'Connection' is no longer
-- valid and must not be used.

#line 335 "src/connections.anansi"
connectionClose :: Connection -> IO ()
connectionClose = transportClose . connectionTransport

#line 357 "src/connections.anansi"

#line 79 "src/api-docs.anansi"
-- | Send a single message, with a generated 'M.Serial'. The second parameter
-- exists to prevent race conditions when registering a reply handler; it
-- receives the serial the message /will/ be sent with, before it's actually
-- sent.
--
-- Only one message may be sent at a time; if multiple threads attempt to
-- send messages in parallel, one will block until after the other has
-- finished.

#line 358 "src/connections.anansi"
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

#line 374 "src/connections.anansi"
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

#line 387 "src/connections.anansi"

#line 90 "src/api-docs.anansi"
-- | Receive the next message from the connection, blocking until one is
-- available.
--
-- Only one message may be received at a time; if multiple threads attempt
-- to receive messages in parallel, one will block until after the other has
-- finished.

#line 388 "src/connections.anansi"
receive :: Connection -> IO (Either W.UnmarshalError M.ReceivedMessage)
receive (Connection _ t _ lock _) = C.withMVar lock $ \_ ->
	W.unmarshalMessage $ transportRecv t