sunet/netrc.scm

186 lines
6.1 KiB
Scheme

;;; netrc.scm -- parse authentication information contained in ~/.netrc
;;
;; $Id: netrc.scm,v 1.1 2001/09/12 18:53:50 interp Exp $
;;
;; Copyright (C) 1998 Eric Marsden
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Library General Public
;; License as published by the Free Software Foundation; either
;; version 2 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Library General Public License for more details.
;;
;; You should have received a copy of the GNU Library General Public
;; License along with this library; if not, write to the Free
;; Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;
;; Please send suggestions and bug reports to <emarsden@mail.dotcom.fr>
;;; 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.
;;; Entry points =======================================================
;;
;; (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.
;;
;; (netrc:default-login) -> string | #f
;; Return the default login specified by the ~/.netrc file, or #f.
;;
;; (netrc:default-password) -> string | #f
;; Return the default password specified by the ~/.netrc file, or #f.
;;
;; (netrc:lookup machine) -> string x string x string
;; Return the login,password,account information for MACHINE
;; specified by the ~/.netrc file.
;;; Related work ========================================================
;;
;; * Graham Barr has written a similar library for Perl, called
;; Netrc.pm
;;
;; * ange-ftp.el (transparent remote file access for Emacs) parses the
;; user's ~/.netrc file
;;; Portability ==================================================
;;
;; getenv, scsh file primitives, regexp code, format
;; define-record
(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))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; nothing exported below
(define-record netrc
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 (netrc:parse)
(netrc:check-permissions)
(set! *netrc* '())
(let ((fd (open-input-file *netrc:file*)))
(for-each-line netrc:parse-line fd)))
;; raise error if any permissions are set for group or others.
(define (netrc:check-permissions)
(let ((perms (- (file-mode *netrc:file*) 32768)))
(if (positive? (bitwise-and #b000111111 perms))
(error "Not parsing ~/.netrc file; dangerous permissions"))))
(define (netrc: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)))
(if login
(set! *netrc:default-login* login))
(if password
(set! *netrc:default-password* password))))
(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))))))
(define (netrc:add machine login password account)
(set! *netrc* (cons (make-netrc machine login password account) *netrc*)))
;; for testing
(define (netrc:dump)
(format #t "~%--- Dumping ~~/.netrc contents ---")
(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 ---~%"))
(define (for-each-line proc fd)
(let ((line (read-line fd)))
(and (not (eof-object? line))
(proc line)
(for-each-line proc fd))))
(define (find-suchthat pred l)
(if (null? l) #f
(or (pred (car l))
(find-suchthat pred (cdr l)))))
; do we need this here?
;(netrc:parse)
;; EOF