scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Rewrite the NETRC library to something more general and much shorter, 

along with up-to-date information.  Get FTP and POP3 to use the new
code.
This commit is contained in:
sperber 2003-01-21 14:20:13 +00:00
parent 2994678584
commit c04d46910c
5 changed files with 203 additions and 517 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

165
doc/latex/netrc.tex
View File

@ -1,136 +1,59 @@
\chapter{Reading netrc-files}\label{cha:netrc} \chapter{Parsing Netrc Files}\label{cha:netrc}
% %
\begin{description} The \ex{netrc} structures provides procedures to parse authentication
\item[Used files:] netrc.scm information contained in \ex{~/.netrc}.
\item[Name of the package:] netrc
\end{description}
%
\section{Overview}
This module provides procedures to parse authentication information
contained in \ex{~/.netrc}.
On Unix systems the \ex{~/.netrc} file (in the user's home directory) On Unix systems the netrc file may contain information allowing
may contain information allowing automatic login to remote hosts. The automatic login to remote hosts. The format of the file is defined in
format of the file is defined in the \ex{ftp}(1) manual page. Example the \ex{ftp(1)} manual page. Example lines are
lines are %
\begin{alltt} \begin{verbatim}
machine ondine.cict.fr login marsden password secret machine ondine.cict.fr login marsden password secret
default login anonymous password user@site% default login anonymous password user@site
\end{alltt} \end{verbatim}
%
The \ex{~/.netrc} file should be protected by appropriate permissions, and The netrc file should be protected by appropriate permissions, and
(like \ex{/usr/bin/ftp}) this library will refuse to read the file if it is (like \ex{/usr/bin/ftp}) this library will refuse to read the file if it is
badly protected. (unlike \ex{ftp} this library will always refuse badly protected. (unlike \ex{ftp} this library will always refuse
to read the file -- \ex{ftp} refuses it only if the password is to read the file----\ex{ftp} refuses it only if the password is
given for a non-default account). Appropriate permissions are set if given for a non-default account). Appropriate permissions are set if
only the user has permissions on the file. only the user has permissions on the file.
Note following restrictions and differences: \defun{netrc-machine-entry}{host accept-default? [file-name]}{netrc-entry-or-\sharpf}
\begin{itemize}
\item The macdef statement (defining macros) is not supported.
\item The settings for one machine must be on a single line.
\item The is no error proof while reading the file.
\item Default need not be the last line of the netrc-file.
\end{itemize}
\section{Entry points}
What you probably want, is to read out the default netrc-file. Do the
following:
\begin{alltt}
(let ((netrc-record (netrc:parse)))
(netrc:lookup netrc-record "name of the machine"))
\end{alltt}
and you will receive three values: \semvar{login-name},
\semvar{password} and \semvar{account-name}. If you only want the
login name or the password, use \ex{netrc:\ob{}lookup\=login} or
\ex{netrc:\ob{}lookup\=password}, resp.
You will get either the login / password for the specified machine, or
a default login / password if the machine is unknown.
\begin{defundesc}{user-mail-address}{}{string}
Calculate the user's email address, as per the Emacs function of the
same name. Will take into account the environment variable
\ex{REPLYTO}, if set. Otherwise the mail-address will look like
\ex{user@\ob{}hostname}.
\end{defundesc}
\defun{netrc:parse} {[filename] [fallback-password] [fallback-login]} {netrc-record}
\begin{defundescx}{netrc:try-parse} {filename fallback-password
fallback-login} {netrc-record}
\ex{netrc:parse} parses the netrc file and returns a \ex{netrc}
record, containing all necessary information for the following
procedures.
\semvar{filename} defaults to ``~/.netrc'',
\semvar{fallback-password} defaults to the result of the call to
\ex{user\=mail\=address} and \semvar{fallback-login} defaults to
``anonymous''. If the netrc file does not provide a default password
or a default login (stated by the ``default'' statement),
\semvar{fallback-password} and \semvar{fallback-login} will be used
as default password or login, respectively (thus,
\ex{user\=mail\=address} is only called if the netrc file does not
contain a default specification). If the netrc file does not exist,
a netrc-record filled with default values is returned. If the netrc
file does not have the correct permissions, a message is printed to
the current error port and a netrc-record filled with default values
is returned.
\ex{netrc:try-parse} does the same as \ex{netrc:\ob{}parse}, except
of the following: if there is no file called \semvar{filename}, the
according error will be raised and if the specified file does not
have the correct permissions set, a \ex{netrc\=refuse\=warning} will
be signalled. So, if you don't like the error handling and behavior
of \ex{netrc:\ob{}parse}, use \ex{netrc:\ob{}try\=parse} and catch
the signalled conditions. Note, that \ex{netrc:\ob{}parse} resolves
\semvar{filename} for you, \ex{netrc:\ob{}try-parse} does not -- you
have to do it on your own.
\end{defundescx}
\defun{netrc:lookup}{netrc-record machine [default?]} {string string string}
\defunx{netrc:lookup-password}{netrc-record machine [default?]}{string}
\defunx{netrc:lookup-login}{netrc-record machine [default?]}{string}
\begin{desc} \begin{desc}
Return the login, password and / or account information for This procedure looks for the entry related to given host in the
\semvar{machine} specified by \semvar{netrc-record}, respectively. user's netrc file. The host is specified in \var{host}.
If \semvar{default?} is \sharpt, default values are returned if no \var{Accept-default?} specifies whether \ex{netrc-machine-entry}
such \semvar{machine} is specified in the \semvar{netrc-record}. should fall back to the default entry if there is no macht for
Otherwise [\sharpf\ \sharpf\ \sharpf] or \sharpf\ is returned, \var{host} in the netrc file. If specified, \var{file-name}
respectively. specifies an alternate file name for the netrc data. It defaults to
\ex{.netrc} in the current user's home directory.
\ex{Netrc-machine-entry} returns a netrc entry (see below) if it was
able to find the requested information; if not, it returns \sharpf.
If the netrc file had inappropriate permissions, \ex{netrc-machine-entry}
raises an error.
\end{desc} \end{desc}
\defun{netrc:default-login}{netrc-record}{string} \defun{netrc-entry?}{thing}{boolean}
\begin{defundescx}{netrc:default-password}{netrc-record}{string} \defunx{netrc-entry-machine}{netrc-entry}{string}
Return the default values for the login or the password, respectively, \defunx{netrc-entry-login}{netrc-entry}{string-or-\sharpf}
specified by \semvar{netrc-record}. If the netrc file did not \defunx{netrc-entry-password}{netrc-entry}{string-or-\sharpf}
specify a default login, ``anonymous'' is returned by \defunx{netrc-entry-account}{netrc-entry}{string-or-\sharpf}
\ex{netrc:\ob{}default\=login}. If the netrc file did not specify a \begin{desc}
default password, the result of the call to \ex{user\=mail\=address} \ex{Netrc-entry?} is the predicate for netrc entries. The other
is returned by \ex{netrc:\ob{}default\=password}. procedures are selectors for netrc entries as returned by
\end{defundescx} \ex{netrc-machine-entry}. They return \sharpf{} if the netrc file
didn't contain a binding for the corresponding field.
\end{desc}
\section{Related work} \defun{netrc-macro-definitions}{[file-name]}{alist}
\begin{itemize} \begin{desc}
\item Graham Barr has written a similar library for Perl, called This returns the macro definitions from the netrc files, represented
\ex{Netrc.pm}. as an alist mapping macro names---represented as strings---to
\item \ex{ange-ftp.el} (transparent remote file access for Emacs) definitions---represented as lists of strings.
parses the user's netrc file. \end{desc}
\end{itemize}
\section{Desirable things}
\begin{itemize}
\item Remove restrictions (as stated in `\emph{Overview}') and behave like
\ex{/usr/\ob{}bin/\ob{}ftp} behaves
\item perhaps: adding case-insensitivity (for host names)
\item perhaps: better record-disclosers for netrc-entry- and
netrc-records
\end{itemize}
%%% Local Variables: %%% Local Variables:
%%% mode: latex %%% mode: latex

10
scheme/lib/ftp.scm
View File

@ -104,11 +104,11 @@
(cond (cond
(netrc-record) (netrc-record)
(else (else
(set! netrc-record (netrc-parse)) (set! netrc-record
(netrc-machine-entry (ftp-connection-host-name connection) #t))
netrc-record))))) netrc-record)))))
(let ((login (or login (let ((login (or login
(netrc-lookup-login (get-netrc-record) (netrc-entry-login (get-netrc-record)))))
(ftp-connection-host-name connection)))))
(let ((reply (let ((reply
(ftp-send-command connection (build-command "USER" login) (ftp-send-command connection (build-command "USER" login)
(lambda (code) (lambda (code)
@ -120,9 +120,7 @@
(build-command (build-command
"PASS" "PASS"
(or password (or password
(netrc-lookup-password (get-netrc-record) (netrc-entry-password (get-netrc-record))))
(ftp-connection-host-name
connection))))
(exactly-code "230"))))))) (exactly-code "230")))))))
(define-enumerated-type ftp-type :ftp-type (define-enumerated-type ftp-type :ftp-type

503
scheme/lib/netrc.scm
View File

@ -2,393 +2,154 @@
;;; This file is part of the Scheme Untergrund Networking package. ;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1998 by Eric Marsden ;;; Copyright (c) 2003 by Mike Sperber <sperber@informatik.uni-tuebingen.de>
;;; Copyright (c) 2002 by Andreas Bernauer.
;;; For copyright information, see the file COPYING which comes with ;;; For copyright information, see the file COPYING which comes with
;;; the distribution. ;;; the distribution.
;;; Overview ===================================================== (define (check-permissions file-name)
;; (if (not (zero? (bitwise-and #b000111111 (file-mode file-name))))
;; On Unix systems the ~/.netrc file (in the user's home directory) (error "Not parsing netrc file; dangerous permissions."
;; may contain information allowing automatic login to remote hosts. file-name)))
;; The format of the file is defined in the ftp(1) manual page.
;; Example lines are
;;
;; machine ondine.cict.fr login marsden password secret
;; default login anonymous password user@site
;;
;; The ~/.netrc file should be protected by appropriate permissions,
;; and (like /usr/bin/ftp) this library will refuse to read the file if
;; it is badly protected. (unlike /usr/bin/ftp this library will always
;; refuse to read the file -- /usr/bin/ftp refuses it only if the password
;; is given for a non-default account). Appropriate permissions are set
;; if only the user has permissions on the file.
;;
;; Note following restrictions / differences:
;; * The macdef statement (defining macros) is not supported.
;; * The settings for one machine must be on a single line.
;; * The is no error proof while reading the file.
;; * default need not be the last line of the netrc-file
(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))))))
;;; Entry points ======================================================= (define (skip-until-eol port)
;; (let loop ()
;; What you probably want, is to read out the default netrc-file. Do the (let ((char (peek-char port)))
;; following: (cond
;; ((eof-object? char)
;; (let ((netrc-record (netrc-parse))) (values))
;; (netrc-lookup netrc-record "name of the machine")) ((char=? #\newline char)
;; (read-char port))
;; and you will receive three values: login-name, password and account-name. (else
;; If you only want the login-name or the password, use netrc-lookup-login (read-char port)
;; or netrc-lookup-password resp. (loop))))))
;;
;; You will get either the login / password for the specified machine,
;; or a default login / password if the machine is unknown.
;;
;;
;; (user-mail-address) -> string
;; Calculate the user's email address, as per the Emacs function of
;; the same name. Will take into account the environment variable
;; REPLYTO, if set. Otherwise the mail-address will look like
;; user@hostname.
;;
;; (netrc-parse [filename [fallback-password [fallback-login]]])
;; -> netrc-record
;; * parses the netrc file and returns a netrc-record, containing all
;; necessary information for the following procedures.
;; * FILENAME defaults to "~/.netrc"
;; FALLBACK-PASSWORD defaults to the result of (user-mail-address)
;; FALLBACK-LOGIN defaults to "anonymous"
;; * if the netrc file does not provide a default password or a default
;; login (stated by the "default" statement), FALLBACK-PASSWORD and
;; FALLBACK-LOGIN will be used as default password or login, respectively.
;; (thus, user-mail-address is only called if the netrc file does not
;; contain a default specification)
;; * if the netrc file does not exist, a netrc-record filled with
;; default values is returned.
;; * if the netrc file does not have the correct permissions, a message is
;; printed to current error port and a netrc-record filled with default
;; values is returned.
;;
;; (netrc-try-parse filename fallback-password fallback-login) -> netrc-record
;; parses the netrc file and returns a netrc-record, containing all
;; necessary information for the following procedures.
;; if there is no file called FILENAME, the according error will be raised
;; if the specified file does not have the correct permissions set,
;; a netrc-refuse-warning will be signalled.
;; so if you don't like the error handling of netrc-parse, use
;; netrc-try-parse and catch the signalled conditions.
;;
;; (netrc-lookup netrc-record machine [default?]) -> string x string x string
;; Return the login,password,account information for MACHINE
;; specified by the netrc file.
;; If DEFAULT? is #t, default values are returned if no such
;; MACHINE is specified in the netrc file. Otherwise, #f,#f,#f
;; is returned
;;
;; (netrc-lookup-password netrc-record machine [default?]) -> string
;; Return the password information for MACHINE specified by the
;; netrc file.
;; If DEFAULT? is #t, the default password is returned if no such
;; MACHINE is specified. Otherwise, #f is returned.
;;
;; (netrc-lookup-login netrc-record machine [default?]) -> string
;; Return the login information for MACHINE specified by the
;; netrc file.
;; If DEFAULT? is #t, the default login is returned if no such
;; MACHINE is specified. Otherwise, #f is returned.
;;
;; (netrc-default-login netrc-record) -> string
;; Return the default login specified by the netrc file or "anonymous"
;;
;; (netrc-default-password netrc-record) -> string
;; Return the default password specified by the netrc file or
;; the mail-addres (result of (user-mail-address))
(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 '()))
;;; Related work ======================================================== (define (token)
;; (if (null? reverse-chars)
;; * Graham Barr has written a similar library for Perl, called #f
;; Netrc.pm (list->string (reverse reverse-chars))))
;;
;; * EFS (transparent remote file access for Emacs) parses the
;; user's netrc file
(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)))))))
;;; Desirable things ============================================= (define (next-field port)
;; (let ((token (next-token port)))
;; * Remove restrictions (as stated in 'Overview') and behave like (cond
;; /usr/bin/ftp behaves ((not token)
;; * perhaps: adding case-insensitivity (for host names) (values #f #f))
;; * perhaps: better record-disclosers for netrc-entry- and netrc-records ((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)))))))
; return the user's mail address, either specified by the environment (define (next-macro-definition port)
; variable REPLYTO or "user@hostname". (let loop ()
(define (user-mail-address) (call-with-values
(or (getenv "REPLYTO") (lambda () (next-field port))
(string-append (user-login-name) "@" (system-fqdn)))) (lambda (tag value)
(cond
((not tag) #f)
; looks up the desired machine in a netrc-record ((string=? "macdef" tag) value)
; if the machine is found in the entries-section (else (loop)))))))
; following three values are returned: login, password and account
; if the machine is not found in the entries-section
; the behavior depends on lookup-default? which defaults to #t:
; if lookup-default? is #t
; following three values are returned: default-login default-password #f
; otherwise #f #f #f is returned.
(define (netrc-lookup netrc-record machine . lookup-default?)
(let-optionals lookup-default?
((lookup-default? #t))
(let ((record (find-record netrc-record machine)))
(if record
(values (netrc-entry-login record)
(netrc-entry-password record)
(netrc-entry-account record))
(if lookup-default?
(values (netrc-default-login netrc-record)
(netrc-default-password netrc-record)
#f)
(values #f #f #f))))))
; does the same as netrc-lookup, but returns only the password (or #f)
(define (netrc-lookup-password netrc-record machine . lookup-default?)
(let-optionals lookup-default?
((lookup-default? #t))
(let ((record (find-record netrc-record machine)))
(if record
(netrc-entry-password record)
(and lookup-default?
(netrc-default-password netrc-record))))))
; does the same as netrc-lookup, but returns only the login (or #f)
(define (netrc-lookup-login netrc-record machine . lookup-default?)
(let-optionals lookup-default?
((lookup-default? #t))
(let ((record (find-record netrc-record machine)))
(if record
(netrc-entry-login record)
(and lookup-default?
(netrc-default-login netrc-record))))))
; does the work for netrc-parse
; file-name has to be resolved
(define (netrc-try-parse file-name default-password default-login)
(netrc-check-permissions file-name)
(let ((fd (open-input-file file-name))
(netrc-record (make-netrc '() default-password default-login file-name)))
(for-each-line (parse-line netrc-record) fd)))
; parses the netrc-file
; expected arguments: filename default-password default-login
; filename: filename of the .netrc-file (defaults to ~/.netrc)
; default-password: default password for any not specified machine
; defaults to (user-mail-address)
; default password in netrc-file overwrites this setting
; default-login: default login name for any not specified machine
; defaults to "anonymous"
; default login in netrc-file overwrites this setting
; * (default-login is expected after default-password as users usually want
; to change the default-password (to something else than their mail-address)
; rather than the login-name)(define (netrc-parse . args)
; * if the given file does not exist or it has the wrong permissions,
; than a default netrc-record is returned
; * if you don't want expected errors to be captured, use netrc-try-parse;
; note that you have to resolve the file-name on your own
(define-condition-type 'netrc-refuse '(warning))
(define netrc-refuse? (condition-predicate 'netrc-refuse))
(define (netrc-parse . args)
(let-optionals
args ((file-name "~/.netrc")
(default-password #f) ; both ...
(default-login #f)) ; ... are set if netrc-file does
; not provide default-values
(let* ((file-name (resolve-file-name file-name))
(local-default-login (lambda () "anonymous"))
(local-default-password (lambda () (user-mail-address)))
(local-default-netrc-record
(lambda ()
(make-netrc '()
(or default-login (local-default-login))
(or default-password (local-default-password))
#f))))
; i know, this double-handler sucks; has anyone a better idea?
(call-with-current-continuation
(lambda (exit)
(with-handler
(lambda (error more)
(if (netrc-refuse? error)
(format (current-error-port)
"netrc- Warning: ~a~%"
(car (condition-stuff error)))
(format (current-error-port)
"netrc- Warning: Unexpected error encountered: ~s~%"
error))
(exit (local-default-netrc-record)))
(lambda ()
(with-errno-handler*
(lambda (errno packet)
(if (= errno errno/noent)
(format (current-error-port)
"netrc- Warning: no such file or directory: ~a~%"
file-name)
(format (current-error-port)
"netrc- Warning: Error accessing file ~s~%"
file-name))
(exit (local-default-netrc-record)))
(lambda ()
(let ((netrc-record
(netrc-try-parse file-name default-password default-login)))
; If we get a netrc-record, we return it after
; checking default login and default password settings.
; Otherwise, we return the default record with
; file-name stored.
; This is sub-optimal, as we may throw away badly
; structured .netrc-files silently. We need an error
; checking mechanism.
(if (netrc? netrc-record)
(begin
(if (eq? (netrc-default-login netrc-record) #f)
(set-netrc-default-login! netrc-record (local-default-login)))
(if (eq? (netrc-default-password netrc-record) #f)
(set-netrc-default-password! netrc-record (local-default-password)))
netrc-record)
(let ((default-netrc-record (local-default-netrc-record)))
(set-netrc-file-name! default-netrc-record file-name)
default-netrc-record))))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; nothing exported below
;; except
;; netrc-default-password
;; netrc-default-login
(define-record-type netrc-entry :netrc-entry (define-record-type netrc-entry :netrc-entry
(make-netrc-entry machine login password account) (make-netrc-entry machine login password account)
netrc-entry? netrc-entry?
(machine netrc-entry-machine) (machine netrc-entry-machine set-netrc-entry-machine!)
(login netrc-entry-login) (login netrc-entry-login set-netrc-entry-login!)
(password netrc-entry-password) (password netrc-entry-password set-netrc-entry-password!)
(account netrc-entry-account)) (account netrc-entry-account set-netrc-entry-account!))
(define-record-type netrc :netrc (define (netrc-machine-entry machine accept-default? . maybe-file-name)
(make-netrc entries default-login default-password file-name) (let ((file-name (if (pair? maybe-file-name)
netrc? (car maybe-file-name)
;; list of netrc-entrys (netrc-file-name)))
(entries netrc-entries set-netrc-entries!) (entry (make-netrc-entry machine #f #f #f)))
;; default-values (either library-default or netrc-file-default) (check-permissions file-name)
(default-login netrc-default-login set-netrc-default-login!) (call-with-input-file file-name
(default-password netrc-default-password set-netrc-default-password!) (lambda (port)
(file-name netrc-file-name set-netrc-file-name!)) (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)
(define-record-discloser :netrc-entry (let ((file-name (if (pair? maybe-file-name)
(lambda (netrc-entry) (car maybe-file-name)
(list 'netrc-entry))) ; perhaps something else later on (netrc-file-name))))
(check-permissions file-name)
(define-record-discloser :netrc (call-with-input-file file-name
(lambda (netrc) (lambda (port)
(list 'netrc))) ; perhaps something else later on (let loop ((reverse-alist '()))
(cond
; finds a record in the entries-list of a netrc-record ((next-macro-definition port)
; matching the given machine => (lambda (pair)
; returns the netrc-entry-record if found, otherwise #f (loop (cons pair reverse-alist))))
(define (find-record netrc-record machine) (else (reverse reverse-alist))))))))
(find-first (lambda (rec)
(and (equal? (netrc-entry-machine rec) machine)
rec))
(netrc-entries netrc-record)))
;; raise error if any permissions are set for group or others.
(define (netrc-check-permissions file-name)
(let ((perms (- (file-mode file-name) 32768)))
(if (positive? (bitwise-and #b000111111 perms))
(signal 'netrc-refuse
(format #f
"Not parsing ~s (netrc file); dangerous permissions."
file-name)))))
; tries to match target on line and returns the first group,
; or #f if there is no match
(define (try-match target line)
(let ((match (string-match target line)))
(and match
(match:substring match 1))))
; parses the default line of the netrc-file
(define (parse-default netrc-record line)
(let ((login (try-match "login[ \t]+([^ \t]+)" line))
(password (try-match "password[ \t]+([^ \t]+)" line)))
(if login
(set-netrc-default-login! netrc-record login))
(if password
(set-netrc-default-password! netrc-record password))
netrc-record))
; parses a line of the netrc-file
(define (parse-line netrc-record)
(lambda (line)
(cond ((string-match "default" line)
(parse-default netrc-record line))
(else
(let ((machine (try-match "machine[ \t]+([^ \t]+)" line))
(login (try-match "login[ \t]+([^ \t]+)" line))
(password (try-match "password[ \t]+([^ \t]+)" line))
(account (try-match "account[ \t]+([^ \t]+)" line)))
(if (or machine login password account)
(add netrc-record machine login password account)
netrc-record)))))) ; return record on empty / wrong lines
; (This is a workaround. we should give a warning on malicious .netrc
; files. As we do not have an error checking system installed yet, we
; skip these lines silently.)
; adds machine login password account stored in a netrc-entry-record
; to the entries-list of a netrc-record
(define (add netrc-record machine login password account)
(set-netrc-entries! netrc-record
(cons (make-netrc-entry machine login password account)
(netrc-entries netrc-record)))
netrc-record)
;; for testing
(define (netrc-dump netrc-record)
(format #t "~%--- Dumping ~s contents ---" (netrc-file-name netrc-record))
(for-each (lambda (rec)
(format #t "~% machine ~a login ~a password ~a account ~a"
(netrc-entry-machine rec)
(netrc-entry-login rec)
(netrc-entry-password rec)
(netrc-entry-account rec)))
(netrc-entries netrc-record))
(format #t "~% default login: ~s" (netrc-default-login netrc-record))
(format #t "~% default password: ~s" (netrc-default-password netrc-record))
(format #t "~%--- End of ~s contents ---~%" (netrc-file-name netrc-record)))
; runs proc for each line of fd (line is argument to proc)
; returns either nothing, if the fd had no line
; or the value returned by proc called on the last line
(define (for-each-line proc fd)
(let ((line (read-line fd)))
(if (not (eof-object? line))
(let loop ((last-result (proc line)))
(let ((line (read-line fd)))
(if (not (eof-object? line))
(loop (proc line))
last-result))))))
; finds first element in l for which pred doesn't return #f
; returns either #f (no such element found)
; or the result of the last call to pred
(define (find-first pred l)
(if (null? l) #f
(or (pred (car l))
(find-first pred (cdr l)))))
;; EOF

20
scheme/lib/pop3.scm
View File

@ -91,16 +91,22 @@
(cond (cond
(netrc-record) (netrc-record)
(else (else
(set! netrc-record (netrc-parse)) (set! netrc-record
(netrc-machine-entry (pop3-connection-host-name connection) #f))
netrc-record))))) netrc-record)))))
(let ((login (or login (let ((login (or login
(netrc-lookup-login (get-netrc-record) (begin
(pop3-connection-host-name connection) (if (or (not (get-netrc-record))
#f))) (not (netrc-entry-login (get-netrc-record))))
(signal 'pop3-error
"no login record specified and no netrc entry"))
(netrc-entry-login (get-netrc-record)))))
(password (or password (password (or password
(netrc-lookup-password (get-netrc-record) (begin
(pop3-connection-host-name connection) (if (not (netrc-entry-password (get-netrc-record)))
#f)))) (signal 'pop3-error
"no password record specified and no netrc entry"))
(netrc-entry-password (get-netrc-record))))))
(with-fatal-error-handler* (with-fatal-error-handler*
(lambda (result punt) (lambda (result punt)
(cond (cond

18
scheme/packages.scm
View File

@ -114,13 +114,13 @@
copy-ascii-port->port)) copy-ascii-port->port))
(define-interface netrc-interface (define-interface netrc-interface
(export user-mail-address (export netrc-machine-entry
netrc-lookup netrc-entry?
netrc-lookup-password netrc-entry-machine
netrc-lookup-login netrc-entry-login
netrc-parse netrc-entry-password
netrc-try-parse netrc-entry-account
netrc-refuse?)) netrc-macro-definitions))
(define-interface pop3-interface (define-interface pop3-interface
(export pop3-connect (export pop3-connect
@ -434,9 +434,7 @@
(define-structure netrc netrc-interface (define-structure netrc netrc-interface
(open scheme-with-scsh (open scheme-with-scsh
define-record-types define-record-types
conditions signals handle srfi-14)
sunet-utilities
let-opt)
(files (lib netrc))) (files (lib netrc)))
(define-structure pop3 pop3-interface (define-structure pop3 pop3-interface