;; This newlisp "module" implements dbus marshalling
;
; The newlisp representation is a simplified form using lists for
; structs and arrays.

;; (expand-signature S)
; Expland a signature string into a nested list to correspond to the
; newlisp list representation.
;; Basic dbus types are basic newlisp types, including strings. Arrays
;; and structs are sublists; the expanded signature marks array
;; sublists with an initial "a", otherwise it's a struct sublist.
;
; Ex: "yi" = ("y" "i")
; Ex: "y(ai)" = ("y" (("a" "i")))
; Ex: "a(yi)" = (("a" ("y" "i")))
; Ex: "yyyyuua(yv)" = ("y" "y" "y" "y" "u" "u" ("a" ("y" "v")))
(define (expand-signature S)
  (setf S (replace "{" (replace "}" (copy S) ")") "("))
  (let ((STACK '()) (CUR '()) (A 0))
    (dolist (X (explode S))
      (case X
        (")" (setf X CUR) (setf CUR (pop STACK)))
        ("(" (push CUR STACK) (setf CUR '()))
        (true true))
      (when (and (!= X "a") (!= X "("))
        (while (and CUR (= "a" (last CUR)))
          (setf X (list (last CUR) X))
          (setf CUR (chop CUR))))
      (when (!= "(" X)
        (push X CUR -1)))
    (if (null? CUR) '() CUR)))

;; Align AT to an I multiple and pad DATA with as many NUL bytes at
;; front, then increment AT past it all.
(define (pack-align DATA (I (length DATA)))
  (let ((PAD (dup "\000" (% (- I (% AT I)) I))))
    (setf DATA (extend PAD DATA))
    (inc AT (length DATA))
    DATA))

;; Pack data from DATA according to signature. The DATA is a nested
;; list where container types are sub lists. Variant types also appear
;; as pairs of signature and value.
(define (pack-data SIGN DATA)
  (let ((AT 0)) (pack-data-struct (expand-signature SIGN) DATA)))

;; Pack a newlisp data element according to marshalling type The
;; newlisp data is integer, double, string or list (for container and
;; variant elements).
(constant
 'FMTMAP ; mapping dbus type code to byte size and newlisp code
 '( ("y" 1 "b")  ; BYTE (unsigned 8-bit integer)
    ("b" 4 "lu")  ; BOOLEAN (0 is FALSE, 1 is TRUE, else invalid)
    ("n" 2 "d")  ; INT16 (signed 16-bit integer)
    ("q" 2 "u")  ; UINT16 (unsigned 16-bit integer)
    ("i" 4 "ld") ; INT32 (signed 32-bit integer)
    ("u" 4 "lu") ; UINT32 (unsigned 32-bit integer)
    ("x" 8 "Ld") ; INT64 (signed 64-bit integer)
    ("t" 8 "Lu") ; UINT64 (unsigned 64-bit integer)
    ("d" 8 "lf") ; DOUBLE (64-bit float)
    ("h" 4 "lu") ; UINT32 (unix file descriptor)
    ("a" ? ?)    ; ARRAY = UINT32 byte-length, items
    ("s" ? ?)    ; STRING = length + data + NUL
    ("o" ? ?)    ; OBJECT_PATH = BYTE length + data + NUL
    ("g" ? ?)    ; SIGNATURE = BYTE length + data + NUL
    ("(" ? ?)    ; STRUCT begin in signature = (8-align) + data
    (")" 0 ?)    ; STRUCT end in signature
    ("v" ? ?)    ; VARIANT = signature + data
    ("{" ? ?)    ; DICT_ENTRY begin 
    ("}" ? ?)    ; DICT_ENTRY end
    ("r" ? ?)    ; reserved STRUCT in bindings?
    ("e" ? ?)    ; reserved DICT_ENTRY in bindings ?
    ("m" ? ?)    ; reserved 'maybe'
    ("*" ? ?)    ; reserved 'single complete type'
    ("?" ? ?)    ; reserved 'basic type'
    ("@" ? ?)    ; reserved
    ("&" ? ?)    ; reserved
    ("^" ? ?)    ; reserved
    )
 )

(define (pack-data-item ES DATA)
  (if (list? ES) (pack-data-struct ES DATA)
    (= ES "s") (pack-data-string ES DATA)
    (= ES "o") (pack-data-string ES DATA)
    (= ES "g") (pack-data-signature ES DATA)
    (= ES "v") (apply pack-data-variant DATA)
    (if (lookup ES FMTMAP) (pack-align (pack $it DATA)))))

(define (pack-data-variant ES DATA)
  (extend (pack-align (pack "bbb" 1 (char ES) 0) 1)
          (pack-data-item ES DATA)))

;; pack types "s" and "o"
(define (pack-data-string ES DATA)
  (pack-align (pack (format "lus%db" (length DATA)) (length DATA) DATA 0) 4))

;; pack type "g"
(define (pack-data-signature ES DATA)
  (pack-align (pack (format "bs%db" (length DATA)) (length DATA) DATA 0) 1))

;; Pack an array. DATA elements marshalled by repeating ES, preceded
;; by the array length in bytes as aligned UINT32.
(define (pack-data-array ES DATA)
  (let ((PAD (pack-align "" 4))
        (X (inc AT 4)) ; start index of array bytes
        (DATA (apply extend (map (curry pack-data-item ES) DATA))))
    (extend PAD (pack "lu" (- AT X)) DATA)))

;; Pack a struct. ES and DATA elements marshalled pairwise in order
;; following an initial8-byte alignment.
(define (pack-data-struct ES DATA)
  (if (= "a" (ES 0)) (pack-data-array (ES 1) DATA)
    (apply extend (cons (pack-align "" 8)
                        (map pack-data-item ES DATA)))))

;;########## unpacking

;; Advance AT to an I multiple.
(define (align-AT I)
  (inc AT (% (- I (% AT I)) I)))

;; Advance AT to an I multiple and unpack (by newlisp format) at that
;; position in DATA. Then advance AT further past that unpacking but
;; return the unpacked value.
(define (unpack-align I FMT)
  ##(println (list 'unpack-align I FMT AT (length DATA)))
  (align-AT I)
  (prog1 ((unpack FMT (AT DATA)) 0) (inc AT I)))

;; Unpack a string or object path. The format is "lu" (UINT32) with
;; the string length, then "s%db" with that string length and followed
;; by a NUL byte.
(define (unpack-data-string ES (N (unpack-align 4 "lu")))
  (prog1 ((unpack (string "s" N) (AT DATA)) 0) (inc AT (+ 1 N))))

;; Unpack a signature string. The format is "b" (BYTE) with the string
;; length, then "s%db" with that string length and followed by a NUL
;; byte. I.e. the same as unpack-data-string but with the string
;; length in a BYTE rather than an UINT32.
(define (unpack-data-signature ES)
  (unpack-data-string ES (unpack-align 1 "b")))

;; Unpack a variant item. This consists of "bbb" where the middle
;; character is the type character for the data, preceded by a 1 byte
;; and followed by a NUL byte. The subsequent data is unpacked
;; according to that type character.
(define (unpack-data-variant)
  (unpack-data-item ((expand-signature (unpack-data-signature "g")) 0)))

;; Unpack the ES type item from (AT DATA), optionally with
;; pre-alignment, and increment AT past the padding and item.
(define (unpack-data-item ES)
  ##(println (list 'unpack-data-item ES AT (length DATA)))
  (if (list? ES) (unpack-data-struct ES)
    (= ES "s") (unpack-data-string ES)
    (= ES "o") (unpack-data-string ES)
    (= ES "g") (unpack-data-signature ES)
    (= ES "v") (unpack-data-variant)
    (if (assoc ES FMTMAP) (unpack-align ($it -2) ($it -1)))))

;; Unpack array with ES elements. The array begins with an UINT32
;; field telling how many bytes to unpack, followed by the array
;; elements.
(define (unpack-data-array ES)
  (let ((A AT) (N (+ (unpack-align 4 "u") AT)) (OUT '()))
    (when (and (list? ES) (!= "a" (ES 0))) (align-AT 8))
    (while (< AT N)
      ##(println "---next " (list AT N))
      (push (unpack-data-item ES) OUT -1))
    OUT))

;; Unpack a structure or array with ES fields.
(define (unpack-data-struct ES)
  ##(println (list 'unpack-data-struct ES AT))
  (if (= "a" (ES 0)) (unpack-data-array (ES 1))
    (begin (align-AT 8) (map unpack-data-item ES))))

;; Unpack from a DATA string according to signature SIGN This returns
;; a pair (unpacked pos) of unpacked data and how much data is
;; consumed.
(define (unpack-data SIGN DATA (AT 0))
  ##(println (format "*** unpack-data %s %d %d" SIGN (length DATA) AT))
  (list (unpack-data-item (expand-signature SIGN)) AT))

;; Unpack all dbus messages in the given DATA block. Each message
;; consists of head and body. The head has signature "yyyyuua(yv)"
;; where the array is an alist of key-value pairs, optionally
;; including the 'SIGNATURE key with the signature for the body; if
;; omitted, then the body is empty.
;;
;; The function returns the header list of key-value pairs optionally
;; extended with the pair ("" body).
(define (unpack-messages DATA)
  (let ((AT 0) (OUT '()) (M nil) (D nil) (S nil))
    (while (and (< (+ AT 7) (length DATA))
                (setf M (unpack-data "yyyyuua(yv)" DATA AT)))
      (setf AT (M 1))
      ##(println "message head " (M 0))
      ##(println (list 'remains AT (length DATA)))
      (setf M (M 0 -1)) ; Drop all but the headers then map to symbol keys
      (dotimes (i (length M))
        (setf (M i 0) (MESSAGE-HEADERS (M i 0) 0)))
      ##(println "mapped headers " M)
      ;; Add the body, if any, keyed by "".
      (setf S (if (lookup 'SIGNATURE M) $it ""))
      ##(println (list 'sign S))
      (when (and (!= S "") (setf D (unpack-data S DATA AT)))
        (setf AT (D 1))
        (extend M (list (list "" (D 0)))))
      ;; Collate message and move to the next portion in DATA
      (push M OUT -1)
      ##(println (list 'ending AT (length DATA)))
      ;;(align-AT 4)
      ##(println (list 'aligned AT (length DATA)))
      (setf DATA (AT DATA))
      (setf AT 0) 
      )
    OUT ))

"lsp-dbus-marshal.lsp"