;;;; This file is part of Guile Netlink

;;;;

;;;; Copyright (C) 2025 Dale Mellor

;;;; Copyright (C) 2025 Julien Lepiller <julien@lepiller.eu>

;;;; 

;;;; This library 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.

;;;;

;;;; This library 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 this library.  If not, see <https://www.gnu.org/licenses/>.

(define-module (netlink acpi)

  #:use-module (ice-9 match)

  #:use-module ((netlink connection)  #:prefix NL:)

  #:use-module ((netlink constant)    #:prefix NL:)

  #:use-module ((netlink data)        #:prefix NL:)

  #:use-module ((netlink deserialize) #:prefix NL:)

  #:use-module ((netlink message)     #:prefix NL:)

  #:use-module ((netlink route)       #:prefix NL:)

  #:use-module ((netlink route attrs) #:prefix NL:)

  #:use-module (rnrs bytevectors)

  #:use-module (rnrs bytevectors gnu)  ;; For bytevector-slice.

  #:export (

    ;; Return accessor procedures to a port listening for power state change

    ;; notifications from the kernel.  The application SHOULD (close-port _)

    ;; on it when it becomes of no further use (the common exception being

    ;; when the port is required for the entire lifetime of the application).

    ;;

    ;; This procedure returns three procedures (use (ice-9 receive) to unpack

    ;; them): (read-select), (process-data ACTION), and (close-connection).

    ;; The ACTION argument to the second procedure should be a procedure like

    ;; (action EVENT), and the four procedures below can be used to extract

    ;; data from the EVENT object.

    connect-events  ;;   > [ read-selector  process-data  close-connection ]

    ;; The above takes a procedure ACTION, of acpi-event; the following

    ;; procedures allow for the extraction of data items from such an object.

    event-device-class  ;;  < event   > string

    event-bus-id        ;;  < event   > string

    event-kind          ;;  < event   > u32

    event-data))        ;;  < event   > u32

;; GLOSSARY

;;

;;  ACPI : advanced configuration and power interface (firmware standard)

;;  ATTR : attribute

;;  BV   : bytevector

;;  GENL : generic netlink

;;  MSG  : message

;;  NL   : netlink

;;  POS  : position (byte offset)

;; These are privately defined for the kernel in drivers/acpi/event.c.

;;

;; The terminal nulls are needed because serializing string types does not

;; work properly.

(define linux/ACPI_GENL_FAMILY_NAME      "acpi_event\0")

(define linux/ACPI_GENL_MCAST_GROUP_NAME "acpi_mc_group\0")

(define linux/ACPI_GENL_ATTR_EVENT       1)

(define linux/ACPI_GENL_CMD_EVENT        1)

(define (bytevector-string-length bv max)

  "Return the position of the first null byte in the bytevector @var{bv}, up to

a possible @var{max} value."

  (let loop ((i 0))

    (if (or (eq? max i)

            (eq? 0 (array-ref bv i)))

        i

        (loop (1+ i)))))

(define (bytevector->string bv maxlen)

  "Return the string corresponding to the null-terminated bytes in bytevector

@var{bv}, which can hold no more than @var{maxlen} bytes."

  (utf8->string (bytevector-slice bv 0 (bytevector-string-length bv maxlen))))

;; This type, genlmsghdr, is defined at

;; [kernel]/include/uapi/linux/genetlink.h.

(NL:define-data-type

  genlmsghdr

  length-genlmsghdr

  serialize-genlmsghdr

  (cmd genlmsghdr-cmd genlmsghdr-type-cmd)  ;; Single byte linux/CTRL_CMD_*.

  (attrs genlmsghdr-attrs genlmsghdr-type-attrs))  ;; Attributes.

(define (length-genlmsghdr msg)

  "The length of the serialization of this header and its attributes on the wire."

  (+ 4 (NL:route-attr-list-size (genlmsghdr-type-attrs msg))))

(define (serialize-genlmsghdr msg pos bv)

  "Serialize @var{msg} to @var{pos} in the bytevector @var{bv}."

  (match msg

    (($ genlmsghdr-type cmd attrs)

     (bytevector-u8-set! bv pos cmd)

     (bytevector-u8-set! bv (1+ pos) 1)  ;; Version.

     (bytevector-u16-set! bv (+ 2 pos) 0 (native-endianness)) ;; Reserved.

     (NL:serialize-route-attr-list attrs (+ 4 pos) bv))))  ;; Payload

