guile-zwave/zwave.scm

;;; Guile-ZWave -- Guile talks with ZWave devices.
;;; Copyright © 2019, 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of Guile-ZWave.
;;;
;;; Guile-ZWave is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Guile-ZWave is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Guile-ZWave.  If not, see <http://www.gnu.org/licenses/>.

(define-module (zwave)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 iconv)
  #:use-module (ice-9 vlist)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-60)
  #:use-module (srfi srfi-71)
  #:export (open-zwave-serial-port
            initialize-zwave-state

            message-type
            message-class
            command-class

            serial-message?
            serial-message
            serial-message-type
            serial-message-class
            serial-message-payload
            read-serial-message
            write-serial-message

            make-request
            handle-response

            zwave-state?
            zwave-state-nodes
            zwave-state-version
            pop-zwave-state-notification))

(define-immutable-record-type <zwave-state>
  (zwave-state version suc-node-id nodes notifications)
  zwave-state?
  (version       zwave-state-version set-zwave-state-version)
  (suc-node-id   zwave-state-suc-node-id set-zwave-state-suc-node-id)
  (nodes         zwave-state-nodes set-zwave-state-nodes)
  (notifications zwave-state-notifications set-zwave-state-notifications))

(define (push-zwave-state-notification state notification)
  (set-zwave-state-notifications state
                                 (cons notification
                                       (zwave-state-notifications state))))

