Socket.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

-- Copyright (C) 2012 John Millikin <john@john-millikin.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/>.

module DBusTests.Socket (test_Socket) where

import           Test.Chell

import           Control.Concurrent
import           Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Data.Map as Map

import           DBus
import           DBus.Socket
import           DBus.Transport

import           DBusTests.Util (forkVar)

test_Socket :: Suite
test_Socket = suite "Socket"
    [ test_Listen
    , test_ListenWith_CustomAuth
    , test_SendReceive
    ]

test_Listen :: Test
test_Listen = assertions "listen" $ do
    uuid <- liftIO randomUUID
    let Just addr = address "unix" (Map.fromList
            [ ("abstract", formatUUID uuid)
            ])

    listener <- liftIO (listen addr)
    afterTest (closeListener listener)

    acceptedVar <- forkVar (accept listener)
    openedVar <- forkVar (open addr)

    sock1 <- liftIO (takeMVar acceptedVar)
    afterTest (close sock1)

    sock2 <- liftIO (takeMVar openedVar)
    afterTest (close sock2)

test_ListenWith_CustomAuth :: Test
test_ListenWith_CustomAuth = assertions "listenWith-custom-auth" $ do
    uuid <- liftIO randomUUID
    let Just addr = address "unix" (Map.fromList
            [ ("abstract", formatUUID uuid)
            ])

    listener <- liftIO (listenWith (defaultSocketOptions
        { socketAuthenticator = dummyAuth
        }) addr)
    afterTest (closeListener listener)

    acceptedVar <- forkVar (accept listener)
    openedVar <- forkVar (openWith (defaultSocketOptions
        { socketAuthenticator = dummyAuth
        }) addr)

    sock1 <- liftIO (takeMVar acceptedVar)
    afterTest (close sock1)

    sock2 <- liftIO (takeMVar openedVar)
    afterTest (close sock2)

test_SendReceive :: Test
test_SendReceive = assertions "send-receive" $ do
    uuid <- liftIO randomUUID
    let Just addr = address "unix" (Map.fromList
            [ ("abstract", formatUUID uuid)
            ])

    let msg = (methodCall "/" "org.example.iface" "Foo")
            { methodCallSender = Just "org.example.src"
            , methodCallDestination = Just "org.example.dst"
            , methodCallAutoStart = False
            , methodCallReplyExpected = False
            , methodCallBody = [toVariant True]
           }

    listener <- liftIO (listen addr)
    afterTest (closeListener listener)

    acceptedVar <- forkVar (accept listener)
    openedVar <- forkVar (open addr)

    sock1 <- liftIO (takeMVar acceptedVar)
    afterTest (close sock1)

    sock2 <- liftIO (takeMVar openedVar)
    afterTest (close sock2)

    -- client -> server
    do
        serialVar <- liftIO newEmptyMVar
        sentVar <- forkVar (send sock2 msg (putMVar serialVar))
        receivedVar <- forkVar (receive sock1)

        serial <- liftIO (takeMVar serialVar)
        sent <- liftIO (takeMVar sentVar)
        received <- liftIO (takeMVar receivedVar)

        $assert (equal sent ())
        $assert (equal received (ReceivedMethodCall serial msg))

    -- server -> client
    do
        serialVar <- liftIO newEmptyMVar
        sentVar <- forkVar (send sock1 msg (putMVar serialVar))
        receivedVar <- forkVar (receive sock2)

        serial <- liftIO (takeMVar serialVar)
        sent <- liftIO (takeMVar sentVar)
        received <- liftIO (takeMVar receivedVar)

        $assert (equal sent ())
        $assert (equal received (ReceivedMethodCall serial msg))

dummyAuth :: Transport t => Authenticator t
dummyAuth = authenticator
    { authenticatorClient = dummyAuthClient
    , authenticatorServer = dummyAuthServer
    }

dummyAuthClient :: Transport t => t -> IO Bool
dummyAuthClient t = do
    transportPut t "\x00"
    resp <- transportGet t 4
    return (resp == "OK\r\n")

dummyAuthServer :: Transport t => t -> UUID -> IO Bool
dummyAuthServer t _ = do
    c <- transportGet t 1
    if c == "\x00"
        then do
            transportPut t "OK\r\n"
            return True
        else return False