305 lines
9.2 KiB
Scheme
Executable File
305 lines
9.2 KiB
Scheme
Executable File
#!/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"))))
|