blob: 127cae2c5923566090dd5e3c8571e0006e43fda3 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
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))))
|