(define (deserialize-genlmsghdr decoder bv pos)

  (make-genlmsghdr (bytevector-u8-ref bv pos)

                   (NL:deserialize-attr-list 'genl-id-attr

                                             decoder

                                             bv

                                             (+ pos 4))))

(NL:define-data-type

  mcast-groups

  length-mcast-groups

  serialize-mcast-groups

  (attrs mcast-groups-attrs mcast-groups-type-attrs))

(define (length-mcast-groups msg)

  (+ 4 (NL:route-attr-list-size (mcast-groups-type-attrs msg))))

(define (serialize-mcast-groups msg pos bv)

  (match msg

    (($ mcast-groups-type attrs)

     (bytevector-u16-set! bv

                          pos

                          (length-mcast-groups msg)

                          (native-endianness))

     (bytevector-u16-set! bv (+ 2 pos) 1 (native-endianness))

     (NL:serialize-route-attr-list attrs (+ 4 pos) bv))))

(define (deserialize-mcast-groups decoder bv pos)

  (let* ((length (bytevector-u16-ref bv pos (native-endianness)))

         (buffer (make-bytevector (- length 4))))

    (bytevector-copy! bv (+ pos 4) buffer 0 (- length 4))

    (let ((ret

           (make-mcast-groups

            (NL:deserialize-attr-list 'mcast-groups-attr

                                      decoder

                                      buffer

                                      0))))

      ret)))

(NL:define-data-type

  acpi-event

  (lambda (msg) 44)

  serialize-acpi-event

  ;; This serializes like a char[20].

  (device-class  event-device-class  event-type-device-class)

  ;; This serializes like a char[15], followed by a slack byte(!).

  (bus-id        event-bus-id        event-type-bus-id)

  (kind          event-kind          event-type-kind)

  (data          event-data          event-type-data))

;; We don't need to do this -- but it does help us understand what is

;; happening.

(define (serialize-acpi-event msg pos bv)

  (match msg

      (($ acpi-event-type device-class bus-id kind data)

       (bytevector-copy! bv pos (make-bytevector 36 0) 0 36)

       (let ((source (string->utf8 (event-type-device-class msg))))

         (bytevector-copy! source 0 bv pos (bytevector-length source)))

       (let ((source (string->utf8 (event-type-bus-id msg))))

         (bytevector-copy! source 0 bv (+ pos 20) (bytevector-length source)))

       (bytevector-u32-set! bv (+ pos 36) kind (native-endianness))

       (bytevector-u32-set! bv (+ pos 40) data (native-endianness)))))

;; This fluid will be filled with the application-supplied procedure to act on

;; ACPI event messages received from the kernel, before the following

;; deserializer gets invoked.

