233 lines
6.7 KiB
Scheme
Executable File
233 lines
6.7 KiB
Scheme
Executable File
#!/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)))
|