diff --git a/modules.scm b/modules.scm index f81f6ee..51c5283 100644 --- a/modules.scm +++ b/modules.scm @@ -533,7 +533,8 @@ netrc:lookup-password netrc:lookup-login netrc:parse - netrc:try-parse)) + netrc:try-parse + netrc-refuse?)) (define-structure netrc netrc-interface (open defrec-package @@ -542,7 +543,7 @@ error-package ecm-utilities string-lib - conditions signals + conditions signals handle let-opt scheme) (files netrc)) diff --git a/netrc.scm b/netrc.scm index e0ac9b9..163dac5 100644 --- a/netrc.scm +++ b/netrc.scm @@ -1,6 +1,6 @@ ;;; netrc.scm -- parse authentication information contained in ~/.netrc ;; -;; $Id: netrc.scm,v 1.3 2001/12/18 18:08:08 interp Exp $ +;; $Id: netrc.scm,v 1.4 2001/12/27 16:45:32 interp Exp $ ;; ;; Please send suggestions and bug reports to @@ -27,7 +27,7 @@ ;; * 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 must not be the last line of the netrc-file +;; * default need not be the last line of the netrc-file @@ -36,22 +36,61 @@ ;; (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. +;; REPLYTO, if set. Otherwise the mail-address will look like +;; user@hostname. ;; -;; (netrc:default-login) -> string -;; Return the default login specified by the ~/.netrc file or "anonymous" +;; (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:default-password) -> string -;; Return the default password specified by the ~/.netrc file or -;; to the mail-addres (result of (user-mail-address)) +;; (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 machine) -> string x string x string -;; Return the login,password,account information for MACHINE -;; specified by the ~/.netrc file. -;; If there is no such machine specified, the condition 'netrc:no-such-entry -;; is signalled, that can be caught with with-handler. -;; If you catch this signal, you probably want to use netrc:default-login -;; and netrc:default-password, that are always set to usable values. +;; (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)) @@ -61,7 +100,7 @@ ;; Netrc.pm ;; ;; * ange-ftp.el (transparent remote file access for Emacs) parses the -;; user's ~/.netrc file +;; user's netrc file ;;; Portability ================================================== @@ -74,9 +113,12 @@ ;; ;; * Remove restrictions (as stated in 'Overview') and behave like ;; /usr/bin/ftp behaves -;; * perhaps: adding case-insensitivity +;; * perhaps: adding case-insensitivity (for host names) ;; * perhaps: better record-disclosers for netrc-entry- and netrc-records + +; 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)))) @@ -98,11 +140,11 @@ (values (netrc-entry:login record) (netrc-entry:password record) (netrc-entry:account record)) - (and lookup-default? - (values (netrc:default-login netrc-record) - (netrc:default-password netrc-record) - #f) - (values #f #f #f)))))) + (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?) @@ -141,38 +183,70 @@ ; 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, than a default netrc-record is returned -; if you don't want this, use netrc:try-parse; note that you have to -; resolve the file-name on your own +; * (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))) + (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-errno-handler* - (lambda (errno packet) - (if (= errno errno/noent) - (exit (make-netrc '() - (or default-login "anonymous") - (or default-password (user-mail-address)) - #f)))) + (with-handler + (lambda (error more) + (if (netrc-refuse? error) + (begin + (format (current-error-port) + "netrc: Warning: ~a~%" + (car (condition-stuff error))) + (exit (local-default-netrc-record))))) (lambda () - (let ((netrc-record (netrc:try-parse file-name default-password default-login))) - (if netrc-record - netrc-record - (begin - (set-netrc:default-password netrc-record (or default-password (user-mail-address))) - (set-netrc:default-login netrc-record (or default-login "anonymous")) - netrc-record)))))))))) + (with-errno-handler* + (lambda (errno packet) + (if (= errno errno/noent) + (begin + (format (current-error-port) + "netrc: Warning: no such file or directory: ~a~%" + file-name) + (exit (local-default-netrc-record))))) + (lambda () + (let ((netrc-record + (netrc:try-parse file-name default-password default-login))) + (if netrc-record + netrc-record + (begin + (set-netrc:default-password + netrc-record + (or default-password (local-default-password))) + (set-netrc:default-login + netrc-record + (or default-login (local-default-login))) + netrc-record)))))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; nothing exported below +;; except +;; netrc:default-password +;; netrc:default-login (define-record netrc-entry machine @@ -209,7 +283,10 @@ (define (netrc:check-permissions file-name) (let ((perms (- (file-mode file-name) 32768))) (if (positive? (bitwise-and #b000111111 perms)) - (error "Not parsing ~/.netrc file; dangerous permissions.")))) + (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