Add utmp logger service.

1 files changed, 136 insertions, 0 deletions

diff --git a/arunisaac/utmp-logger.scm b/arunisaac/utmp-logger.scm
new file mode 100644
index 0000000..127cae2
--- /dev/null
+++ b/arunisaac/utmp-logger.scm
@@ -0,0 +1,136 @@
+(define-module (arunisaac utmp-logger)
+  #:use-module ((gnu packages admin) #:select (shadow))
+  #:use-module ((gnu packages guile) #:select (guile-json-4))
+  #:use-module ((gnu packages hardware) #:select (utmp-cli))
+  #:use-module (gnu build linux-container)
+  #:use-module (gnu services)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu system accounts)
+  #:use-module (gnu system file-systems)
+  #:use-module (gnu system shadow)
+  #:use-module (guix gexp)
+  #:use-module (guix least-authority)
+  #:use-module (guix packages)
+  #:use-module (guix records)
+  #:export (utmp-logger-service-type
+            utmp-logger-configuration
+            utmp-logger-configuration?
+            utmp-logger-configuration-utmp-cli
+            utmp-logger-configuration-serial-port
+            utmp-logger-configuration-data-directory
+            utmp-logger-configuration-minutes))
+
+(define-record-type* <utmp-logger-configuration>
+  utmp-logger-configuration make-utmp-logger-configuration
+  utmp-logger-configuration?
+  (utmp-cli utmp-logger-configuration-utmp-cli
+            (default utmp-cli))
+  (serial-port utmp-logger-configuration-serial-port
+               (default "/dev/ttyUSB0"))
+  (data-directory utmp-logger-configuration-data-directory
+                  (default "/var/utmp-logger"))
+  (minutes utmp-logger-configuration-minutes
+           (default #~(iota 12 0 5))))
+
+(define %utmp-logger-accounts
+  (list (user-group
+          (name "utmp")
+          (system? #t))
+        (user-account
+          (name "utmp")
+          (group "utmp")
+          (supplementary-groups (list "dialout"))
+          (system? #t)
+          (comment "utmp-logger user")
+          (home-directory "/var/empty")
+          (shell (file-append shadow "/sbin/nologin")))))
+
+(define utmp-logger-log-gexp
+  (match-record-lambda <utmp-logger-configuration>
+      (utmp-cli serial-port data-directory)
+    (with-extensions (list guile-json-4)
+      #~(begin
+          (use-modules (rnrs io ports)
+                       (srfi srfi-19)
+                       (srfi srfi-26)
+                       (ice-9 popen)
+                       (json))
+
+          (define (call-with-input-pipe command proc)
+            (let ((port #f))
+              (dynamic-wind
+                (cut set! port (apply open-pipe* OPEN_READ command))
+                (cut proc port)
+                (lambda ()
+                  (unless (zero? (status:exit-val (close-pipe port)))
+                    (error "Command invocation failed" command))))))
+
+          (define (call-with-appended-file file proc)
+            (call-with-port (open-file file "a") proc))
+
+          (let ((data (call-with-input-pipe (list #$(file-append utmp-cli "/bin/utmp-cli")
+                                                  "-s" #$serial-port
+                                                  "-ij")
+                        json->scm)))
+            (call-with-appended-file #$(string-append data-directory
+                                                      "/data.tsv")
+              (lambda (port)
+                (put-string port (date->string (current-date) "~4"))
+                (put-string port "\t")
+                (put-string port
+                            (number->string (assoc-ref data "temp_c")))
+                (put-string port "\n"))))))))
+
+(define (utmp-logger-shepherd-service config)
+  (match-record config <utmp-logger-configuration>
+                (minutes serial-port data-directory)
+    (shepherd-service
+      (provision '(utmp-logger))
+      (modules '((shepherd service timer)))
+      (start #~(make-timer-constructor
+                (calendar-event #:minutes #$minutes)
+                (command (list #$(least-authority-wrapper
+                                  (program-file "utmp-log"
+                                                (utmp-logger-log-gexp config))
+                                  #:name "utmp-log-pola-wrapper"
+                                  #:user "utmp"
+                                  #:group "dialout"
+                                  #:mappings (list (file-system-mapping
+                                                     (source serial-port)
+                                                     (target serial-port))
+                                                   (file-system-mapping
+                                                     (source data-directory)
+                                                     (target data-directory)
+                                                     (writable? #t)))
+                                  #:namespaces (delq 'user %namespaces))))
+                #:log-file "/var/log/utmp-logger.log"
+                #:wait-for-termination? #t))
+      (stop #~(make-timer-destructor))
+      (actions (list shepherd-trigger-action))
+      (documentation "Log temperature using utmp-cli."))))
+
+(define utmp-logger-activation
+  (match-record-lambda <utmp-logger-configuration>
+      (data-directory)
+    #~(begin
+        (use-modules (guix build utils))
+
+        (mkdir-p #$data-directory)
+        (let ((user (getpw "utmp")))
+          (for-each (lambda (file)
+                      (chown file (passwd:uid user) (passwd:gid user)))
+                    (find-files #$data-directory
+                                #:directories? #t))))))
+
+(define utmp-logger-service-type
+  (service-type
+    (name 'utmp-logger)
+    (description "Log temperature using utmp-cli.")
+    (extensions
+     (list (service-extension account-service-type
+                              (const %utmp-logger-accounts))
+           (service-extension shepherd-root-service-type
+                              (compose list utmp-logger-shepherd-service))
+           (service-extension activation-service-type
+                              utmp-logger-activation)))
+    (default-value (utmp-logger-configuration))))