sunet/scheme/lib/netrc.scm

156 lines
4.2 KiB
Scheme
Raw Normal View History

2002-06-08 11:07:01 -04:00
;;; netrc.scm -- parse authentication information contained in ~/.netrc
2002-08-27 05:03:22 -04:00
;;; This file is part of the Scheme Untergrund Networking package.
2002-06-08 11:07:01 -04:00
;;; Copyright (c) 2003 by Mike Sperber <sperber@informatik.uni-tuebingen.de>
2002-08-27 05:03:22 -04:00
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
2002-06-08 11:07:01 -04:00
(define (check-permissions file-name)
(if (not (zero? (bitwise-and #b000111111 (file-mode file-name))))
(error "Not parsing netrc file; dangerous permissions."
file-name)))
(define (netrc-file-name)
(string-append (file-name-as-directory (home-dir))
".netrc"))
(define (skip-whitespace port)
(let loop ()
(let ((char (peek-char port)))
(cond
((eof-object? char)
(values))
((char-set-contains? char-set:whitespace char)
(read-char port)
(loop))
(else (values))))))
(define (skip-until-eol port)
(let loop ()
(let ((char (peek-char port)))
(cond
((eof-object? char)
(values))
((char=? #\newline char)
(read-char port))
(else
(read-char port)
(loop))))))
(define (read-lines-until-double-eol port)
(let loop ((reverse-lines '()))
(let ((line (read-line port)))
(if (or (eof-object? line)
(string=? "" line))
(reverse reverse-lines)
(loop (cons line reverse-lines))))))
(define (next-token port)
(skip-whitespace port)
(let loop ((reverse-chars '()))
(define (token)
(if (null? reverse-chars)
#f
(list->string (reverse reverse-chars))))
(let ((char (peek-char port)))
(cond
((eof-object? char) (token))
((char-set-contains? char-set:whitespace char) (token))
(else
(loop (cons (read-char port) reverse-chars)))))))
(define (next-field port)
(let ((token (next-token port)))
(cond
((not token)
(values #f #f))
((string=? "default" token)
(values token #f))
((string=? "macdef" token)
(let ((name (next-token port)))
(skip-until-eol port)
(values token
(cons name (read-lines-until-double-eol port)))))
(else
(values token (next-token port))))))
(define (skip-until-machine port machine accept-default?)
(let loop ()
(call-with-values
(lambda () (next-field port))
(lambda (tag value)
(cond
((not tag) #f)
((and accept-default? (string=? "default" tag))
#t)
((and (string=? tag "machine")
(string-ci=? machine value))
#t)
(else
(loop)))))))
(define (next-macro-definition port)
(let loop ()
(call-with-values
(lambda () (next-field port))
(lambda (tag value)
(cond
((not tag) #f)
((string=? "macdef" tag) value)
(else (loop)))))))
(define-record-type netrc-entry :netrc-entry
(make-netrc-entry machine login password account)
netrc-entry?
(machine netrc-entry-machine set-netrc-entry-machine!)
(login netrc-entry-login set-netrc-entry-login!)
(password netrc-entry-password set-netrc-entry-password!)
(account netrc-entry-account set-netrc-entry-account!))
(define (netrc-machine-entry machine accept-default? . maybe-file-name)
(let ((file-name (if (pair? maybe-file-name)
(car maybe-file-name)
(netrc-file-name)))
(entry (make-netrc-entry machine #f #f #f)))
(check-permissions file-name)
(call-with-input-file file-name
(lambda (port)
(if (not (skip-until-machine port machine accept-default?))
#f
(let loop ()
(call-with-values
(lambda () (next-field port))
(lambda (tag value)
(cond
((not tag) entry)
((or (string=? "default" tag)
(string=? "machine" tag))
entry)
((string=? "login" tag)
(set-netrc-entry-login! entry value)
(loop))
((string=? "password" tag)
(set-netrc-entry-password! entry value)
(loop))
((string=? "account" tag)
(set-netrc-entry-account! entry value)
(loop))
(else (loop)))))))))))
(define (netrc-macro-definitions . maybe-file-name)
(let ((file-name (if (pair? maybe-file-name)
(car maybe-file-name)
(netrc-file-name))))
(check-permissions file-name)
(call-with-input-file file-name
(lambda (port)
(let loop ((reverse-alist '()))
(cond
((next-macro-definition port)
=> (lambda (pair)
(loop (cons pair reverse-alist))))
(else (reverse reverse-alist))))))))