#! /bin/sh
# -*- mode: scheme; coding: utf-8 -*-
exec guile -e main -s "$0" "$@"
!#

(eval-when (expand load eval)
  (use-modules (oop goops))

  (default-duplicate-binding-handler
    '(merge-generics replace warn-override-core warn last))

  (use-modules (g-golf))

  (g-irepository-require "Gio")
  (for-each (lambda (name)
              (gi-import-by-name "Gio" name))
      '("DBusConnection"
        "DBusInterfaceInfo"
        "DBusMethodInvocation"
        "DBusNodeInfo"
        "bus_own_name"
        "bus_unown_name")))


(define %dbus-node
  "<node>
     <interface name='org.gnu.test.DBus'>
       <method name='Method1'>
         <arg name='arg1' type='s' direction='in'/>
         <arg name='res1' type='x' direction='out'/>
       </method>
       <method name='Method2'>
         <arg name='arg1' type='x' direction='in'/>
         <arg name='res1' type='s' direction='out'/>
         <arg name='res2' type='x' direction='out'/>
       </method>
       <signal name='Signal1'>
         <arg name='param' type='x'/>
       </signal>
     </interface>
   </node>")

(define (dbus-node->interface-info dbus-node)
  (g-dbus-node-info-lookup-interface (g-dbus-node-info-new-for-xml dbus-node)
                                     "org.gnu.test.DBus"))

(define (on-method-call connection
                        sender
                        object-path
                        interface-name
                        method-name
                        parameters
                        invocation)
  (when (%debug)
    (dimfi 'on-method-call)
    (dimfi (format #f "~20,,,' @A" "connection") connection)
    (dimfi (format #f "~20,,,' @A" "sender") sender)
    (dimfi (format #f "~20,,,' @A" "object-path") object-path)
    (dimfi (format #f "~20,,,' @A" "interface-name") interface-name)
    (dimfi (format #f "~20,,,' @A" "method-name") method-name)
    (dimfi (format #f "~20,,,' @A" "parameters") parameters)
    (dimfi (format #f "~20,,,' @A" "invocation") invocation))
  (case (string->symbol method-name)
    ((Method1)
     (let* ((params (get-parameters invocation))
            (child (g-variant-get-child-value params 0))
            (arg1 (g-variant-get-string child))
            (res1 (g-variant-new-int64
                   (cond
                    ((string=? arg1 "Lucky number") 13)
                    ((string=? arg1 "Age") 50)
                    (else -1))))
            (tuple (g-variant-new-tuple `(,res1))))
     (g-object-ref invocation)
     (return-value invocation tuple)))
    ((Method2)
     (let* ((params (get-parameters invocation))
            (child (g-variant-get-child-value params 0))
            (arg1 (g-variant-get-int64 child))
            (res-1 (g-variant-new-string "Hello"))
            (res-2 (g-variant-new-int64 42))
            (tuple (g-variant-new-tuple `(,res-1 ,res-2))))
       (g-object-ref invocation)
       (return-value invocation tuple)
       (emit-signal connection
                    #f
                    "/org/gnu/test/DBus"
                    "org.gnu.test.DBus"
                    "Signal1"
                    (g-variant-new-tuple `(,(g-variant-new-int64 -1))))))
    (else
     (error "Unknown method " method-name))))

(define (on-bus-acquired connection name)
  (unless (> (register-object-with-closures2 connection
                                             "/org/gnu/test/DBus"
                                             (dbus-node->interface-info %dbus-node)
                                             on-method-call
                                             #f
                                             #f)
             0)
    (error 'on-bus-acquired:object-reg-failed)))


(define (on-name-acquired connection name)
  (when (%debug)
    (dimfi 'on-name-acquired)))


(define (on-name-lost connection name)
  (when (%debug)
    (dimfi 'on-name-lost))
  (exit 1))


(define (main args)
  (letrec ((debug? (or (member "-d" args)
                       (member "--debug" args)))
           (animate (lambda ()
                      (let ((loop (g-main-loop-new)))
                        (g-bus-own-name-with-closures 'session
                                                      "org.gnu.test.DBus"
                                                      '(none)
                                                      on-bus-acquired
                                                      on-name-acquired
                                                      on-name-lost)
                        (g-main-loop-run loop)))))
    (if debug?
        (parameterize ((%debug #t)) (animate))
        (animate))))