(define-module (ruther services auto-login)
  #:use-module (guix gexp)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages base)
  #:export (make-auto-login-program))

(define* (make-auto-login-program #:key (users '()))
  (program-file
   "auto-login"
   #~(begin
       (define users (list #$@users))
       (define marker "/tmp/.auto-login-done")
       (define stty-bin #$(file-append coreutils "/bin/stty"))

       (define (show-menu!)
         (display "\nAuto-login — choose account:\n")
         (let loop ((us users) (i 0))
           (when (pair? us)
             (format #t "  ~a) ~a\n" (integer->char (+ i (char->integer #\a))) (car us))
             (loop (cdr us) (+ i 1))))
         (display "> "))

       (define (read-key)
         (dynamic-wind
           (lambda () (system* stty-bin "-echo" "cbreak"))
           (lambda () (read-char))
           (lambda () (system* stty-bin "echo" "-cbreak"))))

       (define (read-choice)
         (show-menu!)
         (let* ((ch  (read-key))
                (idx (- (char->integer ch) (char->integer #\a))))
           (newline)
           (if (and (>= idx 0) (< idx (length users)))
               (list-ref users idx)
               (begin
                 (display "Invalid choice, try again.\n")
                 (read-choice)))))

       (let ((login-bin #$(file-append shadow "/bin/login"))
             (args       (filter (lambda (a) (not (or (string=? a "-f")
                                                      (string=? a "auto"))))
                                (cdr (command-line)))))  ; strip -f and dummy username injected by mingetty
         (if (file-exists? marker)
             (apply execlp login-bin login-bin args)
             (let ((user (read-choice)))
               (call-with-output-file marker
                 (lambda (p) (display (getpid) p)))
               (apply execlp login-bin login-bin "-f" user args)))))))