scsh-expect/examples/passwd-wrapper.scm

341 lines
10 KiB
Scheme
Executable File

#!/bin/sh
exec scsh -lel expect/load.scm -o threads -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
))
;; ((linux) (define-passwd "/afs/wsi/i386_rh90/heimdal-0.6/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))
(define (valid-kerbv-ticket?)
;; neither "No ticket file" nor ">>>Expired<<<" in klist output
#f ;; TODO
)
(define (get-kerbv-ticket password)
;; TODO look at status result
(run (kinit)))
(define (ensure-kerbv-ticket password)
(or (valid-kerbv-ticket?)
(get-kerbv-ticket password)))
;; *** 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"
"Old password: "
"New password (RETURN to abort): "
"Retype new password: "
"kpasswd: Incorrect old password."
"Mismatch"
"Password changed."))
;; ((linux) (define-passwd "/usr/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 (display-usage)
(display "Usage: passwd-wrapper.scm\n")
(display "Change NIS, Kerberos IV and Kerberos V passwords at once.\n")
(display "Written by David Frese.\n"))
(define (main args)
(if (null? (cdr args))
(case system-type
((freebsd solaris)
(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"))))
(else
(raise-unsupported-machine)))
(display-usage)))