From c04d46910ce2180dcb9486d76afc2a68c973e974 Mon Sep 17 00:00:00 2001 From: sperber Date: Tue, 21 Jan 2003 14:20:13 +0000 Subject: [PATCH] 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. --- doc/latex/netrc.tex | 169 ++++----------- scheme/lib/ftp.scm | 10 +- scheme/lib/netrc.scm | 503 ++++++++++++------------------------------- scheme/lib/pop3.scm | 20 +- scheme/packages.scm | 18 +- 5 files changed, 203 insertions(+), 517 deletions(-) diff --git a/doc/latex/netrc.tex b/doc/latex/netrc.tex index 7bf0f1d..76e8b18 100644 --- a/doc/latex/netrc.tex +++ b/doc/latex/netrc.tex @@ -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 diff --git a/scheme/lib/ftp.scm b/scheme/lib/ftp.scm index b5d0f92..3c45164 100644 --- a/scheme/lib/ftp.scm +++ b/scheme/lib/ftp.scm @@ -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 diff --git a/scheme/lib/netrc.scm b/scheme/lib/netrc.scm index b1a09e0..d5ed5c3 100644 --- a/scheme/lib/netrc.scm +++ b/scheme/lib/netrc.scm @@ -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 ;;; 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)))))))) diff --git a/scheme/lib/pop3.scm b/scheme/lib/pop3.scm index 1539cc5..fcadb78 100644 --- a/scheme/lib/pop3.scm +++ b/scheme/lib/pop3.scm @@ -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 diff --git a/scheme/packages.scm b/scheme/packages.scm index ef66451..006f510 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -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