395 lines
16 KiB
Scheme
395 lines
16 KiB
Scheme
;;; netrc.scm -- parse authentication information contained in ~/.netrc
|
|
|
|
;;; This file is part of the Scheme Untergrund Networking package.
|
|
|
|
;;; Copyright (c) 1998 by Eric Marsden
|
|
;;; Copyright (c) 2002 by Andreas Bernauer.
|
|
;;; 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
|
|
|
|
|
|
|
|
;;; 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))
|
|
|
|
|
|
|
|
;;; 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
|
|
|
|
|
|
;;; 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
|
|
|
|
|
|
; 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! (local-default-login)))
|
|
(if (eq? (netrc-default-password netrc-record) #f)
|
|
(set-netrc-default-password! (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
|
|
(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))
|
|
|
|
(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-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
|