adopted Eric's partial implementation

This commit is contained in:
frese 2004-07-16 13:44:39 +00:00
parent 6d8a32093e
commit 7ee58bbe7a
1 changed files with 236 additions and 0 deletions

examples/passwd-wrapper.scm Executable file
View File

@ -0,0 +1,236 @@
#!/usr/local/bin/scsh \
-lm ../scheme/packages.scm -o threads -o chat-package -o expect-package -e main -s
(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
(apply char-set-union 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))
(define (display-password-too-short)
(display "Password too short (minimum length ")
(display min-password-length)
(display ")")
(define (display-password-too-long)
(display "Password too long (maximum length ")
(display max-password-length)
(display ")")
(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.")
;; *** 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
(display prompt)
(force-output (current-output-port))))
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)
;; *** 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"
(exit 10))
;; *** interface to yppasswd *****************************************
(define (yppasswd-program)
(define (yppasswd-prompts)
(map cons
'(old-prompt new-prompt retype-prompt wrong-message mismatch-message
((freebsd-machine?) '("Old Password:"
"New Password:"
"Retype New Password:"
"yppasswd: sorry"
"Mismatch; try again, EOF to quit."
((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:"
"Mismatch - password unchanged."
#f ;; TODO??
(define (verify-yp-password old-pw)
(let ((prompts (yppasswd-prompts)))
(old-prompt (assq/false 'old prompts))
(wrong (assq/false 'wrong-old prompts))
;; if prompted for new password, old one is correct
(correct (assq/false 'new prompts)))
(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
(define (change-yp-password old-pw new-pw)
(let ((prompts (yppasswd-prompts))
(success-message (assq/false 'success-message prompts)))
(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))
(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)))
((verify-old-password pw)
(display "Wrong password. Try again.")
(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))
(display no-match)
(lp #f)))
(let ((pw (read-password new-pw-prompt-1)))
((< (string-length pw) min-password-length)
(lp #f))
((> (string-length pw) max-password-length)
(lp #f))
((< (count-char-classes pw) min-password-char-classes)
(lp #f))
(lp pw))))))))
(define (main args)
(if (not (or (solaris-machine?) (freebsd-machine?)))
(let ((old-pw (ask/check-old-password))
(new-pw (ask-new-password)))
(change-password old-pw new-pw)))