(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))))