basic functionality is working
This commit is contained in:
parent
fac3a22dfe
commit
25662a9120
336
beepy.lisp
336
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))))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue