
;; 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-client1)
  
  
  (import (standard-library core)
          (standard-library list-utilities)
          (standard-library object-string-conversion)
          (standard-library console-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 utils))


  (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 on-my-signal
      (((connection <g-dbus-connection>)
        (str-sender (:alt-maybe <string>))
        (str-object-path <string>)
        (str-interface-name <string>)
        (str-signal-name <string>)
        (vnt-params <g-variant>)
        (x-user-data <object>))
       <none> nonpure)
    (dimfi 'on-my-signal)
    (dimfi (format #f "~20,,,' @A:" "connection") connection)
    (dimfi (format #f "~20,,,' @A:" "unique name")
           (g-dbus-connection-get-unique-name connection))
    (dimfi (format #f "~20,,,' @A:" "sender") str-sender)
    (dimfi (format #f "~20,,,' @A:" "object-path") str-object-path)
    (dimfi (format #f "~20,,,' @A:" "interface name") str-interface-name)
    (dimfi (format #f "~20,,,' @A:" "signal-name") str-signal-name))
  

  (define-simple-method on-my-reply
      (((x-object (:alt-maybe <gobject>))
        (x-result <object>)
        (x-data <object>))
       <none> nonpure)
    (dimfi 'on-my-reply)
    (let* ((connection (cast <g-dbus-connection> x-object))
           (vnt-result (g-dbus-connection-call-finish connection x-result)))
      (dimfi (format #f "~20,,,' @A:" "result")
             (g-variant-get-int64 (g-variant-get-child-value vnt-result 0)))))


  (define-simple-method subscribe-signal
      (((connection <g-dbus-connection>)) <integer> nonpure)
    (g-dbus-connection-signal-subscribe
     connection
     "org.gnu.test.DBus"   ; sender
     "org.gnu.test.DBus"   ; interface-name
     "Signal1"             ; signal-name
     "/org/gnu/test/DBus"  ; object-path
     #f                    ; arg0 filter
     '()                   ; flags
     on-my-signal          ; callback
     #f                    ; user data
     #f))                  ; user data free func
  
  
  (define-simple-method dbus-call-sync
      (((connection <g-dbus-connection>)
        (str-method-name <string>)
        (l-vnt-args (:uniform-list <g-variant>))
        (str-result-type <string>))
       <g-variant> nonpure)
    (g-dbus-connection-call-sync
     connection
     "org.gnu.test.DBus"                  ; bus-name
     "/org/gnu/test/DBus"                 ; object-path
     "org.gnu.test.DBus"                  ; interface-name
     str-method-name                      ; method-name
     (g-variant-new-tuple l-vnt-args)     ; parameters
     (g-variant-type-new str-result-type) ; reply-type
     '()                                  ; flags
     -1                                   ; timeout-msec
     #f))                                 ; cancellable
  

  (define-simple-method dbus-call-async
      (((connection <g-dbus-connection>)
        (str-method-name <string>)
        (l-vnt-args (:uniform-list <g-variant>))
        (str-result-type <string>)
        (proc-result
         (:procedure ((:alt-maybe <gobject>) <object> <object>)
                     <none> nonpure)))
       <none> nonpure)
    (g-dbus-connection-call
     connection
     "org.gnu.test.DBus"                  ; bus-name
     "/org/gnu/test/DBus"                 ; object-path
     "org.gnu.test.DBus"                  ; interface-name
     str-method-name                      ; method-name
     (g-variant-new-tuple l-vnt-args)     ; parameters
     (g-variant-type-new str-result-type) ; reply-type
     '()                                  ; flags
     -1                                   ; timeout-msec
     #f                                   ; cancellable
     proc-result                            ; callback for result
     #f))                                 ; user data
  

  (define-simple-method dbus-get-property
      (((connection <g-dbus-connection>)
        (str-property-name <string>))
       <g-variant> nonpure)
    (let* ((vnt-args
            (g-variant-new-tuple
             (list (g-variant-new-string "org.gnu.test.DBus")
                   (g-variant-new-string str-property-name))))
           (vnt-raw-result
            (g-dbus-connection-call-sync
             connection
             "org.gnu.test.DBus"
             "/org/gnu/test/DBus"
             "org.freedesktop.DBus.Properties"
             "Get"
             vnt-args
             (g-variant-type-new "(v)")
             '()
             -1
             #f))
           (vnt-result
            ;; Get returns this kind of variant.
            (g-variant-get-variant
             (g-variant-get-child-value vnt-raw-result 0))))
      vnt-result))
      

  (define-simple-method dbus-set-property
      (((connection <g-dbus-connection>)
        (str-property-name <string>)
        (vnt-value <g-variant>))
       <none> nonpure)
    (let ((vnt-args
            (g-variant-new-tuple
             (list (g-variant-new-string "org.gnu.test.DBus")
                   (g-variant-new-string str-property-name)
                   ;; Set requires this kind of variant.
                   (g-variant-new-variant vnt-value)))))
      (g-dbus-connection-call-sync
       connection
       "org.gnu.test.DBus"
       "/org/gnu/test/DBus"
       "org.freedesktop.DBus.Properties"
       "Set"
       vnt-args
       (g-variant-type-new "()")
       '()
       -1
       #f)))
    
           
  (define-main-proc (() <none> nonpure)
    (let* ((loop (g-main-loop-new))
           (connection (g-bus-get-sync 'session #f))
           (s-id (subscribe-signal connection))
           (m1-result
            (dbus-call-sync connection
                            "Method1"
                            (list (g-variant-new-string "Lucky number"))
                            "(x)"))
           (m2-result
            (dbus-call-sync connection
                            "Method2"
                            (list (g-variant-new-int64 10))
                            "(sx)"))
           (m3-result
            (dbus-call-sync connection
                            "Method3"
                            (list (g-variant-new-array
                                   (g-variant-type-new "s")
                                   (list (g-variant-new-string "Age")
                                         (g-variant-new-string "Lucky number")
                                         (g-variant-new-string "Height"))))
                            "(ax)"))
           (m4-result
            (dbus-call-sync connection
                            "Method4"
                            (list (g-variant-new-array
                                   (g-variant-type-new "{sx}")
                                   (list
                                    (g-variant-new-dict-entry
                                     (g-variant-new-string "Age")
                                     (g-variant-new-int64 50))
                                    (g-variant-new-dict-entry
                                     (g-variant-new-string "Lucky number")
                                     (g-variant-new-int64 13)))))
                            "(x)"))
           (m5-result
            (dbus-call-sync connection
                            "Method5"
                            (list (g-variant-new-array
                                   (g-variant-type-new "{sx}")
                                   (list
                                    (g-variant-new-dict-entry
                                     (g-variant-new-string "Age")
                                     (g-variant-new-int64 50))
                                    (g-variant-new-dict-entry
                                     (g-variant-new-string "Lucky number")
                                     (g-variant-new-int64 13)))))
                            "(a{xs})"))
           (m6-result
            (dbus-call-sync connection
                            "Method6"
                            '()
                            "()")))
      (dimfi (format #f "~20,,,' @A:" "Result of Method1")
             (g-variant-get-int64
              (g-variant-get-child-value m1-result 0)))
      (dimfi (format #f "~20,,,' @A:" "Result of Method2")
             (g-variant-get-string1
              (g-variant-get-child-value m2-result 0))
             (g-variant-get-int64
              (g-variant-get-child-value m2-result 1)))
      (let ((gv-array (g-variant-get-child-value m3-result 0)))
        (dimfi (format #f "~20,,,' @A:" "Result of Method3")
               (g-variant-n-children gv-array)
               (g-variant-get-int64
                (g-variant-get-child-value gv-array 0))
               (g-variant-get-int64
                (g-variant-get-child-value gv-array 1))
               (g-variant-get-int64
                (g-variant-get-child-value gv-array 2))))
      (dimfi (format #f "~20,,,' @A:" "Result of Method4")
             (g-variant-get-int64
              (g-variant-get-child-value m4-result 0)))
      (let* ((m5-result1
              (g-variant-get-child-value m5-result 0))
             (m5-result2
              (g-variant-get-child-value m5-result1 0)))
        (dimfi (format #f "~20,,,' @A:" "Result of Method5")
               (g-variant-get-int64
                (g-variant-get-child-value m5-result2 0))
               (g-variant-get-string1
                (g-variant-get-child-value m5-result2 1))))
      (dimfi (format #f "~20,,,' @A:" "Result type of Method6")
             (g-variant-get-type-string m6-result))              
      (dimfi (format #f "~20,,,' @A:" "Value of property Volume")
             (g-variant-get-double
              (dbus-get-property connection "Volume")))
      (dbus-set-property connection "Volume"
                         (g-variant-new-double 0.5))
      (dimfi (format
              #f 
              "~20,,,' @A:" "Value of property Volume after setting")
             (g-variant-get-double
              (dbus-get-property connection "Volume")))
      (dimfi (format #f "~20,,,' @A:" "Value of property ReadonlyProp")
             (g-variant-get-string1
              (dbus-get-property connection "ReadonlyProp")))
      (dbus-set-property connection "WriteonlyProp"
                         (g-variant-new-string "Good bye"))
      (dbus-call-async connection
                       "Method1"
                       (list (g-variant-new-string "Age"))
                       "(x)"
                       on-my-reply)
      (g-main-loop-run loop))))
