sunet/scheme/lib/netrc.scm

;;; 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
;;
;; * 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, ecm-utilities


;;; 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 netrc-entry
  machine
  login
  password
  account)

(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-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 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