diff --git a/beepy.lisp b/beepy.lisp index a375332..1cebaa5 100644 --- a/beepy.lisp +++ b/beepy.lisp @@ -9,64 +9,262 @@ (in-package :beepy) ;;;; Configuration ----------------------------------------------- -(defparameter *sysfs-firmware* #P "/sys/firmware/beepy") +(defparameter *sysfs-firmware* "/sys/firmware/beepy/") ;;;; Errors ------------------------------------------------------ (define-condition user-error (error) ()) -(define-condition bad-path (user-error) () - (:report "sysfs interface doesn't exist")) -;; -;; (define-condition write-error (user-error) () -;; (:report "Writing.")) +(define-condition bad-path (user-error) + ((interface :initarg :interface + :reader interface) + (path :initform *sysfs-firmware* + :reader fw-path)) + (:report (lambda (condition stream) + (format stream + "sysfs interface '~a' doesn't exist (in ~a)" + (interface condition) + (fw-path condition))))) +(define-condition non-numeric-interface (bad-path) + ((value :initarg :value + :reader value)) + (:report (lambda (condition stream) + (format stream + "interface ~a~a should be numeric, but is ~a (~a)" + (pathname (interface condition)) + (interface condition) + (type-of (value condition)) + (value condition))))) + +(define-condition non-numeric-value (user-error) + ((value :initarg :value + :reader value)) + (:report (lambda (condition stream) + (format stream + "a numeric value is expected, but a ~a value was provided (value was ~a)" + (type-of (value condition)) + (value condition))))) + +(define-condition non-boolean-value (user-error) + ((value :initarg :value + :reader value)) + (:report (lambda (condition stream) + (format stream + "a boolean value is expected, but a ~a value was provided (value was ~a)" + (type-of (value condition)) + (value condition))))) + +(define-condition invalid-color (user-error) + ((color :initarg :color + :reader color)) + (:report (lambda (condition stream) + (if (keywordp (color condition)) + (format stream + "keyword colors must be one of '(:red :green :blue)") + (format stream + "color should be a list of (r g b) in the range 0-255 (have ~a)" + (color condition)))))) + +(defun list-commands () + (format t "Available commands: + :led [t nil] --- turn the onboard LED on or off + :rgb r g b --- set the onboard LED's color + :rgb [:red :green :blue] + :kbl [t nil] --- turn the keyboard backlight on or off + :batt --- read the battery statistics + :fw-verison --- read the current firmware version +") + (uiop:quit)) ;;;; Down to business -------------------------------------------- -(defun write-to-file (pathname val) - () - (with-open-file)) +(defun firmware-file (interface) + (merge-pathnames interface *sysfs-firmware*)) + +(defun write-value-to-interface (interface val) + "Write the numeric value VAL to the file for INTERFACE. + INTERFACE is a string mapped to a path by FIRMWARE-FILE. + VAL is a number (integer or float). + Signals BAD-PATH if the file cannot be written or INTERFACE is invalid." + (unless (stringp interface) + (error 'bad-path :interface interface)) + (unless (numberp val) + (error 'non-numeric-value :value val)) + (let* ((path (handler-case (firmware-file interface) + (error (e) + (declare (ignore e)) + (error 'bad-path :interface interface)))) + (truename (or (uiop:truename* path) + (error 'bad-path :interface interface)))) + (when (uiop:directory-pathname-p truename) + (error 'bad-path :interface interface)) + (handler-case + (with-open-file (stream truename + :direction :output + :if-exists :supersede + :if-does-not-exist :create + :element-type 'character + :external-format :utf-8) + (format stream "~A" val) + val) + (file-error (e) + (declare (ignore e)) + (error 'bad-path :interface interface))))) + +(defun read-interface-as-string (interface) + "Read the contents of a sysfs interface file as a trimmed string. + INTERFACE is a string identifier (e.g., 'sensor') mapped to a file + path. Returns a non-empty string with whitespace trimmed. Signals + BAD-PATH if the file doesn't exist, is a directory, is empty, or + cannot be read." + (unless (stringp interface) + (error 'bad-path :interface interface)) + (let* ((path (handler-case (firmware-file interface) + (error (e) + (declare (ignore e)) + (error 'bad-path :interface interface)))) + (truename (or (uiop:truename* path) + (error 'bad-path :interface interface)))) + (when (uiop:directory-pathname-p truename) + (error 'bad-path :interface interface)) + (handler-case + (with-open-file (stream truename + :direction :input + :element-type 'character + :external-format :utf-8) + (let ((content (string-trim + '(#\Space #\Tab #\Newline + #\Return #\Linefeed #\Page) + (read-line stream nil "")))) + (when (string= content "") + (error 'bad-path :interface interface)) + content)) + (file-error (e) + (declare (ignore e)) + (error 'bad-path :interface interface))))) + +(defun read-interface-numeric (path) + "Read a numeric form from the file at PATH, signaling non-numeric-interface if invalid. + Assumes read-interface-as-string returns trimmed file contents." + (let* ((string (read-interface-as-string path)) + (form (handler-case + (let ((*read-eval* nil)) ; Disable evaluation + (read-from-string string)) + (reader-error () + (error 'non-numeric-interface + :interface path + :value string))))) + (unless (numberp form) + (error 'non-numeric-interface + :interface path + :value form)) + form)) + +(defun battery () + (list + (cons :percent (read-interface-numeric "battery_percentage")) + (cons :raw (read-interface-numeric "battery_raw")) + (cons :volts (read-interface-numeric "battery_volts")))) + +(defun println (arg) + (print arg) + (terpri)) + +(defvar *rgb-pure* + '((:red (255 0 0)) + (:green (0 255 0)) + (:blue (0 0 255)))) + +(defun in-range (number low high) + (and + (<= number high) + (>= number low))) + +(defun uint8p (n) + (and (integerp n) + (in-range n 0 255))) + +(defun validate-rgb (rgb) + (or + (and (keywordp rgb) + (assoc rgb *rgb-pure*)) + (and (listp rgb) + (= (length rgb) 3) + (every #'uint8p rgb)))) + +(defun get-color (color) + (when (validate-rgb color) + (if (keywordp color) + (cadr (assoc color *rgb-pure*)) + color))) + +(defun set-led (state) + (unless (typep state 'boolean) + (error 'non-boolean-value :value state)) + (let ((state-number (if state 1 0))) + (write-value-to-interface "led" state-number))) + +(defun set-led-color (rgb) + (println rgb) + (let ((rgb (get-color rgb))) + (println rgb) + (unless rgb + (error 'invalid-color :color rgb)) + (destructuring-bind (r g b) rgb + (list + (write-value-to-interface "led_red" r) + (write-value-to-interface "led_green" g) + (write-value-to-interface "led_blue" b))))) + +(defun set-keyboard-backlight (level) + (unless (uint8p level) + (error 'non-numeric-value :value level)) + (write-value-to-interface "keyboard_backlight" level)) (defun beepberry (arg) - (let ((subsystem (car arg)) - (args (cdr arg))) - (case subsystem - ;; turn LED on or off - (:led nil) + (let* ((arg (read-from-string arg)) + (subsystem (car arg)) + (args (cdr arg)) + (result + (progn + (case subsystem + ;; turn LED on or off + (:led (set-led args)) - ;; set the color of the LED - (:rgb nil) + ;; set the color of the LED + (:rgb (set-led-color args)) - ;; keeb is lit - (:kbl nil) + ;; keeb is lit + (:kbl (set-keyboard-backlight args)) - ;; battery info - (:batt nil) + ;; battery info + (:batt (battery)) - ;; firmware version - (:fw-version nil) + ;; firmware version + (:fw-version (read-interface-as-string "fw_version")) - ;; not handled: - ;; - fw_update - ;; - last_keypress - ;; - rewake_timer - ;; - startup_reason - ) - )) + ;; not handled: + ;; - fw_update + ;; - last_keypress + ;; - rewake_timer + ;; - startup_reason + (otherwise (list-commands)))))) + (when result + (cons subsystem result)))) #| -battery_percent fw_version led_blue startup_reason -battery_raw keyboard_backlight led_green -battery_volts last_keypress led_red -fw_update led rewake_timer +Available interfaces: + + battery_percent fw_version led_blue startup_reason + battery_raw keyboard_backlight led_green + battery_volts last_keypress led_red + fw_update led rewake_timer |# - (defun run (arguments) - (format t "arguments: ~a~%" arguments) -; (map nil #'beepberry arguments) - ) + (println + (remove-if #'null (map 'list #'beepberry arguments)))) ;;;; User Interface ---------------------------------------------- (defmacro exit-on-ctrl-c (&body body) @@ -75,10 +273,21 @@ fw_update led rewake_timer (defparameter *option-help* (adopt:make-option 'help - :help "Display help and exit." - :long "help" - :short #\h - :reduce (constantly t))) + :help "Display help and exit." + :long "help" + :short #\h + :reduce (constantly t))) + +(adopt:defparameters (*option-debug* *option-no-debug*) + (adopt:make-boolean-options 'debug + :long "debug" + :short #\d + :help "Enable the Lisp debugger." + :help-no "Disable the Lisp debugger (the default).")) + +(defun last-option (prev new) + (declare (ignore prev)) + new) (defparameter *option-firmware-path* (adopt:make-option 'sysfs-path @@ -90,14 +299,28 @@ fw_update led rewake_timer :long "path" :short #\p :initial-value *sysfs-firmware* - :key #'make-pathname - :reduce #'adopt:collect)) + :reduce #'last-option + :key #'uiop:ensure-directory-pathname)) (adopt:define-string *help-text* "beepy takes commands, each of which is a list. For example, '(:led t) (:rgb 127 0 0).") -(adopt:define-string *extra-manual-text* "") +(adopt:define-string *extra-manual-text* "Available commands: + :led [t nil] --- turn the onboard LED on or off + :rgb r g b --- set the onboard LED's color + :rgb [:red :green :blue] + :kbl [t nil] --- turn the keyboard backlight on or off + :batt --- read the battery statistics + :fw-verison --- read the current firmware version + + The battery returns an assoc list of values: + '((:percent . 67) (:raw . 2312) (:volts . 3.885)) + + The firmware version returns an assoc list with a single + key: + '((:fw-version \"3.4\")) +") (defparameter *examples* '(("Turn the LED on, showing red:" @@ -117,12 +340,31 @@ fw_update led rewake_timer :examples *examples* :contents (list *option-help* + *option-debug* + *option-no-debug* *option-firmware-path*))) +(defun configure (options) + (maphash + (lambda (key value) + (case key + ('sysfs-path + (progn + (setf *sysfs-firmware* value))))) + options)) + (defun toplevel () (sb-ext:disable-debugger) (exit-on-ctrl-c - (multiple-value-bind (arguments options) (adopt:parse-options-or-exit *ui*) - … ; Handle options. - (handler-case (run arguments) + (multiple-value-bind (arguments options) + (adopt:parse-options-or-exit *ui*) + (when (gethash 'debug options) + (sb-ext:enable-debugger)) + (handler-case + (cond + ((gethash 'help options) (adopt:print-help-and-exit *ui*)) + ((null arguments) (list-commands)) + (t (progn + (configure options) + (run arguments)))) (user-error (e) (adopt:print-error-and-exit e)))))) diff --git a/build-binary.sh b/build-binary.sh index 46e7e5b..c70bac5 100755 --- a/build-binary.sh +++ b/build-binary.sh @@ -2,6 +2,12 @@ set -euo pipefail +if [ "${1:-}" = "" ] +then + echo "[!] no lisp files provided, exiting." > /dev/stderr + exit 1 +fi + LISP=$1 NAME=$(basename "$1" .lisp) shift