371 lines
11 KiB
Common Lisp
371 lines
11 KiB
Common Lisp
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(ql:quickload '(:with-user-abort :uiop :adopt) :silent t))
|
|
|
|
|
|
(defpackage :beepy
|
|
(:use :cl)
|
|
(:export :toplevel *ui*))
|
|
|
|
(in-package :beepy)
|
|
|
|
;;;; Configuration -----------------------------------------------
|
|
(defparameter *sysfs-firmware* "/sys/firmware/beepy/")
|
|
|
|
;;;; Errors ------------------------------------------------------
|
|
(define-condition user-error (error) ())
|
|
|
|
(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 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* ((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 (set-led-color args))
|
|
|
|
;; keeb is lit
|
|
(:kbl (set-keyboard-backlight args))
|
|
|
|
;; battery info
|
|
(:batt (battery))
|
|
|
|
;; firmware version
|
|
(:fw-version (read-interface-as-string "fw_version"))
|
|
|
|
;; not handled:
|
|
;; - fw_update
|
|
;; - last_keypress
|
|
;; - rewake_timer
|
|
;; - startup_reason
|
|
(otherwise (list-commands))))))
|
|
(when result
|
|
(cons subsystem result))))
|
|
|
|
#|
|
|
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)
|
|
(println
|
|
(remove-if #'null (map 'list #'beepberry arguments))))
|
|
|
|
;;;; User Interface ----------------------------------------------
|
|
(defmacro exit-on-ctrl-c (&body body)
|
|
`(handler-case (with-user-abort:with-user-abort (progn ,@body))
|
|
(with-user-abort:user-abort () (sb-ext:exit :code 130))))
|
|
|
|
(defparameter *option-help*
|
|
(adopt:make-option 'help
|
|
: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
|
|
:parameter "STRING"
|
|
:help "Look for the sysfs interface at path"
|
|
:manual (format nil "~
|
|
This must be a path to a valid beepy sysfs. The default is ~a."
|
|
*sysfs-firmware*)
|
|
:long "path"
|
|
:short #\p
|
|
:initial-value *sysfs-firmware*
|
|
: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* "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:"
|
|
. "'(:led t) '(:rgb 127")
|
|
("Turn the LED on, showing green (alternate syntax):"
|
|
. "'(:led t) '(:rgb :green)")
|
|
("Return the firmware version:"
|
|
. "'(:fw-version)")))
|
|
|
|
(defparameter *ui*
|
|
(adopt:make-interface
|
|
:name "beepy"
|
|
:usage "[OPTIONS] commands..."
|
|
:summary "interface with beepy's sysfs interface"
|
|
:help *help-text*
|
|
:manual (format nil "~A~2%~A" *help-text* *extra-manual-text*)
|
|
: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*)
|
|
(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))))))
|