#! /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"
        "bus_own_name"
        "bus_unown_name")))


(define-class <server> ()
  (conn #:init-keyword #:conn))
    
(define (on-method-call conn
                        str-sender
                        str-object
                        str-interface
                        str-method
                        vnt-parameters
                        invocation)
  (dimfi (format #f "~20,,,' @A" " on-method-call"))
  (if (equal? str-method "MyMethod1")
    (let ((vnt-params (gd-bus-method-invocation-get-parameters invocation)))
      (dimfi (format #f "~20,,,' @A" " params")
            vnt-params 
            (g-variant-type-dup-string (g-variant-get-type vnt-params)))
      (if (eqv? (g-variant-n-children vnt-params) 1)
        (let ((str-arg
               (g-variant-get-string
                (g-variant-get-child-value vnt-params 0))))
          (dimfi (format #f "~20,,,' @A" " on-method-call/1"))
          (let ((i-response
                 (cond
                   ((equal? str-arg "Lucky number") 13)
                   ((equal? str-arg "Age") 50)
                   (else -1))))
            (let* ((vnt-response (g-variant-new-int64 i-response))
                   (vnt-tuple
                    (g-variant-new-tuple (list vnt-response))))
              (dimfi (format #f "~20,,,' @A" " on-method-call/2")
                     (g-variant-type-dup-string (g-variant-get-type vnt-tuple)))
              ;; (g-variant-ref vnt-response)
              ;; (g-variant-ref vnt-tuple)
              (gd-bus-method-invocation-return-value invocation
                                                     vnt-tuple))))
        (display "Invalid number of arguments to MyMethod1.\n")))
    (display (string-append "Unknown method " str-method ".\n"))))

(define (on-bus-acquired server conn str-name)
  (dimfi (format #f "~20,,,' @A" " on-bus-acquired"))
  (slot-set! server 'conn conn)
    (let* ((x-arg1
            (make-c-struct (list int64 '* '* '*)
                           (list 1
                                 (string->pointer "str-choice")
                                 (string->pointer "s")
                                 %null-pointer)))
           (x-arguments (scm->gi-pointers (list x-arg1)))
           (x-return-value
            (make-c-struct
             (list int64 '* '* '*)
             (list 1
                   (string->pointer "i-result")
                   (string->pointer "x")
                   %null-pointer)))
           (x-return-values
            (scm->gi-pointers (list x-return-value)))
           (x-method1
            (make-c-struct (list int64 '* '* '* '*)
                           (list 1
                                 (string->pointer "MyMethod1")
                                 x-arguments
                                 x-return-values
                                 %null-pointer)))
           (x-methods (scm->gi-pointers (list x-method1)))
           (x-interface-info
            (make-c-struct (list int64 '* '* '* '* '*)
                           (list 1
                                 (string->pointer "fi.tohoyn.DBusServer1")
                                 x-methods
                                 %null-pointer
                                 %null-pointer
                                 %null-pointer)))
           (i-reg-id
            (gd-bus-connection-register-object-with-closures2
             conn
             "/fi/tohoyn/DBusServer1"
             x-interface-info
             on-method-call
             #f
             #f)))
      (if (<= i-reg-id 0)
        (raise 'on-bus-acquired:object-reg-failed))))


(define (on-name-acquired server conn str-name)
  (dimfi (format #f "~20,,,' @A" " on-name-acquired")))


(define (on-name-lost server conn str-name)
  (dimfi (format #f "~20,,,' @A" " on-name-lost"))
  (exit 1))


(define (main args)
  (let* ((loop (g-main-loop-new))
         (server (make <server> #:conn #f))
         (i-id
          (g-bus-own-name-with-closures
           'session
           "fi.tohoyn.DBusServer1"
           '(none)
           (lambda (conn str-name)
             (on-bus-acquired server conn str-name))
           (lambda (conn str-name)
             (on-name-acquired server conn str-name))
           (lambda (conn str-name)
             (on-name-lost server conn str-name)))))
    (g-main-loop-run loop)
    (g-bus-unown-name i-id)))