67 lines
2.4 KiB
Scheme
67 lines
2.4 KiB
Scheme
(use-modules (srfi srfi-1)
|
|
(srfi srfi-13)
|
|
(ice-9 binary-ports)
|
|
(ice-9 textual-ports)
|
|
(ice-9 format)
|
|
(ice-9 regex)
|
|
(rnrs bytevectors))
|
|
|
|
(define *host-passwd-file* (getenv "FUDO_HOST_PASSWD_FILE"))
|
|
(when (not *host-passwd-file*)
|
|
(format (current-error-port "FUDO_HOST_PASSWD_FILE not set~%"))
|
|
(exit 1))
|
|
|
|
(define *service-passwd-file* (getenv "FUDO_SERVICE_PASSWD_FILE"))
|
|
(when (not *service-passwd-file*)
|
|
(format (current-error-port "FUDO_SERVICE_PASSWD_FILE not set~%"))
|
|
(exit 1))
|
|
|
|
(define host-regex "^host-([a-zA-Z][a-zA-Z0-9_-]+)$")
|
|
(define service-regex "^service-([a-zA-Z][a-zA-Z0-9_-]+)$")
|
|
|
|
(define (make-verifier passwd-file)
|
|
(let ((passwds (load passwd-file)))
|
|
(lambda (username passwd)
|
|
(and (> (string-length passwd) 6)
|
|
(equal? (assoc-ref passwds username) passwd)))))
|
|
|
|
(define (make-authenticator host-verifier service-verifier)
|
|
(lambda (username hostname password)
|
|
(cond ((string-match host-regex username)
|
|
(host-verifier (match:substring (string-match host-regex username) 1)
|
|
password))
|
|
|
|
((string-match service-regex username)
|
|
(service-verifier (match:substring (string-match service-regex username) 1)
|
|
password))
|
|
|
|
(else #f))))
|
|
|
|
(define (make-handler handlers)
|
|
(lambda (request)
|
|
(let ((op (assoc-ref handlers (first request))))
|
|
(if op
|
|
(apply op (cdr request))
|
|
#f))))
|
|
|
|
(define (auth-listener handler)
|
|
(let ((in (current-input-port))
|
|
(out (current-output-port)))
|
|
(while #t
|
|
(let ((size (bytevector-u16-ref (get-bytevector-n in 2) 0 (endianness big)))
|
|
(response (make-bytevector 4 0)))
|
|
(bytevector-u8-set! response 1 #x02)
|
|
(if (handler (string-split (get-string-n in size) #\:))
|
|
(begin (bytevector-u8-set! response 3 #x01)
|
|
(put-bytevector out response 0 4)
|
|
(force-output out))
|
|
(begin (bytevector-u8-set! response 3 #x00)
|
|
(put-bytevector out response 0 4)
|
|
(force-output out)))))))
|
|
|
|
(auth-listener
|
|
(make-handler
|
|
(list (cons "auth"
|
|
(make-authenticator (make-verifier *host-passwd-file*)
|
|
(make-verifier *service-passwd-file*))))))
|