basic functionality is working

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) ()
+(define-condition bad-path (user-error)
-  (:report "sysfs interface doesn't exist"))
+  ((interface :initarg  :interface
-;;
+	      :reader    interface)
-;; (define-condition write-error (user-error) ()
+   (path      :initform *sysfs-firmware*
-;;   (:report "Writing."))
+	      :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)
+(defun firmware-file (interface)
-  ()
+  (merge-pathnames interface *sysfs-firmware*))
-  (with-open-file))
+
+(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))
+  (let* ((arg       (read-from-string arg))
-	(args      (cdr arg)))
+	 (subsystem (car arg))
-    (case subsystem
+	 (args      (cdr arg))
-      ;; turn LED on or off
+	 (result
-      (:led nil)
+	   (progn
+	     (case subsystem
+	       ;; turn LED on or off
+	       (:led (set-led args))
 
-      ;; set the color of the LED
+	       ;; set the color of the LED
-      (:rgb nil)
+	       (:rgb (set-led-color args))
 
-      ;; keeb is lit
+	       ;; keeb is lit
-      (:kbl nil)
+	       (:kbl (set-keyboard-backlight args))
 
-      ;; battery info
+	       ;; battery info
-      (:batt nil)
+	       (:batt (battery))
 
-      ;; firmware version
+	       ;; firmware version
-      (:fw-version nil)
+	       (:fw-version (read-interface-as-string "fw_version"))
 
-      ;; not handled:
+	       ;; not handled:
-      ;; - fw_update
+	       ;; - fw_update
-      ;; - last_keypress
+	       ;; - last_keypress
-      ;; - rewake_timer
+	       ;; - rewake_timer
-      ;; - startup_reason
+	       ;; - startup_reason
-      )
+	       (otherwise (list-commands))))))
-    ))
+    (when result
+      (cons subsystem result))))
 
 #|
-battery_percent  fw_version          led_blue      startup_reason
+Available interfaces:
-battery_raw      keyboard_backlight  led_green
+
-battery_volts    last_keypress       led_red
+  battery_percent  fw_version          led_blue      startup_reason
-fw_update        led                 rewake_timer
+  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)
+  (println
-;  (map nil #'beepberry arguments)
+   (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."
+		     :help "Display help and exit."
-    :long "help"
+		     :long "help"
-    :short #\h
+		     :short #\h
-    :reduce (constantly t)))
+		     :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 #'last-option
-		     :reduce #'adopt:collect))
+		     :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*)
+   (multiple-value-bind (arguments options)
-     …					; Handle options.
+       (adopt:parse-options-or-exit *ui*)
-     (handler-case (run arguments)
+     (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))))))

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