{-# LANGUAGE OverloadedStrings #-}
module Pirandello.DBus ( incomingConnectionSignal, connectionClosedSignal
                       , emitEvents, exportAPI, unexportAPI ) where

import Control.Applicative ((<$>))
import Control.Concurrent.STM (atomically, readTQueue)
import Control.Monad (forever)
import Data.List (genericReplicate)
import DBus ( Type (TypeVariant), Signature, MethodCall, Signal
            , signature_, fromVariant, toVariant, methodCallBody, signal, signalBody )
import DBus.Client ( Client, RequestNameReply (NamePrimaryOwner), Reply
                   , requestName, releaseName
                   , method, export, unexport, replyReturn, replyError, emit )
import Pirandello.DBus.Constants (lookupFailure)
import Pirandello.Events (EventQueue, Event (ConnectionClosed, IncomingConnection))
import Pirandello.Kruger (Host, Manager, newManager)
import Pirandello.Outgoing (IdCount, ConnectViaKrugerError (LookupFailure), connectDirect, connectViaKruger, newIdCount)
import UnexceptionalIO (runUnexceptionalIO)
import UnexceptionalIO.ExceptT (EUIO, fromIO, runEUIO, throwEUIO)

incomingConnectionSignal ∷ Signal
incomingConnectionSignal = signal "/" "local.pirandello" "IncomingConnectionSignal"

connectionClosedSignal ∷ Signal
connectionClosedSignal = signal "/" "local.pirandello" "ConnectionClosedSignal"

emitEvents ∷ Client → EventQueue → EUIO ()
emitEvents client q = fromIO . forever $ do
    ev ← atomically $ readTQueue q
    case ev of
        IncomingConnection cid remoteId path →
            emit client $ incomingConnectionSignal { signalBody = [toVariant cid, toVariant remoteId, toVariant path] }
        ConnectionClosed cid reason →
            emit client $ connectionClosedSignal { signalBody = [toVariant cid, toVariant (show reason)] }

variantSig ∷ Integer → Signature
variantSig c = signature_ $ genericReplicate c TypeVariant

wrapConnectDirect ∷ EventQueue → IdCount → MethodCall → IO Reply
wrapConnectDirect q idCount call = rep <$> runEUIO (connectDirect q idCount name host port) where
    Just name = fromVariant $ head $ methodCallBody call
    Just host = fromVariant $ methodCallBody call !! 1
    Just port = fromVariant $ methodCallBody call !! 2
    rep (Right (cid, path)) = replyReturn [toVariant cid, toVariant path]
    rep (Left _) = replyError "local.pirandello.ConnectDirect.Error" []

wrapConnectViaKruger ∷ EventQueue → IdCount → Manager → MethodCall → IO Reply
wrapConnectViaKruger q idCount man call = rep <$> runEUIO (connectViaKruger q idCount man name toLookup) where
    Just name = fromVariant $ head $ methodCallBody call
    Just toLookup = fromVariant $ methodCallBody call !! 1
    rep (Right (cid, path)) = replyReturn [toVariant cid, toVariant path]
    rep (Left LookupFailure) = replyError lookupFailure []
    rep (Left _) = replyError "local.pirandello.ConnectViaKruger.Error" []

exportAPI ∷ Client → EventQueue → Maybe Host → EUIO ()
exportAPI client q krugerHostM = fromIO $ do
    NamePrimaryOwner ← requestName client "local.pirandello" []
    idCount ← runUnexceptionalIO newIdCount
    let methods = [method "local.pirandello" "ConnectDirect" (variantSig 3) (variantSig 2) (wrapConnectDirect q idCount)]
    export client "/" =<< case krugerHostM of
        Just krugerHost → do
            man ← throwEUIO $ newManager krugerHost
            return $ method "local.pirandello" "ConnectViaKruger" (variantSig 2) (variantSig 2) (wrapConnectViaKruger q idCount man) : methods
        Nothing         → return methods

unexportAPI ∷ Client → EUIO ()
unexportAPI client = fromIO $ do
    unexport client "/"
    _ ← releaseName client "local.pirandello"
    return ()
