{-# LANGUAGE OverloadedStrings #-}
module DBus.Proxy where

import           Control.Arrow
import           Control.Monad
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Except
import           DBus
import           DBus.Client
import           DBus.Internal.Message
import qualified DBus.Internal.Types as T
import qualified DBus.Introspection as I
import qualified DBus.TH as DBusTH
import           Data.Coerce
import           Data.Maybe
import           System.Log.Logger

data ProxyOptions = ProxyOptions Client BusName ObjectPath InterfaceName

maybeToEither :: b -> Maybe a -> Either b a
maybeToEither = flip maybe Right . Left

proxyAll :: Client -> BusName -> ObjectPath -> ObjectPath -> IO ()
proxyAll client busName pathToProxy registrationPath = either print return =<< runExceptT (do
  let introspectionCall =
        (methodCall pathToProxy
                     (interfaceName_ "org.freedesktop.DBus.Introspectable")
                     "Introspect")
                     { methodCallDestination = Just busName }
  returnValue <- ExceptT $ left methodErrorName <$> call client introspectionCall
  obj <- ExceptT $ return $ do
    xmlString <- maybeToEither errorInvalidParameters $
                 listToMaybe (methodReturnBody returnValue) >>= fromVariant
    maybeToEither errorFailed $ I.parseXML "/" xmlString
  let interfaces = I.objectInterfaces obj
  lift $ do
    logM "DBus.Proxy" DEBUG $ show obj
    when (length interfaces < 1) $
         logM "DBus.Proxy" WARNING "No interfaces found when attempting to proxy"
    mapM_ runInterface interfaces)
  where runInterface interface = do
           let proxyOptions = ProxyOptions client busName pathToProxy $
                              I.interfaceName interface
           buildAndRegisterInterface proxyOptions interface registrationPath

buildAndRegisterInterface :: ProxyOptions -> I.Interface -> ObjectPath -> IO ()
buildAndRegisterInterface
   options@(ProxyOptions client busName path interfaceName)
   introspectionInterface registrationPath = do
     let interface = buildInterface options introspectionInterface
     export client registrationPath interface
     forwardSignals options

buildInterface :: ProxyOptions -> I.Interface -> Interface
buildInterface options I.Interface
                 { I.interfaceName = name
                 , I.interfaceMethods = methods
                 , I.interfaceProperties = properties
                 } = Interface
  { interfaceName = name
  , interfaceMethods = map (buildMethod options) methods
  , interfaceProperties = map (buildProperty options) properties
  , interfaceSignals = []
  }

buildReply :: Either MethodError MethodReturn -> Reply
buildReply (Left MethodError { methodErrorName = errorName
                             , methodErrorBody = body
                             }) = ReplyError errorName body
buildReply (Right MethodReturn { methodReturnBody = body }) =
  ReplyReturn body

buildMethod :: ProxyOptions -> I.Method -> Method
buildMethod (ProxyOptions client busName path interfaceName)
            introspectionMethod = Method
  { methodName = I.methodName introspectionMethod
  , inSignature = T.Signature []            -- TODO: make signature accurate
  , outSignature = T.Signature []
  , methodHandler = lift . handler
  }
  where handler theMethodCall =
           buildReply <$> call client
                     theMethodCall { methodCallPath = path
                                , methodCallDestination = Just busName
                                }

buildProperty :: ProxyOptions -> I.Property -> Property
buildProperty (ProxyOptions client busName path interfaceName)
              introspectionProperty = Property
  { propertyName = propName
  , propertyType = T.TypeVariant -- TODO: make this accurate
  , propertyGetter = Just getter
  , propertySetter = Just $ void . setter
  }
  where propName = memberName_ $ I.propertyName introspectionProperty
        baseMethodCall = (methodCall path interfaceName propName)
                         { methodCallDestination = Just busName}
        getter = either (const $ toVariant ("" :: String)) id <$> getProperty client baseMethodCall
        setter = setProperty client baseMethodCall

forwardSignals :: ProxyOptions -> IO ()
forwardSignals (ProxyOptions client busName path interfaceName) = do
  -- TODO: Handle name owner changes?
  let forwardSignal = emit client
      updateSignalForwarding =
          void $ runExceptT $ do
            nameOwnerString <- ExceptT $ DBusTH.getNameOwner client $ coerce busName
            let matchRule = matchAny
                            { matchPath = Just path
                            , matchInterface = Just interfaceName
                            , matchSender = Just $ busName_ nameOwnerString
                            }
            lift $ addMatch client matchRule forwardSignal
  updateSignalForwarding