#!/bin/sh
exec scsh -lm ../scheme/packages.scm -o threads -o chat-package -o expect-package -o let-opt -e main -s "$0" "$@"
!#

(define (assq/false key alist)
  (let ((p (assq key alist)))
    (and p (cdr p))))

;; *** password restrictions *****************************************

(define min-password-length 8)
(define max-password-length 32)
(define min-password-char-classes 2)

(define known-char-sets
  (list char-set:lower-case char-set:upper-case
	char-set:digit char-set:punctuation))

(define all-char-sets
  (cons (char-set-difference 
	 char-set:full
	 (apply char-set-union known-char-sets))
	known-char-sets))

(define (count-char-classes pw)
  (apply + (map (lambda (cs)
		  (if (string-fold 
		       (lambda (c s)
			 (or s (char-set-contains? cs c)))
		       #f pw)
		      1 0))
		all-char-sets)))

(define (display-password-too-short)
  (newline)
  (display "Password too short (minimum length ")
  (display min-password-length)
  (display ")")
  (newline))

(define (display-password-too-long)
  (newline)
  (display "Password too long (maximum length ")
  (display max-password-length)
  (display ")")
  (newline))

(define (display-password-too-few-char-classes)
  (display "
New password does not have enough character classes.
The character classes are:
    - lower-case letters
    - upper-case letters
    - digits
    - punctuation, and
    - all other characters (e.g., control characters).

Please choose a password with at least 2 character classes.")
  (newline))

;; *** tty support ***************************************************

;; read string without echoing it
;; optionals arguments:
;; prompt - a string to be display before reading (default none)
;; port - the port to read from (default current-input-port)
(define (read-password . args)
  (let-optionals args ((prompt #f)
		       (port (current-input-port)))
    (let* ((tty-before (tty-info port))
	   (tty-sans-echo (copy-tty-info tty-before)))
      (if prompt
	  (begin
	    (display prompt)
	    (force-output (current-output-port))))
      (set-tty-info:local-flags 
       tty-sans-echo (bitwise-and (tty-info:local-flags tty-sans-echo) 
				  (bitwise-not ttyl/echo)))
      (set-tty-info/now port tty-sans-echo)
      (let ((password (read-line port)))
	(set-tty-info/now port tty-before)
	(flush-tty/both port)
	password))))

;; *** supported machines ********************************************

;; TODO: cache the results

(define (solaris-machine?)
  (let ((systype (getenv "SYSTYPE")))
    (and systype (string=? systype "sun4x_58"))))

(define (freebsd-machine?)
  (let ((systype (getenv "SYSTYPE")))
    (and systype (string=? systype "i386_fbsd52"))))

(define (linux-machine?)
  (let ((systype (getenv "SYSTYPE")))
    (and systype (string=? systype "i386_linux24"))))

(define (raise-unsupported-machine)
  (display "I refuse to run on unsupported machines\n" 
	   (current-error-port))
  (exit 10))

;; *** interface to yppasswd *****************************************

(define (yppasswd-program)
  "/usr/bin/yppasswd")

(define (yppasswd-prompts)
  (map cons
       '(old-prompt new-prompt retype-prompt wrong-message mismatch-message
		    success-message)
       (cond
	((freebsd-machine?) '("Old Password:"
			      "New Password:"
			      "Retype New Password:"
			      "yppasswd: sorry"
			      "Mismatch; try again, EOF to quit."
			      #f))
	((solaris-machine?) '("Enter existing login password:"
			      "New Password: "
			      "Re-enter new Password: "
			      "yppasswd: Sorry, wrong passwd"
			      "passwd(SYSTEM): They don't match."
			      "passwd: password successfully changed"))
	((linux-machine?) '("Please enter old password:"
			    "Please enter new password:"
			    "Please retype new password:"
			    "Sorry."
			    "Mismatch - password unchanged."
			    #f ;; TODO??
			    )))))

(define (verify-yp-password old-pw)
  (let ((prompts (yppasswd-prompts)))
    (call/cc
     (lambda (return)
       (chat (spawn ,(yppasswd-program) (= 2 1))
	     (chat-abort (rx ,(assq/false 'wrong-message prompts)))
	     (chat-monitor (lambda (event value)
			     (case event
			       ((eof timeout abort) (return #f)))))
	     
	     (look-for (assq/false 'old-prompt prompts))
	     (send/cr old-pw)
	     (look-for (assq/false 'new-prompt prompts))
	     ;; if we are prompted for the new pw, old one was correct
	     #t)))))

(define (change-yp-password old-pw new-pw)
  (let ((prompts (yppasswd-prompts))
	(success-message (assq/false 'success-message prompts)))
    (call/cc
     (lambda (return)
       (chat (spawn ,(yppasswd-program (= 2 1)))
	     (chat-abort (rx (| ,(assq/false 'mismatch-message prompts)
				,(assq/false 'wrong-message prompts))))
	     (chat-monitor (lambda (event value)
			     (case event
			       ((timeout abort) (return #f))
			       ((eof)
				(if success-message
				    (return #f)
				    (return #t))))))
	     
	     (look-for (assq/false 'old-prompt prompts))
	     (send old-pw)
	     (look-for (assq/false 'new-prompt prompts))
	     (send new-pw)
	     (look-for (assq/false 'retype-prompt prompts))
	     (send new-pw)
	     (if success-message
		 ;; if there's gonna be a success-message, wait for it.
		 (begin (look-for success-message) #t)
		 ;; else wait a bit for errors (#f) or eof (#t)
		 (begin (sleep 2000) #f)))))))

;; *** all together **************************************************

(define (verify-old-password pw)
  (verify-yp-password pw))

(define (change-password old-pw new-pw)
  (change-yp-password old-pw new-pw))

(define (ask/check-old-password)
  (let ((old-pw-prompt "Old password: "))
    (let lp ((old-pw #f))
      (let ((pw (read-password old-pw-prompt)))
 	(cond
 	 ((verify-old-password pw)
 	  pw)
 	 (else
 	  (display "Wrong password.  Try again.")
	  (newline)
 	  (lp (read-password old-pw-prompt))))))))

(define (ask-new-password)
  (let ((new-pw-prompt-1 "New password: ")
 	(new-pw-prompt-2 "\nRetype new password: ")
 	(no-match "Passwords do not match. Retry."))
    (let lp ((pw #f))
      (if pw 
 	  (if (string=? pw (read-password new-pw-prompt-2))
 	      pw
 	      (begin
		(newline)
 		(display no-match)
 		(newline)
 		(lp #f)))
	  (let ((pw (read-password new-pw-prompt-1)))
	    (cond
	     ((< (string-length pw) min-password-length)
	      (display-password-too-short)
	      (lp #f))
	     ((> (string-length pw) max-password-length)
	      (display-password-too-long)
	      (lp #f))
	     ((< (count-char-classes pw) min-password-char-classes)
	      (display-password-too-few-char-classes)
	      (lp #f))
	     (else
	      (lp pw))))))))

(define (main args)
  (if (not (or (solaris-machine?) (freebsd-machine?)))
      (raise-unsupported-machine))
  (let ((old-pw (ask/check-old-password))
	(new-pw (ask-new-password)))
    (change-password old-pw new-pw)))