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

169
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}
\item[Used files:] netrc.scm
\item[Name of the package:] netrc
\end{description}
%
\section{Overview}
This module provides procedures to parse authentication information
contained in \ex{~/.netrc}.
The \ex{netrc} structures provides procedures to parse authentication
information contained in \ex{~/.netrc}.
On Unix systems the \ex{~/.netrc} file (in the user's home directory)
may contain information allowing automatic login to remote hosts. The
format of the file is defined in the \ex{ftp}(1) manual page. Example
lines are
\begin{alltt}
On Unix systems the netrc file may contain information allowing
automatic login to remote hosts. The format of the file is defined in
the \ex{ftp(1)} manual page. Example lines are
%
\begin{verbatim}
machine ondine.cict.fr login marsden password secret
default login anonymous password user@site%
\end{alltt}
The \ex{~/.netrc} file should be protected by appropriate permissions, and
default login anonymous password user@site
\end{verbatim}
%
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
badly protected. (unlike \ex{ftp} this library will always refuse
to read the file -- \ex{ftp} refuses it only if the password is
given for a non-default account). Appropriate permissions are set if
badly protected. (unlike \ex{ftp} this library will always refuse
to read the file----\ex{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 and differences:
\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}
\defun{netrc-machine-entry}{host accept-default? [file-name]}{netrc-entry-or-\sharpf}
\begin{desc}
Return the login, password and / or account information for
\semvar{machine} specified by \semvar{netrc-record}, respectively.
If \semvar{default?} is \sharpt, default values are returned if no
such \semvar{machine} is specified in the \semvar{netrc-record}.
Otherwise [\sharpf\ \sharpf\ \sharpf] or \sharpf\ is returned,
respectively.
This procedure looks for the entry related to given host in the
user's netrc file. The host is specified in \var{host}.
\var{Accept-default?} specifies whether \ex{netrc-machine-entry}
should fall back to the default entry if there is no macht for
\var{host} in the netrc file. If specified, \var{file-name}
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}
\defun{netrc:default-login}{netrc-record}{string}
\begin{defundescx}{netrc:default-password}{netrc-record}{string}
Return the default values for the login or the password, respectively,
specified by \semvar{netrc-record}. If the netrc file did not
specify a default login, ``anonymous'' is returned by
\ex{netrc:\ob{}default\=login}. If the netrc file did not specify a
default password, the result of the call to \ex{user\=mail\=address}
is returned by \ex{netrc:\ob{}default\=password}.
\end{defundescx}
\defun{netrc-entry?}{thing}{boolean}
\defunx{netrc-entry-machine}{netrc-entry}{string}
\defunx{netrc-entry-login}{netrc-entry}{string-or-\sharpf}
\defunx{netrc-entry-password}{netrc-entry}{string-or-\sharpf}
\defunx{netrc-entry-account}{netrc-entry}{string-or-\sharpf}
\begin{desc}
\ex{Netrc-entry?} is the predicate for netrc entries. The other
procedures are selectors for netrc entries as returned by
\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}
\begin{itemize}
\item Graham Barr has written a similar library for Perl, called
\ex{Netrc.pm}.
\item \ex{ange-ftp.el} (transparent remote file access for Emacs)
parses the user's netrc file.
\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}
\defun{netrc-macro-definitions}{[file-name]}{alist}
\begin{desc}
This returns the macro definitions from the netrc files, represented
as an alist mapping macro names---represented as strings---to
definitions---represented as lists of strings.
\end{desc}
%%% Local Variables:
%%% mode: latex

10
scheme/lib/ftp.scm
View File

@ -104,11 +104,11 @@
(cond
(netrc-record)
(else
(set! netrc-record (netrc-parse))
(set! netrc-record
(netrc-machine-entry (ftp-connection-host-name connection) #t))
netrc-record)))))
(let ((login (or login
(netrc-lookup-login (get-netrc-record)
(ftp-connection-host-name connection)))))
(netrc-entry-login (get-netrc-record)))))
(let ((reply
(ftp-send-command connection (build-command "USER" login)
(lambda (code)
@ -120,9 +120,7 @@
(build-command
"PASS"
(or password
(netrc-lookup-password (get-netrc-record)
(ftp-connection-host-name
connection))))
(netrc-entry-password (get-netrc-record))))
(exactly-code "230")))))))
(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.
;;; Copyright (c) 1998 by Eric Marsden
;;; Copyright (c) 2002 by Andreas Bernauer.
;;; Copyright (c) 2003 by Mike Sperber <sperber@informatik.uni-tuebingen.de>
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;; Overview =====================================================
;;
;; On Unix systems the ~/.netrc file (in the user's home directory)
;; may contain information allowing automatic login to remote hosts.
;; 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 (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))))))
;;; Entry points =======================================================
;;
;; What you probably want, is to read out the default netrc-file. Do the
;; following:
;;
;; (let ((netrc-record (netrc-parse)))
;; (netrc-lookup netrc-record "name of the machine"))
;;
;; and you will receive three values: login-name, password and account-name.
;; If you only want the login-name or the password, use netrc-lookup-login
;; or netrc-lookup-password resp.
;;
;; 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 (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 '()))
;;; Related work ========================================================
;;
;; * Graham Barr has written a similar library for Perl, called
;; Netrc.pm
;;
;; * EFS (transparent remote file access for Emacs) parses the
;; user's netrc file
(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)))))))
;;; Desirable things =============================================
;;
;; * Remove restrictions (as stated in 'Overview') and behave like
;; /usr/bin/ftp behaves
;; * perhaps: adding case-insensitivity (for host names)
;; * perhaps: better record-disclosers for netrc-entry- and netrc-records
(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)))))))
; return the user's mail address, either specified by the environment
; variable REPLYTO or "user@hostname".
(define (user-mail-address)
(or (getenv "REPLYTO")
(string-append (user-login-name) "@" (system-fqdn))))
; looks up the desired machine in a netrc-record
; if the machine is found in the entries-section
; 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 (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)
(login netrc-entry-login)
(password netrc-entry-password)
(account netrc-entry-account))
(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-record-type netrc :netrc
(make-netrc entries default-login default-password file-name)
netrc?
;; list of netrc-entrys
(entries netrc-entries set-netrc-entries!)
;; default-values (either library-default or netrc-file-default)
(default-login netrc-default-login set-netrc-default-login!)
(default-password netrc-default-password set-netrc-default-password!)
(file-name netrc-file-name set-netrc-file-name!))
(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-record-discloser :netrc-entry
(lambda (netrc-entry)
(list 'netrc-entry))) ; perhaps something else later on
(define-record-discloser :netrc
(lambda (netrc)
(list 'netrc))) ; perhaps something else later on
; finds a record in the entries-list of a netrc-record
; matching the given machine
; returns the netrc-entry-record if found, otherwise #f
(define (find-record netrc-record machine)
(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
(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))))))))

20
scheme/lib/pop3.scm
View File

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

18
scheme/packages.scm
View File

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