module Network.DBus.Actions
( DBusContext
, DBusTransport(..)
, authenticate
, authenticateUID
, connectSession
, connectSystem
, contextNew
, contextNewWith
, busGetSession
, busGetSystem
, busGetNextSerial
, busClose
, messageSend
, messageSendWithSerial
, messageRecv
, MessageType(..)
, MessageFlag(..)
, DBusFields(..)
, DBusMessage(..)
, Serial
, readBody
, readBodyWith
, Type(..)
, SignatureElem
, Signature
, serializeSignature
, unserializeSignature
, ObjectPath(..)
, PackedString(..)
, packedStringToString
, DBusValue(..)
, DBusTypeable(..)
) where
import Numeric (showHex)
import Data.Char (ord)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BC
import Control.Arrow
import Control.Applicative ((<$>))
import Control.Concurrent
import Control.Monad.State
import System.Environment
import System.IO hiding (hGetLine)
import Network.Socket
import Network.DBus.Message
import Network.DBus.Type
import Network.DBus.Internal
import Network.DBus.Signature
data DBusTransport = DBusTransport
{ transportGet :: Int -> IO ByteString
, transportPut :: ByteString -> IO ()
, transportClose :: IO ()
}
data DBusContext = DBusContext
{ contextTransport :: DBusTransport
, contextSerial :: MVar Serial
}
withTransport :: DBusContext -> (DBusTransport -> IO a) -> IO a
withTransport ctx f = f $ contextTransport ctx
transportHandle :: Handle -> DBusTransport
transportHandle h = DBusTransport
{ transportGet = BC.hGet h
, transportPut = BC.hPut h
, transportClose = hClose h
}
hGet :: DBusContext -> Int -> IO ByteString
hGet ctx i = withTransport ctx (\t -> transportGet t i)
hPut :: DBusContext -> ByteString -> IO ()
hPut ctx b = withTransport ctx (\t -> transportPut t b)
hPuts :: DBusContext -> [ByteString] -> IO ()
hPuts ctx bs = withTransport ctx (\t -> mapM_ (transportPut t) bs)
hGetLine :: DBusContext -> IO ()
hGetLine ctx = withTransport ctx getTillEOL
where getTillEOL transport = do
v <- transportGet transport 1
if BC.singleton '\n' == v then return () else getTillEOL transport
authenticateUID :: DBusContext -> Int -> IO ()
authenticateUID ctx uid = authenticate ctx hexencoded_uid
where hexencoded_uid = BC.pack $ concatMap (hex2 . ord) $ show uid
hex2 a
| a < 0x10 = '0' : showHex a ""
| otherwise = showHex a ""
authenticate :: DBusContext -> ByteString -> IO ()
authenticate ctx auth = do
hPut ctx $ BC.concat ["\0AUTH EXTERNAL ", auth, "\r\n"]
_ <- hGetLine ctx
hPut ctx "BEGIN\r\n"
close :: DBusTransport -> IO ()
close = transportClose
connectUnix :: ByteString -> IO Handle
connectUnix addr = do
let sockaddr = SockAddrUnix $ BC.unpack addr
sock <- socket AF_UNIX Stream 0
connect sock sockaddr
h <- socketToHandle sock ReadWriteMode
hSetBuffering h NoBuffering
return h
connectOver :: ByteString -> [(ByteString, ByteString)] -> IO Handle
connectOver "unix" flags = do
let abstract = lookup "abstract" flags
case abstract of
Nothing -> error "no abstract path, use the normal path ..."
Just path -> connectUnix $ BC.concat ["\x00", path]
connectOver _ _ = error "not implemented yet"
connectSessionAt :: ByteString -> IO Handle
connectSessionAt addr = do
let (domain, flagstr) = second BC.tail $ BC.breakSubstring ":" addr
let flags = map (\x -> let (k:v:[]) = BC.split '=' x in (k,v)) $ BC.split ',' flagstr
connectOver domain flags
connectSession :: IO Handle
connectSession = BC.pack <$> getEnv "DBUS_SESSION_BUS_ADDRESS" >>= connectSessionAt
connectSystem :: IO Handle
connectSystem = connectUnix "/var/run/dbus/system_bus_socket"
contextNew :: Handle -> IO DBusContext
contextNew h = contextNewWith (transportHandle h)
contextNewWith :: DBusTransport -> IO DBusContext
contextNewWith transport = liftM (DBusContext transport) (newMVar 1)
busGetSession :: IO DBusContext
busGetSession = connectSession >>= contextNew
busGetSystem :: IO DBusContext
busGetSystem = connectSystem >>= contextNew
busClose :: DBusContext -> IO ()
busClose = transportClose . contextTransport
busGetNextSerial :: DBusContext -> IO Serial
busGetNextSerial ctx =
modifyMVar (contextSerial ctx) (\v -> return $! (v+1, v))
messageSendWithSerial :: DBusContext -> Serial -> DBusMessage -> IO ()
messageSendWithSerial ctx serial msg = do
let fieldstr = writeFields (msgFields msg)
let fieldlen = BC.length fieldstr
let alignfields = alignVal 8 fieldlen fieldlen
let header = (headerFromMessage msg)
{ headerBodyLength = BC.length $ msgBodyRaw msg
, headerFieldsLength = fieldlen
, headerSerial = serial }
hPuts ctx [ writeHeader header, fieldstr, BC.replicate alignfields '\0', msgBodyRaw msg ]
messageSend :: DBusContext -> DBusMessage -> IO Serial
messageSend ctx msg = do
serial <- busGetNextSerial ctx
messageSendWithSerial ctx serial msg
return serial
messageRecv :: DBusContext -> IO DBusMessage
messageRecv ctx = do
hdr <- readHeader <$> hGet ctx 16
fields <- readFields (headerEndian hdr) <$> hGet ctx (alignVal 8 $ headerFieldsLength hdr)
body <- hGet ctx (headerBodyLength hdr)
return $ (messageFromHeader hdr) { msgFields = fields, msgBodyRaw = body }
alignVal :: Int -> Int -> Int
alignVal n x
| x `mod` n == 0 = x
| otherwise = x + (n (x `mod` n))