A dbus.lisp => dbus.lisp +93 -0
@@ 0,0 1,93 @@
+;; dbus.lisp
+
+;; Copyright (c) 2023 Jeremiah LaRocco <jeremiah_larocco@fastmail.com>
+
+;; Permission to use, copy, modify, and/or distribute this software for any
+;; purpose with or without fee is hereby granted, provided that the above
+;; copyright notice and this permission notice appear in all copies.
+
+;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+
+(in-package :racebox-tools)
+
+(defun first-racebox-device ()
+ "Return the name of the first RaceBox Mini device found."
+ (dbt:managed-object-name (first (list-racebox-devices))))
+
+(defun is-racebox-device (object)
+ "Check if a bluetooth object is a RaceBox Mini device."
+ (and (dbt:is-bt-device object)
+ (let* ((attributes (dbt:managed-object-value object))
+ (properties (dbt:find-value attributes "org.bluez.Device1"))
+ (name (dbt:find-value properties "Name")))
+ (cl-ppcre:scan "^RaceBox Mini [0-9]+" name))))
+
+(defun list-racebox-devices ()
+ "Return a list of all known RaceBox Mini devices."
+ (remove-if-not #'is-racebox-device
+ (dbt:list-bt-objects)))
+
+(defun connect (&key (device-name (first-racebox-device)))
+ "Connect to a RaceBox."
+ (dbt:invoke-method-simple :system
+ "org.bluez"
+ device-name
+ "org.bluez.Device1"
+ "Connect"))
+
+(defun disconnect (&key (device-name (first-racebox-device)))
+ "Disconnect "
+ (dbt:invoke-method-simple :system
+ "org.bluez"
+ device-name
+ "org.bluez.Device1"
+ "Disconnect"))
+
+(defun read-metadata (&key (device-name (dbt:managed-object-name (first (list-racebox-devices)))))
+ "Return the type, serial number, firmware version, hardware version, and manufacturer."
+ (loop :for key :in '(:type :serial :firmware-version :hardware-version :manufacturer)
+ :for uuid :in '("00002a24-0000-1000-8000-00805f9b34fb"
+ "00002a25-0000-1000-8000-00805f9b34fb"
+ "00002a26-0000-1000-8000-00805f9b34fb"
+ "00002a27-0000-1000-8000-00805f9b34fb"
+ "00002a29-0000-1000-8000-00805f9b34fb")
+ :collecting (cons key
+ (dbt:to-string
+ (dbt:read-gatt-characteristic-by-uuid device-name
+ uuid)))))
+(defun read-raw-value (&key (device-name (dbt:managed-object-name (first (list-racebox-devices)))))
+ "Read an octet buffer containing the most recent reading from specified device."
+ (dbt:read-gatt-characteristic-by-uuid device-name
+ "6e400003-b5a3-f393-e0a9-e50e24dcca9e"))
+
+
+;; (dbus:define-dbus-object racebox-service
+;; (:path "/org/bluez/hci0/dev_D2_D6_A3_84_35_29/service000b/char000e"))
+;; (dbus:define-dbus-signal-handler (racebox-service (wat))
+;; wat)
+
+;; TODO Get notifications of incoming messages.
+;; (dbus:define-dbus-object racebox-listener-service
+;; (:path "/org/jl2/RaceBoxService"))
+
+;; (dbus:define-dbus-method (racebox-service ) () (:list)
+;; (:interface "org.jl2.RaceBoxService")
+;; (read-current-value))
+
+;; (dbus:define-dbus-signal-handler (my-service on-signal) ((s :string))
+;; (:interface "org.adeht.MyService")
+;; (format t "Got signal with arg ~S~%" s))
+
+;; (defun publish-example ()
+;; (handler-case
+;; (with-open-bus (bus (session-server-addresses))
+;; (format t "Bus connection name: ~A~%" (bus-name bus))
+;; (publish-objects bus))
+;; (end-of-file ()
+;; :disconnected-by-bus)))
A importers.lisp => importers.lisp +52 -0
@@ 0,0 1,52 @@
+;; importers.lisp
+
+;; Copyright (c) 2023 Jeremiah LaRocco <jeremiah_larocco@fastmail.com>
+
+;; Permission to use, copy, modify, and/or distribute this software for any
+;; purpose with or without fee is hereby granted, provided that the above
+;; copyright notice and this permission notice appear in all copies.
+
+;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+
+(in-package :racebox-tools)
+
+(defun read-csv-stream (stream)
+ "Read a stream of CSV data downloaded from the RaceBox service.
+Not yet implemented."
+ (cl-csv:read-csv stream))
+
+(defun read-csv-file (file-name)
+ "Read a CSV data file downloaded from the RaceBox service.
+Not yet implemented."
+ (with-input-from-file (inf file-name)
+ (read-csv-stream inf)))
+
+
+(defun read-vbo-stream (stream)
+ "Read a stream of CSV data downloaded from the RaceBox service.
+Not yet implemented."
+ stream)
+
+(defun read-vbo-file (file-name)
+ "Read a CSV data file downloaded from the RaceBox service.
+Not yet implemented."
+ (with-input-from-file (inf file-name)
+ (read-vbo-stream inf)))
+
+
+(defun read-gpx-stream (stream)
+ "Read a stream of GPX data downloaded from the RaceBox service.
+Not yet implemented."
+ stream)
+
+(defun read-gpx-file (file-name)
+ "Read a GPX data file downloaded from the RaceBox service.
+Not yet implemented."
+ (with-input-from-file (inf file-name)
+ (read-gpx-stream inf)))
A main.lisp => main.lisp +27 -0
@@ 0,0 1,27 @@
+;; main.lisp
+
+;; Copyright (c) 2023 Jeremiah LaRocco <jeremiah_larocco@fastmail.com>
+
+;; Permission to use, copy, modify, and/or distribute this software for any
+;; purpose with or without fee is hereby granted, provided that the above
+;; copyright notice and this permission notice appear in all copies.
+
+;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+
+(in-package :racebox-tools)
+
+
+
+(defun main (args)
+ (declare (ignorable args))
+ (connect)
+ (inspect (read-current-value))
+ (disconnect)
+ ;; TODO: What should main do?
+ 0)
A messages.lisp => messages.lisp +315 -0
@@ 0,0 1,315 @@
+;; messagesto.lisp
+
+;; Copyright (c) 2023 Jeremiah LaRocco <jeremiah_larocco@fastmail.com>
+
+;; Permission to use, copy, modify, and/or distribute this software for any
+;; purpose with or without fee is hereby granted, provided that the above
+;; copyright notice and this permission notice appear in all copies.
+
+;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+
+(in-package :racebox-tools)
+
+(eval-when
+ (:compile-toplevel
+ :load-toplevel
+ :execute)
+
+ ;; Based on "RaceBox Mini Data Message" section of the protocol documentation
+ (binary-types:define-binary-class ubx-header ()
+ ((header1 :accessor header1
+ :binary-type binary-types:u8)
+ (header2 :accessor header2
+ :binary-type binary-types:u8)
+ (message-class :accessor message-class
+ :binary-type binary-types:u8)
+ (message-id :accessor message-id
+ :binary-type binary-types:u8)
+ (payload-length :accessor payload-length
+ :binary-type binary-types:u16)))
+
+ (binary-types:define-binary-class racebox-mini-data-message ()
+ (
+ ;; milliseconds from GPS week start
+ (itow :accessor itow
+ :binary-type binary-types:u32)
+
+ (year :binary-type binary-types:u16)
+ (month :binary-type binary-types:u8)
+ (day :binary-type binary-types:u8)
+
+ (hour :binary-type binary-types:u8)
+ (minute :binary-type binary-types:u8)
+ (second :binary-type binary-types:u8)
+
+ (validity-flags :accessor validity-flags
+ :binary-type binary-types:u8)
+ (time-accuraccy :accessor time-accuracy
+ :binary-type binary-types:u32)
+ (nanosecond :binary-type binary-types:s32)
+
+ (fix-status :accessor fix-status
+ :binary-type binary-types:u8)
+ (fix-status-flags :accessor fix-status-flags
+ :binary-type binary-types:u8)
+ (date-time-flags :accessor date-time-flags
+ :binary-type binary-types:u8)
+ (number-of-svs :accessor number-of-svs
+ :binary-type binary-types:u8)
+
+ (longitude :accessor longitude
+ :binary-type binary-types:s32)
+ (latitude :accessor latitude
+ :binary-type binary-types:s32)
+
+ (wgs-altitude :accessor wgs-altitude
+ :binary-type binary-types:s32)
+ (msl-altitude :accessor msl-altitude
+ :binary-type binary-types:s32)
+
+ (horizontal-accuracy :accessor horizontal-accuracy
+ :binary-type binary-types:u32)
+ (vertical-accuracy :accessor vertical-accuracy
+ :binary-type binary-types:u32)
+
+ (speed :accessor rb-speed
+ :binary-type binary-types:s32)
+ (heading :accessor heading
+ :binary-type binary-types:s32)
+
+ (speed-accuracy :accessor speed-accuracy
+ :binary-type binary-types:u32)
+ (heading-accuracy :accessor heading-accuracy
+ :binary-type binary-types:u32)
+
+ (pdop :accessor pdop
+ :binary-type binary-types:u16)
+
+ (lat-lon-flags :accessor lat-lon-flags
+ :binary-type binary-types:u8)
+
+ (battery-status :accessor battery-status
+ :binary-type binary-types:u8)
+
+ (g-force-x :accessor g-force-x
+ :binary-type binary-types:s16)
+ (g-force-y :accessor g-force-y
+ :binary-type binary-types:s16)
+ (g-force-z :accessor g-force-z
+ :binary-type binary-types:s16)
+
+ (rotation-rate-x :accessor rotation-rate-x
+ :binary-type binary-types:s16)
+ (rotation-rate-y :accessor rotation-rate-y
+ :binary-type binary-types:s16)
+ (rotation-rate-z :accessor rotation-rate-z
+ :binary-type binary-types:s16))))
+
+(defun rbm-fix-status (msg)
+ (with-slots (fix-status) msg
+ (cond ((= 0 fix-status) :no-fix)
+ ((= 2 fix-status) :2d-fix)
+ ((= 3 fix-status) :3d-fix)
+ (t :unknown))))
+
+(defun rbm-timestamp (data-message)
+ "Get a `local-time:timestamp` at the time of data-message."
+ (with-slots (year month day hour minute second nanosecond) data-message
+ (local-time-duration:timestamp-duration+
+ ;; RaceBox nanoseconds can be negative, which isn't supported by
+ ;; localtime, so add the nanoseconds as a duration.
+ (local-time:encode-timestamp 0
+ second
+ minute
+ hour
+ day
+ month
+ year
+ :timezone local-time:+utc-zone+)
+ (local-time-duration:duration :nsec nanosecond))))
+
+(defun rbm-latitude (data-message)
+ (with-slots (latitude) data-message
+ (/ latitude
+ 100000.0)))
+
+(defun rbm-longitude (data-message)
+ (with-slots (longitude) data-message
+ (/ longitude
+ 100000.0)))
+
+(defun rbm-battery-status (data-message)
+ data-message)
+
+
+(defun rbm-speed-in-km-per-hour (data-message)
+ (with-slots (speed) data-message
+ ;; mm/s to km/h
+ (/ speed
+ (* 1000 1000)
+ (* 60 60)
+ 1.0)))
+
+(defun rbm-heading (data-message)
+ (with-slots (heading) data-message
+ (/ heading
+ 10000.0)))
+
+(defun rmb-wgs-altitude (data-message)
+ (with-slots (wgs-altitude) data-message
+ (/ wgs-altitude
+ (* 1000 1000)
+ 1.0)))
+
+(defun rbm-msl-altitude (data-message)
+ (with-slots (msl-altitude) data-message
+ (/ msl-altitude
+ (* 1000 1000)
+ 1.0)))
+
+(defun rbm-g-force-x (data-message)
+ (with-slots (g-force-x) data-message
+ (/ g-force-x
+ 1000
+ 1.0)))
+(defun rbm-g-force-y (data-message)
+ (with-slots (g-force-y) data-message
+ (/ g-force-y
+ 1000
+ 1.0)))
+(defun rbm-g-force-z (data-message)
+ (with-slots (g-force-z) data-message
+ (/ g-force-z
+ 1000
+ 1.0)))
+
+(defun rbm-rotation-rate-x (data-message)
+ (with-slots (rotation-rate-x) data-message
+ (/ rotation-rate-x
+ 100
+ 1.0)))
+(defun rbm-rotation-rate-y (data-message)
+ (with-slots (rotation-rate-y) data-message
+ (/ rotation-rate-y
+ 100
+ 1.0)))
+(defun rbm-rotation-rate-z (data-message)
+ (with-slots (rotation-rate-z) data-message
+ (/ rotation-rate-z
+ 100
+ 1.0)))
+
+(defstruct gps-message
+ (timestamp (local-time:now) :type local-time:timestamp)
+ (longitude 0.0 :type real)
+ (latitude 0.0 :type real)
+ (msl-altitude 0.0 :type real)
+ (wgs-altitude 0.0 :type real)
+ (speed 0.0 :type real)
+ (heading 0.0 :type real)
+ (g-force (vec3 0.0 0.0 0.0) :type vec3)
+ (rotation (vec3 0.0 0.0 0.0) :type vec3))
+
+
+(defun to-gps-message (data-message)
+ (with-slots (year month day hour minute second nanosecond
+ longitude latitude msl-altitude wgs-altitude speed heading
+ g-force-x g-force-y g-force-z
+ rotation-rate-x rotation-rate-y rotation-rate-z) data-message
+ (values (make-gps-message :timestamp (rbm-timestamp data-message)
+ :latitude (/ latitude
+ 10000000.0)
+ :longitude (/ longitude
+ 10000000.0)
+ :msl-altitude (/ msl-altitude
+ (* 1000.0))
+ :wgs-altitude (/ wgs-altitude
+ (* 1000.0))
+ :speed (/ speed
+ (* 1000 1000)
+ (* 60 60)
+ 1.0)
+ :heading (/ heading
+ 100000.0)
+ :g-force (vec3 (/ g-force-x
+ 1000.0)
+ (/ g-force-y
+ 1000.0)
+ (/ g-force-z
+ 1000.0))
+ :rotation (vec3 (/ rotation-rate-x
+ 100.0)
+ (/ rotation-rate-y
+ 100.0)
+ (/ rotation-rate-z
+ 100.0)))
+ data-message)))
+
+(defun compute-checksum (packet)
+ "Compute the checksum used by ubx messages."
+ (declare (optimize (speed 3) (safety 3) (debug 3) (space 3))
+ (type (simple-array (unsigned-byte 8)) packet))
+ (loop
+ :for ck-a fixnum = 0 :then (mod (+ ck-a (aref packet i))
+ 256)
+ :for ck-b fixnum = 0 :then (mod (+ ck-b ck-a)
+ 256)
+ :for i fixnum :from 2 :below (- (length packet) 2)
+ :finally (return (values ck-a ck-b))))
+
+
+(defun validate-checksum (raw-data)
+ "Validate the checksum of the raw-data from the RaceBox."
+ (let ((byte-count (length raw-data)))
+ (multiple-value-bind (check-byte1 check-byte2) (compute-checksum raw-data)
+ (declare (type (unsigned-byte 8) check-byte1 check-byte2))
+ (when (or (/= (aref raw-data (- byte-count 2)) check-byte1)
+ (/= (aref raw-data (- byte-count 1)) check-byte2))
+ (error "Checksum error! ~a ~a ~a" check-byte1 check-byte2 raw-data))
+ (values check-byte1 check-byte2))))
+
+(defun is-racebox-mini-message (header)
+ "Check if message has class 0xff and id 0x1"
+ (and (= #16rff
+ (the (unsigned-byte 8) (message-class header)))
+ (= #16r1
+ (the (unsigned-byte 8) (message-id header)))))
+
+(defun decode-packet (raw-data)
+ "Decode raw octet buffer from the gatt characteristic into a
+(values racebox-mini-data-message ubx-header check1 check2 octet-buffer)"
+
+ (declare (optimize (speed 0) (safety 3) (debug 3) (space 3))
+ (type (simple-array (unsigned-byte 8)) raw-data))
+
+ (when (zerop (length raw-data))
+ (return-from decode-packet nil))
+
+ (multiple-value-bind (check-byte1 check-byte2) (validate-checksum raw-data)
+ (let* ((binary-types:*endian* :little-endian)
+ (input-stream (flexi-streams:make-in-memory-input-stream raw-data))
+ (header (binary-types:read-binary 'ubx-header input-stream)))
+
+ (cond ((is-racebox-mini-message header)
+ (values (binary-types:read-binary 'racebox-mini-data-message input-stream)
+ header
+ check-byte1
+ check-byte2
+ raw-data))
+ (t
+ (values nil
+ header
+ check-byte1
+ check-byte2
+ raw-data))))))
+
+(defun read-current-value (&key (device-name (dbt:managed-object-name (first (list-racebox-devices)))))
+ "The current sensor value decoded as a (values racebox-mini-data-message ubx-header check1 check2 octet-buffer)"
+ (decode-packet
+ (read-raw-value :device-name device-name)))
M package.lisp => package.lisp +59 -2
@@ 18,9 18,10 @@
(:nicknames :rbt)
- (:use #:cl #:alexandria #:dbus-tools)
+ (:use #:cl #:alexandria #:3d-vectors #:dbus-tools)
(:export #:list-racebox-devices
#:is-racebox-device
+ #:first-racebox-device
#:connect
#:disconnect
@@ 32,8 33,64 @@
#:read-raw-value
#:decode-packet
- #:get-timestamp
+ #:rbm-battery-status
+
+ #:rbm-timestamp
+ #:rbm-latitude
+ #:rbm-longitude
+
+
+ #:rbm-speed
+ #:rbm-heading
+
+ #:rmb-wgs-altitude
+ #:rbm-msl-altitude
+
+ #:rbm-g-force-x
+ #:rbm-g-force-y
+ #:rbm-g-force-z
+
+ #:rbm-rotation-rate-x
+ #:rbm-rotation-rate-y
+ #:rbm-rotation-rate-z
+
+ #:rbm-fix-status
+ #:rbm-validity
+ #:rbm-accuracy
+ #:rbm-status-flags-valid-fix
+ #:rbm-status-flags-differential-corrections-applied
+ #:rbm-status-flags-power-state
+ #:rbm-status-flags-valid-heading
+ #:rbm-status-flags-carrier-phase-range-solution
+
+ #:rbm-datetime-flags-available-confirmation-of-date-time
+ #:rbm-datetime-flags-confirmed-utc-date-validity
+ #:rbm-datetime-flags-confirmed-utc-time-validity
+
+ #:rbm-lat-lon-valid
+ #:rbm-lat-lon-correction-age
+
+ #:gps-message
+ #:timestamp
+ #:longitude
+ #:latitude
+ #:msl-altitude
+ #:wgs-altitude
+ #:speed
+ #:heading
+ #:g-force
+ #:rotation
+
+ #:gps-message-timestamp
+ #:gps-message-longitude
+ #:gps-message-latitude
+ #:gps-message-msl-altitude
+ #:gps-message-wgs-altitude
+ #:gps-message-speed
+ #:gps-message-heading
+ #:gps-message-g-force
+ #:gps-message-rotation
;; Not yet implemented...
;; #:read-csv-stream
M racebox-tools.asd => racebox-tools.asd +8 -1
@@ 20,6 20,7 @@
:license "ISC"
:version "0.0.1"
:serial t
+
:depends-on (
#:alexandria
#:binary-types
@@ 30,7 31,13 @@
#:local-time-duration
#:sqlite
#:dbus-tools
+ #:3d-vectors
)
+
:components ((:file "package")
- (:file "racebox-tools"))
+ (:file "dbus")
+ (:file "messages")
+ (:file "importers")
+ (:file "main"))
+
:in-order-to ((test-op (test-op racebox-tools.test))))
D racebox-tools.lisp => racebox-tools.lisp +0 -246
@@ 1,246 0,0 @@
-;; racebox-tools.lisp
-
-;; Copyright (c) 2023 Jeremiah LaRocco <jeremiah_larocco@fastmail.com>
-
-;; Permission to use, copy, modify, and/or distribute this software for any
-;; purpose with or without fee is hereby granted, provided that the above
-;; copyright notice and this permission notice appear in all copies.
-
-;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
-;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
-;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
-;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
-;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
-;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
-;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
-
-(in-package :racebox-tools)
-
-(defun first-racebox ()
- "Return the name of the first RaceBox Mini device found."
- (dbt:managed-object-name (first (list-racebox-devices))))
-
-(defun is-racebox-device (object)
- "Check if a bluetooth object is a RaceBox Mini device."
- (and (dbt:is-bt-device object)
- (let* ((attributes (dbt:managed-object-value object))
- (properties (dbt:find-value attributes "org.bluez.Device1"))
- (name (dbt:find-value properties "Name")))
- (cl-ppcre:scan "^RaceBox Mini [0-9]+" name))))
-
-(defun list-racebox-devices ()
- "Return a list of all known RaceBox Mini devices."
- (remove-if-not #'is-racebox-device
- (dbt:list-bt-objects)))
-
-(defun connect (&key (device-name (first-racebox)))
- "Connect to a RaceBox."
- (dbt:invoke-method-simple :system
- "org.bluez"
- device-name
- "org.bluez.Device1"
- "Connect"))
-
-(defun disconnect (&key (device-name (first-racebox)))
- "Disconnect "
- (dbt:invoke-method-simple :system
- "org.bluez"
- device-name
- "org.bluez.Device1"
- "Disconnect"))
-
-(defun read-metadata (&key (device-name (dbt:managed-object-name (first (list-racebox-devices)))))
- "Return the type, serial number, firmware version, hardware version, and manufacturer."
- (loop :for key :in '(:type :serial :firmware-version :hardware-version :manufacturer)
- :for uuid :in '("00002a24-0000-1000-8000-00805f9b34fb"
- "00002a25-0000-1000-8000-00805f9b34fb"
- "00002a26-0000-1000-8000-00805f9b34fb"
- "00002a27-0000-1000-8000-00805f9b34fb"
- "00002a29-0000-1000-8000-00805f9b34fb")
- :collecting (cons key
- (dbt:to-string
- (dbt:read-gatt-characteristic-by-uuid device-name
- uuid)))))
-
-(eval-when
- (:compile-toplevel ; this top-level form will be executed by the
- ; file compiler
-
- :load-toplevel ; this top-level form will be executed at load-time
- ; of the compiled file
-
- :execute) ; executed whenever else
-
- ;; Based on "RaceBox Mini Data Message" section of the protocol documentation
- (binary-types:define-binary-class ubx-header ()
- ((header1 :accessor header1 :binary-type binary-types:u8)
- (header2 :accessor header2 :binary-type binary-types:u8)
- (message-class :accessor message-class :binary-type binary-types:u8)
- (message-id :accessor message-id :binary-type binary-types:u8)
- (payload-length :accessor payload-length :binary-type binary-types:u16)))
-
- (binary-types:define-binary-class racebox-mini-data-message ()
- (
- ;; milliseconds from GPS week start
- (itow :accessor itow :binary-type binary-types:u32)
-
- (year :binary-type binary-types:u16)
- (month :binary-type binary-types:u8)
- (day :binary-type binary-types:u8)
-
- (hour :binary-type binary-types:u8)
- (minute :binary-type binary-types:u8)
- (second :binary-type binary-types:u8)
-
- (validity-flags :accessor validity-flags :binary-type binary-types:u8)
- (time-accuraccy :accessor time-accuracy :binary-type binary-types:u8)
- (nanosecond :binary-type binary-types:s32)
-
- (fix-status :accessor fix-status :binary-type binary-types:u8)
- (date-time-flags :accessor date-time-flags :binary-type binary-types:u8)
- (number-of-svs :accessor number-of-svs :binary-type binary-types:u8)
-
- (longitude :accessor longitude :binary-type binary-types:s32)
- (latitude :accessor latitude :binary-type binary-types:s32)
-
- (wgs-altitude :accessor wgs-altitude :binary-type binary-types:s32)
- (msl-altitude :accessor msl-altitude :binary-type binary-types:s32)
-
- (horizontal-accuracy :accessor horizontal-accuracy :binary-type binary-types:u32)
- (vertical-accuracy :accessor vertical-accuracy :binary-type binary-types:u32)
-
- (speed :accessor rb-speed :binary-type binary-types:s32)
- (heading :accessor heading :binary-type binary-types:s32)
- (speed-accuracy :accessor speed-accuracy :binary-type binary-types:u32)
- (heading-accuracy :accessor heading-accuracy :binary-type binary-types:u32)
- (pdop :accessor pdop :binary-type binary-types:u16)
- (lat-lon-flags :accessor lat-lon-flags :binary-type binary-types:u8)
- (battery-status :accessor battery-status :binary-type binary-types:u8)
-
- (g-force-x :accessor g-force-x :binary-type binary-types:s16)
- (g-force-y :accessor g-force-y :binary-type binary-types:s16)
- (g-force-z :accessor g-force-z :binary-type binary-types:s16)
-
- (rotation-rate-x :accessor rotation-rate-x :binary-type binary-types:s16)
- (rotation-rate-y :accessor rotation-rate-y :binary-type binary-types:s16)
- (rotation-rate-z :accessor rotation-rate-z :binary-type binary-types:s16))))
-
-(defun get-timestamp (data-message)
- "Get a `local-time:timestamp` at the time of data-message."
- (with-slots (year month day hour minute second nanosecond) data-message
- (local-time-duration:timestamp-duration+
- ;; RaceBox nanoseconds can be negative, which isn't supported by
- ;; localtime, so add the nanoseconds as a duration.
- (local-time:encode-timestamp 0
- second
- minute
- hour
- day
- month
- year
- :timezone local-time:+utc-zone+)
- (local-time-duration:duration :nsec nanosecond))))
-
-(defun read-raw-value (&key (device-name (dbt:managed-object-name (first (list-racebox-devices)))))
- "Read an octet buffer containing the most recent reading from specified device."
- (dbt:read-gatt-characteristic-by-uuid device-name
- "6e400003-b5a3-f393-e0a9-e50e24dcca9e"))
-
-(defun read-current-value (&key (device-name (dbt:managed-object-name (first (list-racebox-devices)))))
- "The current sensor value decoded as a (values racebox-mini-data-message ubx-header check1 check2 octet-buffer)"
- (decode-packet
- (read-raw-value :device-name device-name)))
-
-
-(defun compute-checksum (packet)
- "Compute the checksum used by ubx messages."
- (declare (optimize (speed 3) (safety 0) (debug 0) (space 3))
- (type (simple-array (unsigned-byte 8)) packet))
- (loop :for ck-a fixnum = 0 :then (mod (+ ck-a (aref packet i)) 256)
- :for ck-b fixnum = 0 :then (mod (+ ck-b ck-a) 256)
- :for i fixnum :from 2 :below (- (length packet) 2)
- :finally (return (values ck-a ck-b))))
-
-(defun decode-packet (raw-data)
- "Decode raw octet buffer from the gatt characteristic into a
-(values racebox-mini-data-message ubx-header check1 check2 octet-buffer)"
- (declare (optimize (speed 3) (safety 0) (debug 0) (space 3))
- (type (simple-array (unsigned-byte 8)) raw-data))
- (let ((byte-count (length raw-data)))
- (multiple-value-bind (check-byte1 check-byte2) (compute-checksum raw-data)
- (declare (type (unsigned-byte 8) check-byte1 check-byte2))
- (when (or (/= (aref raw-data (- byte-count 2)) check-byte1)
- (/= (aref raw-data (- byte-count 1)) check-byte2))
- (error "Checksum error! ~a ~a ~a" check-byte1 check-byte2 raw-data))
- (let* ((binary-types:*endian* :little-endian)
- (input-stream (flexi-streams:make-in-memory-input-stream raw-data))
- (header (binary-types:read-binary 'ubx-header input-stream)))
- (cond ((and (= (the (unsigned-byte 8) (message-class header)) #16rff)
- (= (the (unsigned-byte 8) (message-id header)) #16r1))
- (let ((message (binary-types:read-binary 'racebox-mini-data-message input-stream)))
- (values message header check-byte1 check-byte2 raw-data)))
- (t
- (values nil header check-byte1 check-byte2 raw-data)))))))
-
-;; TODO Get notifications of incoming messages.
-;; (dbus:define-dbus-object racebox-listener-service
-;; (:path "/org/jl2/RaceBoxService"))
-
-;; (dbus:define-dbus-method (racebox-service ) () (:list)
-;; (:interface "org.jl2.RaceBoxService")
-;; (read-current-value))
-
-;; (dbus:define-dbus-signal-handler (my-service on-signal) ((s :string))
-;; (:interface "org.adeht.MyService")
-;; (format t "Got signal with arg ~S~%" s))
-
-;; (defun publish-example ()
-;; (handler-case
-;; (with-open-bus (bus (session-server-addresses))
-;; (format t "Bus connection name: ~A~%" (bus-name bus))
-;; (publish-objects bus))
-;; (end-of-file ()
-;; :disconnected-by-bus)))
-
-;; TODO: Add utility functions for importing downloaded CSV, GPX, and .vbo files.
-
-(defun read-csv-stream (stream)
- "Read a stream of CSV data downloaded from the RaceBox service.
-Not yet implemented."
- (cl-csv:read-csv stream))
-
-(defun read-csv-file (file-name)
- "Read a CSV data file downloaded from the RaceBox service.
-Not yet implemented."
- (with-input-from-file (inf file-name)
- (read-csv-stream inf)))
-
-
-(defun read-vbo-stream (stream)
- "Read a stream of CSV data downloaded from the RaceBox service.
-Not yet implemented."
- stream)
-
-(defun read-vbo-file (file-name)
- "Read a CSV data file downloaded from the RaceBox service.
-Not yet implemented."
- (with-input-from-file (inf file-name)
- (read-vbo-stream inf)))
-
-
-(defun read-gpx-stream (stream)
- "Read a stream of GPX data downloaded from the RaceBox service.
-Not yet implemented."
- stream)
-
-(defun read-gpx-file (file-name)
- "Read a GPX data file downloaded from the RaceBox service.
-Not yet implemented."
- (with-input-from-file (inf file-name)
- (read-gpx-stream inf)))
-
-
-(defun main (args)
- (declare (ignorable args))
- ;; TODO: What should main do?
- 0)