
;; Copyright (C) 2026 Tommi Höynälänmaa

;; Distributed under GNU Lesser General Public License.


(define-proper-program (intr-dbus-examples server-and-client-1 dbus-test-server1)
  
  
  (import (standard-library core)
          (standard-library list-utilities)
          (standard-library string-utilities)
          (standard-library object-string-conversion)
          (standard-library console-io)
          (standard-library text-file-io))
  

  (import (theme-d-intr base gobject)
          (theme-d-intr base variant)
          (theme-d-intr base utils)
          (theme-d-intr dbus connection)
          (theme-d-intr dbus node-info)
          (theme-d-intr dbus utils))

  
  (define-class <server>
    (fields
     (r-volume <real> public public)
     (str-writeonly <string> public public)))


  (define-simple-method dimfi (((l-items (rest <object>))) <none> nonpure)
    (console-display ";; ")
    (for-each1 (lambda (((x-item <object>)) <none> nonpure)
                 (console-display x-item) (console-display " "))
               l-items)
    (console-newline))
  

  (add-method format
    (prim-proc format
               ((:alt-maybe <output-port>) <string> (rest <object>))
               (:union <string> <boolean>) nonpure))


  (define-simple-method error (((l-args (rest <object>)))
                               <none> (nonpure never-returns))
    (for-each1 console-display l-args)
    (console-newline)
    (exit 1))


  (define gl-debug? #t)
  

  (define-simple-method dbus-node->interface-info
      (((str-node <string>))
       <g-dbus-interface-info>
       nonpure)
    (cast <g-dbus-interface-info>
          (g-dbus-node-info-lookup-interface
           (g-dbus-node-info-new-for-xml str-node)
           "org.gnu.test.DBus")))


  (define-simple-method on-method-call
      (((l-args (rest <object>))) <object> nonpure)
    (dimfi 'on-method-call)
    (dimfi (format #f "~20,,,' @A:" "number of arguments") (length l-args)) 
    (let ((connection
           (cast <g-dbus-connection> (uniform-list-ref l-args 0)))
          (str-sender
           (cast <string> (uniform-list-ref l-args 1)))
          (str-object-path
           (cast <string> (uniform-list-ref l-args 2)))
          (str-interface-name
           (cast <string> (uniform-list-ref l-args 3)))
          (str-method-name
           (cast <string> (uniform-list-ref l-args 4)))
          (vnt-params
           (cast <g-variant> (uniform-list-ref l-args 5)))
          (invocation
           (cast <g-dbus-method-invocation> (uniform-list-ref l-args 6))))
      (case (string->symbol str-method-name)
        ((Method1)
         (let* ((vnt-child (g-variant-get-child-value vnt-params 0))
                (str-arg1 (car (g-variant-get-string vnt-child)))
                (vnt-res1 (g-variant-new-int64
                           (cond
                            ((equal? str-arg1 "Lucky number") 13)
                            ((equal? str-arg1 "Age") 50)
                            (else -1))))
                (vnt-tuple (g-variant-new-tuple (list vnt-res1))))
           (g-object-ref invocation)
           (return-value invocation vnt-tuple)))
        ((Method2)
         (let* ((vnt-child (g-variant-get-child-value vnt-params 0))
                (i-arg1 (g-variant-get-int64 vnt-child))
                (vnt-res-1 (g-variant-new-string "Hello"))
                (vnt-res-2 (g-variant-new-int64 42))
                (vnt-tuple (g-variant-new-tuple (list vnt-res-1 vnt-res-2))))
           (g-object-ref invocation)
           (return-value invocation vnt-tuple)
           (g-dbus-connection-emit-signal
            connection
            str-sender ;; #f
            "/org/gnu/test/DBus"
            "org.gnu.test.DBus"
            "Signal1"
            (g-variant-new-tuple (list (g-variant-new-int64 -1))))))
        ((Method3)
         (let* ((vnt-child (g-variant-get-child-value vnt-params 0))
                (i-count (g-variant-n-children vnt-child))
                (handle-element
                 (lambda (((i <integer>)) <g-variant> nonpure)
                   (let* ((vnt-cur (g-variant-get-child-value vnt-child i))
                          (str-cur (car (g-variant-get-string vnt-cur))))
                     (g-variant-new-int64
                      (cond
                       ((equal? str-cur "Lucky number") 13)
                       ((equal? str-cur "Age") 50)
                       (else -1)))))))
           (let-mutable ((l-result (:uniform-list <g-variant>) null))
             (do ((i <integer> 0 (+ i 1))) ((>= i i-count))
               (set! l-result
                 (append-uniform2 l-result (list (handle-element i)))))
             ;; Variable l-result has to consist of int64's.
             (let* ((vnt-array 
                     (g-variant-new-array
                      (g-variant-type-new "x")
                      l-result))
                    (vnt-tuple (g-variant-new-tuple (list vnt-array))))
               (g-object-ref invocation)
               (return-value invocation vnt-tuple)))))
        ((Method4)
         (let* ((vnt-child (g-variant-get-child-value vnt-params 0))
                (vnt-child2 (g-variant-get-child-value vnt-child 0))
                (vnt-child3 (g-variant-get-child-value vnt-child2 1))
                (i-result (g-variant-get-int64 vnt-child3))
                (vnt-result (g-variant-new-int64 i-result))
                (vnt-tuple (g-variant-new-tuple (list vnt-result))))
           (g-object-ref invocation)
           (return-value invocation vnt-tuple)))
        ((Method5)
         (let* ((vnt-child (g-variant-get-child-value vnt-params 0))
                (vnt-child2 (g-variant-get-child-value vnt-child 0))
                (vnt-child3 (g-variant-get-child-value vnt-child2 0))
                (str-result (car (g-variant-get-string vnt-child3)))
                (vnt-child4 (g-variant-get-child-value vnt-child2 1))
                (i-result (g-variant-get-int64 vnt-child4))
                (vnt-result
                 (g-variant-new-array
                  (g-variant-type-new "{xs}")
                  (list
                   (g-variant-new-dict-entry
                    (g-variant-new-int64 i-result)
                    (g-variant-new-string str-result)))))
                (vnt-tuple (g-variant-new-tuple (list vnt-result))))
           (g-object-ref invocation)
           (return-value invocation vnt-tuple)))
        ((Method6)
         (console-display-line "Method6 called")
         (g-object-ref invocation)
         (return-value invocation (g-variant-new-tuple '())))
        (else
         (error "Unknown or unimplemented method " str-method-name))))
    #f)
  

  (define-simple-method on-get-property
      (((server <server>) (l-args <list>)) <object> nonpure)
    (dimfi 'on-get-property)
    (dimfi (format #f "~20,,,' @A:" "number of arguments") (length l-args)) 
    (let ((connection
           (cast <g-dbus-connection> (uniform-list-ref l-args 0)))
          (str-sender
           (cast <string> (uniform-list-ref l-args 1)))
          (str-object-path
           (cast <string> (uniform-list-ref l-args 2)))
          (str-interface-name
           (cast <string> (uniform-list-ref l-args 3)))
          (str-property-name
           (cast <string> (uniform-list-ref l-args 4))))
      (case (string->symbol str-property-name)
        ((Volume) (g-variant-new-double (field-ref server 'r-volume)))
        ((ReadonlyProp) (g-variant-new-string "Hello World"))
        (else
         (error "Unknown or inaccessible property " str-property-name)))))


  (define-simple-method on-set-property
      (((server <server>) (l-args <list>)) <object> nonpure)
    (dimfi 'on-set-property)
    (dimfi (format #f "~20,,,' @A:" "number of arguments") (length l-args)) 
    (let ((connection
           (cast <g-dbus-connection> (uniform-list-ref l-args 0)))
          (str-sender
           (cast <string> (uniform-list-ref l-args 1)))
          (str-object-path
           (cast <string> (uniform-list-ref l-args 2)))
          (str-interface-name
           (cast <string> (uniform-list-ref l-args 3)))
          (str-property-name
           (cast <string> (uniform-list-ref l-args 4)))
          (vnt-value
           (cast <g-variant> (uniform-list-ref l-args 5))))
      (case (string->symbol str-property-name)
        ((Volume)
         (field-set! server 'r-volume
                     (g-variant-get-double vnt-value))
         #t)
        ((WriteonlyProp)
         (field-set! server 'str-writeonly
                     (g-variant-get-string1 vnt-value))
         (if gl-debug?
             (console-display-line
              (string-append
               "Set property "
               str-property-name
               " to value "
               (field-ref server 'str-writeonly))))
         #t)
        (else
         (error "Unknown or inaccessible property " str-property-name)))))


  (define-simple-method read-file-as-string
      (((str-filename <string>)) <string> nonpure)
    (let* ((ip (open-input-file str-filename))
           (str-contents (read-string ip)))
      (close-input-port ip)
      str-contents))


  (define-simple-method on-bus-acquired
      (((l-args (rest <object>))) <object> nonpure)
    (dimfi 'on-bus-acquired)
    (dimfi (format #f "~20,,,' @A:" "number of arguments") (length l-args)) 
    (dimfi (format #f "~20,,,' @A:" "name") (uniform-list-ref l-args 1)) 
    (let ((connection
           (cast <g-dbus-connection> (uniform-list-ref l-args 0)))
          (server (make <server> #:r-volume 1.0 #:str-writeonly "")))
      (let ((i-result
             (g-dbus-connection-register-object-with-closures2
              connection
              "/org/gnu/test/DBus"
              (dbus-node->interface-info (read-file-as-string "server1.xml"))
              on-method-call
              (lambda (((l-args (rest <object>))) <object> nonpure)
                (on-get-property server l-args))
              (lambda (((l-args (rest <object>))) <object> nonpure)
                (on-set-property server l-args)))))              
        (if (<= i-result 0)
            (error "Registration failed"))
        #f)))
  

  (define-simple-method on-name-acquired
      (((l-args (rest <object>))) <object> nonpure)
    (dimfi 'on-name-acquired)
    (dimfi (format #f "~20,,,' @A:" "number of arguments") (length l-args)) 
    (dimfi (format #f "~20,,,' @A:" "name") (uniform-list-ref l-args 1)) 
    #f)


  (define-simple-method on-name-lost
      (((l-args (rest <object>))) <object> nonpure)
    (dimfi 'on-name-lost)
    (dimfi (format #f "~20,,,' @A:" "number of arguments") (length l-args)) 
    (exit 1)
    #f)


  (define-main-proc (((l-args (:uniform-list <string>))) <none> nonpure)
    (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))))


