* in netrc.scm:
- changes to make Eric's code fit our desires:
. functional concept (netrc:parse returns a record that has to be carried with)
. usual errors (no such file, no such machine) are caught and handled adequately
(nevertheless the user can get the errors, if he wants to)
. netrc:parse works when no ~/.netrc file exists
. default-values (file-name, login, password) can be set while
calling netrc:parse
. netrc:lookup, netrc:lookup-password, netrc:lookup-login return
default-values by default (can be switched off)
- removed bug in netrc:lookup
* in modules.scm:
new export in netrc-interface: netrc:try-parse (returns error if
file does not exist)
* in ecm-utilities:
rewrote nslookup-fqdn: uses host-info now
This commit is contained in:
interp
parent
75633864c3
commit
89bb20c63e
|
|
@ -1,6 +1,6 @@
|
|||
;; ecm-utilities.scm -- Utility procedures for ecm-net code
|
||||
;;
|
||||
;; $Id: ecm-utilities.scm,v 1.2 2001/11/15 11:12:23 mainzelm Exp $
|
||||
;; $Id: ecm-utilities.scm,v 1.3 2001/12/18 18:08:08 interp Exp $
|
||||
;;
|
||||
;; Please send suggestions and bug reports to <emarsden@mail.dotcom.fr>
|
||||
|
||||
|
|
@ -12,12 +12,19 @@
|
|||
sysname
|
||||
(nslookup-fqdn))))
|
||||
|
||||
;; This doesn't work on my system. Probably it is not configured well.
|
||||
;; Nevertheless, the alternative seems better to me
|
||||
;(define (nslookup-fqdn)
|
||||
; (let* ((cmd (format #f "nslookup ~a" (system-name)))
|
||||
; (raw (string-join (run/strings (nslookup ,(system-name)))))
|
||||
; (match (string-match "Name: +([-a-zA-Z0-9.]+)" raw)))
|
||||
; (display raw)
|
||||
; (match:substring match 1)))
|
||||
|
||||
(define (nslookup-fqdn)
|
||||
(let* ((cmd (format #f "nslookup ~a" (system-name)))
|
||||
(raw (string-join (run/strings (nslookup ,(system-name)))))
|
||||
(match (string-match "Name: +([-a-zA-Z0-9.]+)" raw)))
|
||||
(display raw)
|
||||
(match:substring match 1)))
|
||||
(host-info:name (host-info (system-name))))
|
||||
; another easy alternative:
|
||||
; (car (run/strings (hostname "--long"))))
|
||||
|
||||
|
||||
;; prefer this to :optional
|
||||
|
|
|
|||
|
|
@ -529,19 +529,21 @@
|
|||
|
||||
(define-interface netrc-interface
|
||||
(export user-mail-address
|
||||
netrc:default-login
|
||||
netrc:default-password
|
||||
netrc:lookup
|
||||
netrc:lookup-password
|
||||
netrc:lookup-login
|
||||
netrc:parse))
|
||||
netrc:parse
|
||||
netrc:try-parse))
|
||||
|
||||
(define-structure netrc netrc-interface
|
||||
(open defrec-package
|
||||
records
|
||||
scsh
|
||||
error-package
|
||||
ecm-utilities
|
||||
string-lib
|
||||
conditions signals
|
||||
let-opt
|
||||
scheme)
|
||||
(files netrc))
|
||||
|
||||
|
|
|
|||
274
netrc.scm
274
netrc.scm
|
|
@ -1,6 +1,6 @@
|
|||
;;; netrc.scm -- parse authentication information contained in ~/.netrc
|
||||
;;
|
||||
;; $Id: netrc.scm,v 1.2 2001/11/15 11:12:24 mainzelm Exp $
|
||||
;; $Id: netrc.scm,v 1.3 2001/12/18 18:08:08 interp Exp $
|
||||
;;
|
||||
;; Please send suggestions and bug reports to <emarsden@mail.dotcom.fr>
|
||||
|
||||
|
|
@ -18,7 +18,17 @@
|
|||
;;
|
||||
;; 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.
|
||||
;; 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 must not be the last line of the netrc-file
|
||||
|
||||
|
||||
|
||||
;;; Entry points =======================================================
|
||||
|
|
@ -28,15 +38,21 @@
|
|||
;; the same name. Will take into account the environment variable
|
||||
;; REPLYTO, if set.
|
||||
;;
|
||||
;; (netrc:default-login) -> string | #f
|
||||
;; Return the default login specified by the ~/.netrc file, or #f.
|
||||
;; (netrc:default-login) -> string
|
||||
;; Return the default login specified by the ~/.netrc file or "anonymous"
|
||||
;;
|
||||
;; (netrc:default-password) -> string | #f
|
||||
;; Return the default password specified by the ~/.netrc file, or #f.
|
||||
;; (netrc:default-password) -> string
|
||||
;; Return the default password specified by the ~/.netrc file or
|
||||
;; to the mail-addres (result of (user-mail-address))
|
||||
;;
|
||||
;; (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.
|
||||
|
||||
|
||||
|
||||
;;; Related work ========================================================
|
||||
|
|
@ -51,119 +67,221 @@
|
|||
;;; Portability ==================================================
|
||||
;;
|
||||
;; getenv, scsh file primitives, regexp code, format
|
||||
;; define-record
|
||||
;; define-record, ecm-utilities
|
||||
|
||||
|
||||
;;; Desirable things =============================================
|
||||
;;
|
||||
;; * Remove restrictions (as stated in 'Overview') and behave like
|
||||
;; /usr/bin/ftp behaves
|
||||
;; * perhaps: adding case-insensitivity
|
||||
;; * perhaps: better record-disclosers for netrc-entry- and netrc-records
|
||||
|
||||
(define (user-mail-address)
|
||||
(or (getenv "REPLYTO")
|
||||
(string-append (user-login-name) "@" (system-fqdn))))
|
||||
|
||||
(define (netrc:default-login) *netrc:default-login*)
|
||||
(define (netrc:default-password) *netrc:default-password*)
|
||||
|
||||
;;: string -> string x string x string
|
||||
(define (netrc:lookup machine)
|
||||
(let ((record
|
||||
(find-suchthat (lambda (rec)
|
||||
(and (equal? (netrc:machine rec) machine)
|
||||
(list (netrc:login rec)
|
||||
(netrc:password rec)
|
||||
(netrc:account rec))))
|
||||
*netrc*)))
|
||||
(values (netrc:login record)
|
||||
(netrc:password record)
|
||||
(netrc:account record))))
|
||||
|
||||
(define (netrc:lookup-password machine)
|
||||
(receive (login password account)
|
||||
(netrc:lookup machine)
|
||||
password))
|
||||
|
||||
(define (netrc:lookup-login machine)
|
||||
(receive (login password account)
|
||||
(netrc:lookup machine)
|
||||
login))
|
||||
; 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))
|
||||
(and 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, 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
|
||||
(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)))
|
||||
(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))))
|
||||
(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))))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; nothing exported below
|
||||
|
||||
(define-record netrc
|
||||
(define-record netrc-entry
|
||||
machine
|
||||
login
|
||||
password
|
||||
account)
|
||||
|
||||
(define *netrc* '())
|
||||
(define *netrc:default-login* "anonymous")
|
||||
(define *netrc:default-password* (user-mail-address))
|
||||
(define *netrc:file* (resolve-file-name "~/.netrc"))
|
||||
(define-record netrc
|
||||
entries ; list of netrc-entrys
|
||||
default-login ; default-values (either library-default or netrc-file-default)
|
||||
default-password
|
||||
file-name) ; debug-purpose
|
||||
|
||||
|
||||
(define (netrc:parse)
|
||||
(netrc:check-permissions)
|
||||
(set! *netrc* '())
|
||||
(let ((fd (open-input-file *netrc:file*)))
|
||||
(for-each-line netrc:parse-line fd)))
|
||||
(define-record-discloser type/netrc-entry
|
||||
(lambda (netrc-entry)
|
||||
(list 'netrc-entry))) ; perhaps something else later on
|
||||
|
||||
(define-record-discloser type/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)
|
||||
(let ((perms (- (file-mode *netrc:file*) 32768)))
|
||||
(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"))))
|
||||
(error "Not parsing ~/.netrc file; dangerous permissions."))))
|
||||
|
||||
(define (netrc:try-match target line)
|
||||
; 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))))
|
||||
|
||||
(define (netrc:parse-default line)
|
||||
(let ((login (netrc:try-match "login[ \t]+([^ \t]+)" line))
|
||||
(password (netrc:try-match "password[ \t]+([^ \t]+)" line)))
|
||||
; 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* login))
|
||||
(set-netrc:default-login netrc-record login))
|
||||
(if password
|
||||
(set! *netrc:default-password* password))))
|
||||
(set-netrc:default-password netrc-record password))
|
||||
netrc-record))
|
||||
|
||||
(define (netrc:parse-line line)
|
||||
(cond ((string-match "default" line)
|
||||
(netrc:parse-default line))
|
||||
(else
|
||||
(let ((machine (netrc:try-match "machine[ \t]+([^ \t]+)" line))
|
||||
(login (netrc:try-match "login[ \t]+([^ \t]+)" line))
|
||||
(password (netrc:try-match "password[ \t]+([^ \t]+)" line))
|
||||
(account (netrc:try-match "account[ \t]+([^ \t]+)" line)))
|
||||
(if (or machine login password account)
|
||||
(netrc:add machine login password account))))))
|
||||
; 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)))))))
|
||||
|
||||
(define (netrc:add machine login password account)
|
||||
(set! *netrc* (cons (make-netrc machine login password account) *netrc*)))
|
||||
; 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)
|
||||
(format #t "~%--- Dumping ~~/.netrc contents ---")
|
||||
(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:machine rec)
|
||||
(netrc:login rec)
|
||||
(netrc:password rec)
|
||||
(netrc:account rec)))
|
||||
*netrc*)
|
||||
(format #t "~%--- End of ~~/.netrc contents ---~%"))
|
||||
(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)))
|
||||
(and (not (eof-object? line))
|
||||
(proc line)
|
||||
(for-each-line proc 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))))))
|
||||
|
||||
(define (find-suchthat pred l)
|
||||
; 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-suchthat pred (cdr l)))))
|
||||
|
||||
; do we need this here?
|
||||
;(netrc:parse)
|
||||
(find-first pred (cdr l)))))
|
||||
|
||||
;; EOF
|
||||
|
|
|
|||
Loading…
Reference in New Issue