(define %action (make-parameter '()))

(define (deserialize-acpi-event decoder bv pos)

  (let ((ret (make-acpi-event

               (bytevector->string (bytevector-slice bv pos 20) 20)

               (bytevector->string (bytevector-slice bv (+ pos 20) 15) 15)

               (bytevector-u32-ref bv (+ pos 36) (native-endianness))

               (bytevector-u32-ref bv (+ pos 40) (native-endianness)))))

    ((%action) ret)

    ret))

;; These are filled in as a side effect of parsing the return from the

;; NETLINK_GENERIC/GENL_ID_CTRL/CTRL_CMD_GETFAMILY message from the kernel, in

;; the two specialized deserializers immediately below.

(define %genl-acpi-family-id (make-parameter 0))

(define %acpi-mcast-group-id (make-parameter 0))

(define (deserialize-mcast-grp-id decoder bv pos)

  (let ((ret (NL:deserialize-route-attr-data-u32 decoder bv pos)))

    (%acpi-mcast-group-id (NL:nl-data-data ret))

    ret))

(define (deserialize-genl-family-id decoder bv pos)

  (let ((ret (NL:deserialize-route-attr-data-u16 decoder bv pos)))

    (%genl-acpi-family-id (NL:nl-data-data ret))

    ret))

(define genl-decoder

  `(;; This is the decoding lookup table used by

    ;; NL:receive-and-decode-message.

    (message ,NL:deserialize-message

             ;; This will catch the final acknowledgement, which we force onto

             ;; all return messages.

             ,@NL:%default-message-decoder

             (,NL:GENL_ID_CTRL . ,deserialize-genlmsghdr))

    ;; This table is used by deserialize-genlmsghdr above.

    (genl-id-attr

       ,(NL:deserialize-route-attr 'genl-id-attr)

       (,NL:CTRL_ATTR_FAMILY_ID . ,deserialize-genl-family-id)

       (,NL:CTRL_ATTR_MCAST_GROUPS . ,deserialize-mcast-groups)

       (default . ,NL:deserialize-route-attr-data-bv))

    ;; This table is used by deserialize-mcast-groups above.

    (mcast-groups-attr

      ,(NL:deserialize-route-attr 'mcast-groups-attr)

      (,NL:CTRL_ATTR_MCAST_GRP_NAME . ,NL:deserialize-route-attr-data-string)

      (,NL:CTRL_ATTR_MCAST_GRP_ID . ,deserialize-mcast-grp-id))))

(define  (connect-events)

  "Return three procedures to manage a connected listener for kernel Netlink ACPI messages.

The procedures are, nominally (but you can call them what you want),

  - (read-selector) which returns an object which can be used in the read

       list of a select procedure call.

  - (process-data ACTION) which applies ACTION to any ACPI events which

       the kernel ʼcasts to us.  The ACTION procedure should be of the

       form (action event), where EVENT will be an acpi-event object.

  - (close-socket) which closes the connection to the kernel.

The application SHOULD (close-socket) when it becomes of no further use (the

common exception being when the connection is required for the entire lifetime

of the application)."

  (define socket (NL:connect NL:NETLINK_GENERIC

                             (NL:get-addr NL:AF_NETLINK 0 0)

                             #:flags SOCK_NONBLOCK))

  (define msg (NL:make-message

                NL:GENL_ID_CTRL  ;; Sub-system

                NL:NLM_F_REQUEST ;; Flags

                1                   ;; sequence number

                0                   ;; kernel PID

                (make-genlmsghdr

                  NL:CTRL_CMD_GETFAMILY

                  (list

                    (NL:make-route-attr

                      NL:CTRL_ATTR_FAMILY_NAME

                      (NL:make-string-route-attr

                        linux/ACPI_GENL_FAMILY_NAME))))))

  (NL:send-msg msg socket)

  ;;  These get filled in just by calling NL:receive-and-decode-message!

  (parameterize ((%genl-acpi-family-id 0)

                 (%acpi-mcast-group-id 0))

    ;;  We donʼt actually care about the decoded message; we are only

    ;;  interested in the side-effect of the decoding of furnishing the fluids

    ;;  %genl-acpi-family-id and %acpi-mcast-group-id.

    (NL:receive-and-decode-msg socket genl-decoder)

    ;;  Subscribe the socket to ACPI broadcasts.

    (NL:add-socket-membership socket (%acpi-mcast-group-id))

    (values

      ;; Get the read-select object.

      (lambda () socket)

      ;; Process data at the port, passing it to (action acpi-event).

      (let ((genl-acpi-family-id (%genl-acpi-family-id)))

        (lambda (action)

          (process-event-port socket genl-acpi-family-id action)))

      ;; Close the connection.

      (lambda () (close-port socket)))))

(define  (process-event-port socket acpi-family-id action)

  "Read Netlink messages from socket and apply ACTION to any acpi-event objects found."

  (parameterize ((%action action))

    ;;  Once again, we are not interested in the actual decoded message, we

    ;;  just use the side-effect of having ACTION run every time we decode an

    ;;  acpi-event object (it happens during the deserialize-acpi-event).

    (NL:receive-and-decode-msg

      socket

      `(;; The table used directly by NL:receive-and-decode-msg.

        (message      ,NL:deserialize-message

                      ,@NL:%default-message-decoder

                      (,acpi-family-id . ,deserialize-genlmsghdr)

                      (default . ,NL:deserialize-message-header))

        ;; The table used by deserialize-genlmsghdr above.

        (genl-id-attr ,(NL:deserialize-route-attr 'genl-id-attr)

                      (,linux/ACPI_GENL_ATTR_EVENT . ,deserialize-acpi-event)

                      (default . ,NL:deserialize-route-attr-data-bv))

        ;; Needed to decode headers repeated in error messages.

        (message-hdr  ,NL:deserialize-message-header)))))