(define (pop-zwave-state-notification state)
  (match (zwave-state-notifications state)
    (()
     (values #f state))
    ((first ... notification)
     (values notification
             (set-zwave-state-notifications state first)))))

(define %zwave-initial-state
  (zwave-state #f #f '() '()))

(define-immutable-record-type <node>
  (%node id alive? command-classes)
  node?
  (id        node-id)
  (alive?    node-alive? set-node-alive?)
  (command-classes node-command-classes set-node-command-classes))

(define* (node id #:key (alive? #t) command-classes)
  (%node id alive? command-classes))

(define (add-zwave-state-node state node)
  "Add NODE to the list of nodes of STATE."
  (let ((new-id (node-id node)))
    (set-zwave-state-nodes
     state
     (cons node (remove (lambda (node)
                          (= new-id (node-id node)))
                        (zwave-state-nodes state))))))

(define-syntax define-enumerate-type
  (syntax-rules ()
    ((_ record-type predicate
        name->value value->integer integer->value
        (name id) ...)
     (begin
       ;; Disjoint type used as a box for the integer value.
       (define-record-type record-type
         (box value)
         predicate
         (value value->integer))

       (define integer->value
         (let ((id/name-list '((id . name) ...)))
           (lambda (integer)
             (let ((symbol (assv-ref id/name-list integer)))
               (unless symbol
                 (error "wrong enumerate value"
                        (list 'record-type integer)))
               (box integer)))))

       (let* ((alist        '((id . name) ...))
              (print-record (lambda (box port)
                              (format port "#<~a ~a>"
                                      'record-type
                                      (assv-ref alist
                                                (value->integer box))))))
         (set-record-type-printer! record-type print-record))

       (define-syntax name->value
         (syntax-rules (name ...)
           ((_ name) (make-struct/no-tail record-type id))
           ...))))))

(define-enumerate-type <message-type>
  message-type?
  message-type message-type->integer integer->message-type
  (request  #x00)
  (response #x01)
  (ack      #x02)
  (nack     #x03)
  (can      #x04))

;; Signaling frames.  This is a single byte sent over the wire.
(define-enumerate-type <signaling-frame>
  signaling-frame?
  signaling-frame signaling-frame->integer integer->signaling-frame
  (som      #x01)                                 ;start of frame (SOM)
  (ack      #x06)
  (nack     #x15)
  (can      #x18))

;; Message classes.  See SerialMessage.java.
(define-enumerate-type <message-class>
  message-class?
  message-class message-class->integer integer->message-class
  (get-initial-data              #x02)
  (application-command-handler   #x04)
  (get-version                   #x15)
  (application-update            #x49)
  (get-suc-node-id               #x56) ;get ID of Static Update Controller (SUC)
  (explore-request-inclusion     #x5e)
  (get-routing-info              #x80)
  (add-node-to-network           #x4a))   ;start the device inclusion process

(define-record-type <serial-message>
  (serial-message type class payload)
  serial-message?
  (type    serial-message-type)
  (class   serial-message-class)
  (payload serial-message-payload))

(define-syntax vhash
  (syntax-rules (=>)
    "Build a vhash with the given key/value mappings."
    ((_ constructor)
     vlist-null)
    ((_ constructor (key => value) rest ...)
     (vhash-cons (constructor key) value
                 (vhash constructor rest ...)))))

(define %request-payload
  ;; Map message classes to procedures that compute the message's payload
  ;; based on its arguments.  See ZWaveController.java.
  (vhash message-class
         (get-routing-info
          => (lambda (node-id)
               (u8-list->bytevector
                (list node-id
                      0                           ;don't remove bad nodes
                      0                           ;don't remove non-repeaters
                      3))))
         (add-node-to-network
          => (lambda* (#:key high-power? network-wide?)
               ;; Send a request to start the device "inclusion" process.
               ;; When HIGH-POWER? is false, the device has to be within one
               ;; meter of the controller.  When NETWORK-WIDE? is true, hmm?
               ;; See AddNodeMessageClass.java.
               (define add-node-any 1)
               (define option-high-power #x80)
               (define option-network-wide #x40)

               (u8-list->bytevector
                (list (logior add-node-any
                              (if high-power? option-high-power 0)
                              (if network-wide? option-network-wide 0))))))))

;; Update types for 'application-update' messages.
(define-enumerate-type <update-type>
  update-type?
  update-type update-type->integer integer->update-type
  (node-info-received       #x84)
  (node-info-request-done   #x82)
  (node-info-request-failed #x81)
  (routing-pending          #x80)
  (new-id-assigned          #x40)
  (delete-done              #x20)
  (suc-id                   #x10))

;; Command classes that devices may support.  See ZWaveCommandClass.java.
(define-enumerate-type <command-class>
  command-class?
  command-class command-class->integer integer->command-class
  (no-operation             #x00)
  (basic                    #x20)
  (controller-replication   #x21)
  (application-status       #x22)
  (zip                      #x23)
  (security-panel-mode      #x24)
  (switch-binary            #x25)
  (switch-multilevel        #x26)
  (switch-all               #x27)
  (switch-toggle-binary     #x28)
  (switch-toggle-multilevel #x29)
  (chimney-fan              #x2a)
  (scene-activation #x2b)
  (scene-actuator-conf #x2c)
  (scene-controller-conf #x2d)
  (security-panel-zone #x2e)
  (security-panel-zone-sensor #x2f)
  (sensor-binary #x30)
  (sensor-multilevel #x31)
  (meter #x32)
  (switch-color #x33)
  (network-management-inclusion #x34)
  (meter-pulse #x35)
  (basic-tariff-info #x36)
  (hrv-status #x37)
  (hrv-control #x39)
  (dcp-config #x3a)
  (dcp-monitor #x3b)
  (meter-tbl-config #x3c)
  (meter-tbl-monitor #x3d)
  (meter-tbl-push #x3e)
  (thermostat-heating #x38)
  (prepayment #x3f)
  (thermostat-mode #x40)
  (prepayment-encapsulation #x41)
  (thermostat-operating-state #x42)
  (thermostat-setpoint #x43)
  (thermostat-fan-mode #x44)
  (thermostat-fan-state #x45)
  (climate-control-schedule #x46)
  (thermostat-setback #x47)
  (rate-tbl-config #x48)
  (rate-tbl-monitor #x49)
  (tariff-config #x4a)
  (tariff-tbl-monitor #x4b)
  (door-lock-logging #x4c)
  (network-management-basic #x4d)
  (schedule-entry-lock #x4e)
  (zip-6lowpan #x4f)
  (basic-window-covering #x50)
  (mtp-window-covering #x51)
  (network-management-proxy #x52)
  (schedule #x53)
  (network-management-primary #x54)
  (transport-service #x55)
  (crc-16-encap #x56)
  (application-capability #x57)
  (zip-nd #x58)
  (association-grp-info #x59)
  (device-reset-locally #x5a)
  (central-scene #x5b)
  (ip-association #x5c)
  (antitheft #x5d)
  (zwaveplus-info #x5e)
  (zip-gateway #x5f)
  (multi-channel #x60)
  (zip-portal #x61)
  (door-lock #x62)
  (user-code #x63)
  (humidity-control-setpoint #x64)
  (dmx #x65)
  (barrier-operator #x66)
  (network-management-installation-maintenance #x67)
  (zip-naming #x68)
  (mailbox #x69)
  (window-covering #x6a)
  (irrigation #x6b)
  (supervision #x6c)
  (humidity-control-mode #x6d)
  (humidity-control-operating-state #x6e)
  (entry-control #x6f)
  (configuration #x70)
  (alarm #x71)
  (manufacturer-specific #x72)
  (powerlevel #x73)
  (inclusion-controller #x74)
  (protection #x75)
  (lock #x76)
  (node-naming #x77)
  (firmware-update-md #x7a)
  (grouping-name #x7b)
  (remote-association-activate #x7c)
  (remote-association #x7d)
  (battery #x80)
  (clock #x81)
  (hail #x82)
  (wake-up #x84)
  (association #x85)
  (version #x86)
  (indicator #x87)
  (proprietary #x88)
  (language #x89)
  (time #x8a)
  (time-parameters #x8b)
  (geographic-location #x8c)
  (multi-channel-association #x8e)
  (multi-cmd #x8f)
  (energy-production #x90)
  ;; Note that MANUFACTURER-PROPRIETARY shouldn't be instantiated directly
  ;; The getInstance method will catch this and translate to the correct
  ;; class for the device.
  (manufacturer-proprietary #x91)
  (screen-md #x92)
  (screen-attributes #x93)
  (simple-av-control #x94)
  (av-content-directory-md #x95)
  (av-renderer-status #x96)
  (av-content-search-md #x97)
  (security #x98)
  (av-tagging-md #x99)
  (ip-configuration #x9a)
  (association-command-configuration #x9b)
  (sensor-alarm #x9c)
  (silence-alarm #x9d)
  (sensor-configuration #x9e)
  (security-2 #x9f)
  (mark #xef)
  (non-interoperable #xf0))

(define (lookup-node state id)
  "Return the node with the given ID or #f."
  (find (lambda (node)
          (= id (node-id node)))
        (zwave-state-nodes state)))

(define (handle-get-initial-data message state)
  "Process MESSAGE, a response to a 'get-initial-data' request, and return
STATE with a node list adjusted accordingly."
  (let* ((payload (serial-message-payload message))
         (bytes   (bytevector-u8-ref payload 2)))
    (unless (= 29 bytes)
      (error "invalid get-initial-data number of node bytes"
             bytes))

    (let loop ((index 3)
               (id    1)
               (nodes '()))
      (if (< index (+ 3 bytes))                   ;XXX: or +2?
          (let ((byte (bytevector-u8-ref payload index)))
            ;; Each bit in BYTE indicates a node.
            (let liip ((bit 0)
                       (id id)
                       (nodes nodes))
              (if (< bit 8)
                  (liip (+ 1 bit)
                        (+ 1 id)
                        (if (bit-set? bit byte)
                            (cons (node id) nodes)
                            nodes))
                  (loop (+ 1 index) id nodes))))
          (set-zwave-state-nodes state (reverse nodes))))))

(define (handle-application-update message state)
  "Handle MESSAGE, an 'application-update' message, and return STATE modified
accordingly."
  (define (read-command-classes payload)
    (define len (bytevector-u8-ref payload 2))
    (let loop ((index 6)
               (classes '()))
      (if (< index (+ len 2))
          (loop (+ 1 index)
                (cons (integer->command-class
                       (bytevector-u8-ref payload index))
                      classes))
          (reverse classes))))

  (let* ((payload (serial-message-payload message))
         (update  (integer->update-type
                   (bytevector-u8-ref payload 0))))
    (cond ((equal? update (update-type node-info-received))
           ;; We received a "node info frame" (NIF).
           (let* ((id   (bytevector-u8-ref payload 1))
                  (node (or (lookup-node state id)
                            (node id))))
             (pk 'newnode id)
             (add-zwave-state-node state
                                   (set-node-command-classes
                                    node (read-command-classes payload)))))
          (else
           state))))

(define (sub-bytevector bv start size)
  "Return a copy of the SIZE bytes of BV starting from offset START."
  (let ((result (make-bytevector size)))
    (bytevector-copy! bv start result 0 size)
    result))

(define (handle-get-version message state)
  "Handle MESSAGE, a 'get-version' reply that gives us the version string of
the controller."
  (let* ((payload (serial-message-payload message))
         (library-type (bytevector-u8-ref payload 11))
         (version (utf8->string (sub-bytevector payload 0 11))))
    (set-zwave-state-version state version)))

(define (handle-application-command-handler message state)
  (let* ((payload (serial-message-payload message))
         (node-id (bytevector-u8-ref payload 1))
         (len     (bytevector-u8-ref payload 2))
         (class   (integer->command-class
                   (bytevector-u8-ref payload 3))))
    (push-zwave-state-notification state
                                   (cons class node-id))))

(define (handle-add-node-to-network message state)
  "Handle the 'add-node-to-network' request in MESSAGE."
  ;; See AddNodeMessageClass.java.
  (define status/learn-ready 1)
  (define status/node-found 2)
  (define status/adding-slave 3)                 ;XXX: despicable terminology
  (define status/adding-controller 4)
  (define status/protocol-done 5)
  (define status/done 6)
  (define status/failed 7)

  (define (payload->command-classes payload)
    ;; TODO: Factorize with 'read-command-classes'?
    (let ((basic (bytevector-u8-ref payload 4))
          (generic (bytevector-u8-ref payload 5))
          (specific (bytevector-u8-ref payload 6)))
      (let loop ((i 7)
                 (classes '()))
        (if (= i (bytevector-length payload))
            (reverse classes)
            (let ((integer (bytevector-u8-ref payload i)))
              (match (false-if-exception (integer->command-class integer))
                (#f    (loop (+ 1 i) classes))
                (class (loop (+ 1 i) (cons class classes)))))))))

  ;; TODO: Implement.
  (let* ((payload (serial-message-payload message))
         (status  (bytevector-u8-ref payload 1)))
    (cond ((= status status/learn-ready)
           (pk 'learn-ready)
           state)
          ((= status status/node-found)
           (pk 'node-found!)
           state)
          ((= status status/adding-slave)
           (let* ((id (bytevector-u8-ref payload 2))
                  (classes (payload->command-classes payload))
                  (node (node id #:command-classes classes)))
             (add-zwave-state-node
              (push-zwave-state-notification state
                                             `(included-node . ,node))
              (pk 'adding-slave node))))
          ((= status status/adding-controller)
           (pk 'adding-controller (bytevector-u8-ref payload 2))
           (let ((id (bytevector-u8-ref payload 2))
                 (classes (payload->command-classes payload)))
             (add-zwave-state-node
              (push-zwave-state-notification state
                                             `(included-controller . ,node))
              (pk 'adding-controller
                  (node id #:command-classes classes)))))
          ((= status status/protocol-done)
           (let* ((id   (bytevector-u8-ref payload 2))
                  (node (lookup-node state id)))
             (pk 'protocol-done id node)
             (push-zwave-state-notification state
                                            `(inclusion-protocol-done . ,node))))
          ((= status status/done)
           (pk 'done (bytevector-u8-ref payload 2))
           state)
          ((= status status/failed)
           (pk 'failed)
           (push-zwave-state-notification state 'inclusion-failed))
          (else
           (format (current-error-port) "unknown add-node status: ~s~%"
                   status)
           state))))

(define %response-handlers
  (vhash message-class
         (application-update => handle-application-update)
         (get-initial-data => handle-get-initial-data)
         (get-version => handle-get-version)
         (application-command-handler => handle-application-command-handler)
         (add-node-to-network => handle-add-node-to-network)))

(define (handle-response response state)
  "Return STATE updated according to RESPONSE."
  (let ((type (serial-message-type response)))
    (cond ((equal? (message-type ack) type)
           state)
          ((equal? (message-type nack) type)
           state)
          ((equal? (message-type can) type)
           state)
          (else
           (match (vhash-assoc (serial-message-class response)
                               %response-handlers)
             (#f
              (format (current-error-port)
                      "warning: no handler for response ~s~%"
                      response)
              state)
             ((_ . handle) (handle response state)))))))

(define (make-request message-class . args)
  "Return a message for a request of MESSAGE-CLASS with the given ARGS.
Some requests take no arguments while others require some arguments."
  (serial-message (message-type request)
                  message-class
                  (match (vhash-assoc message-class %request-payload)
                    (#f            #vu8())
                    ((_ . payload) (apply payload args)))))

(define* (bytevector-checksum bv #:optional (start 0))
  "Compute the checksum of BV, a bytevector, starting at offset START."
  (let loop ((i start)
             (sum #xff))
    (if (= i (bytevector-length bv))
        sum
        (loop (+ i 1)
              (logxor sum (bytevector-u8-ref bv i))))))

;; Quoth, openHAB: A ZWave serial message frame is made up as follows
;; Byte 0 : SOF (Start of Frame) 0x01
;; Byte 1 : Length of frame - number of bytes to follow
;; Byte 2 : Request (0x00) or Response (0x01)
;; Byte 3 : Message Class (see SerialMessageClass)
;; Byte 4+: Message Class data >> Message Payload
;; Byte x : Last byte is checksum

(define (write-serial-message message port)
  "Write MESSAGE to PORT."
  (cond ((equal? (serial-message-type message) (message-type nack))
         (put-u8 port (signaling-frame nack)))
        ((equal? (serial-message-type message) (message-type ack))
         (put-u8 port (signaling-frame ack)))
        ((equal? (serial-message-type message) (message-type can))
         (put-u8 port (signaling-frame can)))
        (else
         (let* ((len (+ (bytevector-length (serial-message-payload message))
                        (if (equal? (serial-message-type message)
                                    (message-type request))
                            5
                            4)))
                (bv  (make-bytevector len)))
           (bytevector-u8-set! bv 0
                               (signaling-frame->integer
                                (signaling-frame som)))
           (bytevector-u8-set! bv 1 (- len 2))
           (bytevector-u8-set! bv 2
                               (message-type->integer
                                (serial-message-type message)))
           (bytevector-u8-set! bv 3
                               (message-class->integer
                                (serial-message-class message)))
           (bytevector-copy! (serial-message-payload message) 0
                             bv 4
                             (bytevector-length
                              (serial-message-payload message)))
           ;; TODO: request callback id
           (bytevector-u8-set! bv (- len 1) 1)
           (bytevector-u8-set! bv (- len 1) (bytevector-checksum bv))

           (put-bytevector port bv)))))

(define (read-serial-message port)
  (let ((type (integer->signaling-frame (get-u8 port))))
    (cond ((equal? (signaling-frame ack) type)
           (serial-message (message-type ack) 0 #vu8()))
          ((equal? (signaling-frame nack) type)
           (serial-message (message-type nack) 0 #vu8()))
          ((equal? (signaling-frame can) type)
           (serial-message (message-type can) 0 #vu8()))
          ((equal? (signaling-frame som) type)
           (let* ((len   (get-u8 port))
                  (bv    (make-bytevector (+ len 2))))
             (bytevector-u8-set! bv 0 (signaling-frame->integer type))
             (bytevector-u8-set! bv 1 len)
             (get-bytevector-n! port bv 2 len)
             (let ((type    (if (zero? (bytevector-u8-ref bv 2))
                                (message-type request)
                                (message-type response)))
                   (class   (integer->message-class
                             (bytevector-u8-ref bv 3)))
                   (payload (make-bytevector (- len 4)))
                   (sum     (bytevector-u8-ref bv (- len 1))))
               (bytevector-copy! bv 4 payload 0 (- len 4))
               (bytevector-u8-set! bv (- len 1) 1)
               (unless (= sum (bytevector-checksum bv))
                 (error "invalid checksum"
                        (list sum (bytevector-checksum bv))))

               ;; Send an ACK.  If we don't do that, the controller will
               ;; resend the message three times.
               (put-u8 port (signaling-frame->integer
                             (signaling-frame ack)))

               (serial-message type class payload))))
          (else
           (error "unknown message frame" type)))))

;; (define (make-command node-id command-class . args)
;;   ;; TODO: Return a message for a command like BatteryGet.
;;   (serial-message (message-type request)
;;                   (message-class application-command-handler)
;;                   (u8-list->bytevector
;;                    (cons* 0 node-id
;;                           (command-class->integer command-class)
;;                           args))))

(define (initialize-zwave-state port)
  "Initialize ZWave state by sending a messages on PORT, and return the
state."
  (write-serial-message (make-request (message-class get-version))
                        port)
  (let loop ()
    (let* ((message (read-serial-message port))
           (state   (handle-response message %zwave-initial-state)))
      (if (eq? state %zwave-initial-state) ;did we get a mere 'ack' or similar?
          (loop)
          state))))

(define (open-zwave-serial-port file)
  (let ((port (open-file file "r+0")))
    ;; TODO: Open at 115200 baud 8N1.
    (put-u8 port (signaling-frame->integer (signaling-frame nack)))
    port))