adopted Eric's partial implementation
This commit is contained in:
frese
parent
6d8a32093e
commit
7ee58bbe7a
|
|
@ -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
|
||||
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)))
|
||||
(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)))
|
||||
(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)))
|
||||
Loading…
Reference in New Issue