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

;; TODO:
;; make program uninterruptable - catch Ctrl-C

(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)
  (display "Password too short (minimum length ")
  (display min-password-length)
  (display ")")
  (newline))

(define (display-password-too-long)
  (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)
	(newline)
	(force-output (current-output-port))
	password))))

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

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

(define system-type
  (let ((systype (getenv "SYSTYPE")))
    (if (not systype)
	(error "Cannot determine system type ($SYSTYPE not set)."))
    (cond
     ((string=? systype "sun4x_58") 'sun)
     ((string=? systype "i386_fbsd52") 'freebsd)
     ((string=? systype "i386_linux24") 'linux)
     (else (raise-unsupported-machine)))))

;; *** general password interface ************************************

(define (define-passwd program old-prompt new-prompt retype-prompt wrong-message
	  mismatch-message success-message)
  `((program . ,program)
    (old-prompt . ,old-prompt)
    (new-prompt . ,new-prompt)
    (retype-prompt . ,retype-prompt)
    (wrong-message . ,wrong-message)
    (mismatch-message . ,mismatch-message)
    (success-message . ,success-message)))

(define (verify-password spec password)
  (call-with-current-continuation
   (lambda (return)
     (chat (spawn (,(assq/false 'program spec)) (= 2 1))
	     (chat-abort (rx ,(assq/false 'wrong-message spec)))
	     (chat-monitor (lambda (event value)
			     ;(format (current-error-port)
				;     "Event: ~a <~a>\n" event value)
			     ;(force-output (current-error-port))
			     (case event
			       ((eof timeout abort) (return #f)))))
	     
	     (look-for (assq/false 'old-prompt spec))
	     (send/cr password)
	     (look-for (assq/false 'new-prompt spec))
	     ;; if we are prompted for the new pw, old one was correct
	     #t))))

(define (change-password spec old-pw new-pw)
  (let ((success-message (assq/false 'success-message spec)))
    (call-with-current-continuation
     (lambda (return)
       (chat (spawn (,(assq/false 'program spec)) (= 2 1))
	     (chat-abort (rx (| ,(assq/false 'mismatch-message spec)
				,(assq/false 'wrong-message spec))))
	     (chat-monitor (lambda (event value)
			     ;(format (current-error-port)
				;     "Event: ~a <~a>\n" event value)
			     ;(force-output (current-error-port))
			     (case event
			       ((timeout abort) (return #f))
			       ((eof)
				(if success-message
				    (return #f)
				    (return #t))))))
	     
	     (look-for (assq/false 'old-prompt spec))
	     (send/cr old-pw)
	     (look-for (assq/false 'new-prompt spec))
	     (send/cr new-pw)
	     (look-for (assq/false 'retype-prompt spec))
	     (send/cr 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)
		 ;; TODO: there is no eof, although program ends
		 (begin (sleep 2000) #t)))))))

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

(define yppasswd
  (let ((program "/usr/bin/yppasswd"))
    (case system-type
      ((freebsd) (define-passwd program
		   "Old Password:"
		   "New Password:"
		   "Retype New Password:"
		   "yppasswd: sorry"
		   "Mismatch; try again, EOF to quit."
		   #f))
      ((solaris) (define-passwd program
		   "Enter existing login password:"
		   "New Password: "
		   "Re-enter new Password: "
		   "yppasswd: Sorry, wrong passwd"
		   (rx "passwd(SYSTEM): They don't match.")
		   "passwd: password successfully changed"))
      ((linux) (define-passwd program
		 "Please enter old password:"
		 "Please enter new password:"
		 "Please retype new password:"
		 "Sorry."
		 "Mismatch - password unchanged."
		 #f ;; TODO??
		 )))))

(define (verify-yp-password password)
  (verify-password yppasswd password))

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

;; *** Kerberos V interface ******************************************

(define kerberos-v
  (case system-type
    ((freebsd) (define-passwd "/afs/wsi/i386_fbsd52/heimdal-1.6/bin/kpasswd"
		 "Password: "
		 "New password: "
		 "Verifying - New password: "
		 "kpasswd: Password incorrect"
		 "Verify failure"
		 "Success"))
    ))
    ;;((solaris) (define-passwd "/afs/wsi/sun4x_58/krb5-1.3.1/bin/kpasswd"
		 ;; TODO))

(define (verify-kerbv-password password)
  (verify-password kerberos-v password))

(define (change-kerbv-password old-pw new-pw)
  (change-password kerberos-v old-pw new-pw))

;; *** AFS (Kerberos IV) interface ***********************************

(define afs
  (case system-type
    ((freebsd) (define-passwd "/afs/wsi/i386_fbsd52/openafs-cvs/bin/kpasswd"
		 "Old password: "
		 (rx "New password (RETURN to abort): ")
		 "Retype new password: "
		 ;; Attention: the old password is checked AFTER the
		 ;; new password is entered! So verify will not work!
		 "kpasswd: Incorrect old password."
		 "Mismatch"
		 "Password changed."))
    ))
    ;;((solaris) (define-passwd "/afs/wsi/sun4x_58/openafs-1.2.11/bin/kpasswd"
		 ;; TODO))

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

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

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

(define (change-all-passwords old-pw new-pw)
  ;; TODO: maybe undo password changes if next changes fail - is
  ;; difficult because Kerberos passwords need some minutes to become
  ;; effective
  (and (change-yp-password old-pw new-pw)
       (begin
	 (display "NIS password changed successfully.\n")
	 ;; TODO: make sure we have a ticket
	 (and (change-kerbv-password old-pw new-pw)
	      (begin
		(display "Kerberos V password changed successfully.\n")
		(and (change-afs-password old-pw new-pw)
		     (display "AFS password changed successfully.\n")))))))

(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.\n")
	  (force-output)
 	  (lp (read-password old-pw-prompt))))))))

(define (ask-new-password)
  (let ((new-pw-prompt-1 "New password: ")
 	(new-pw-prompt-2 "Retype 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
 		(display no-match)
 		(newline)
 		(lp #f)))
	  ;; TODO: there are more restrictions concerning 'too similar'!
	  (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)
  (let ((old-pw (ask/check-old-password))
	(new-pw (ask-new-password)))
    (if (change-all-passwords old-pw new-pw)
	(display "Password changed.\n")
	(display "Password could not be changed.\n"))))