path: root/nclients.scm

;;; "nclients.scm" Interface to net-client programs.
; Copyright 1997, 1998 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
;granted, subject to the following restrictions and understandings.
;
;1.  Any copy made of this software must include this copyright notice
;in full.
;
;2.  I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3.  In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.

(require 'string-search)
(require 'line-i/o)
(require 'system)
(require 'printf)
(require 'scanf)

;;@args proc
;;@args proc k
;;Calls @1 with @var{k} arguments, strings returned by successive
;;calls to @code{tmpnam}.  If @1 returns, then any files named by the
;;arguments to @1 are deleted automatically and the value(s) yielded
;;by the @1 is(are) returned.  @var{k} may be ommited, in which case
;;it defaults to @code{1}.
(define (call-with-tmpnam proc . k)
  (do ((cnt (if (null? k) 0 (+ -1 (car k))) (+ -1 cnt))
       (paths '() (cons (tmpnam) paths)))
      ((negative? cnt)
       (let ((ans (apply proc paths)))
	 (for-each (lambda (path) (if (file-exists? path) (delete-file path)))
		   paths)
	 ans))))

;;@args
;;@0 returns a string of the form @samp{username@r{@@}hostname}.  If
;;this e-mail address cannot be obtained, #f is returned.
(define user-email-address
  (let ((user (or (getenv "USER") (getenv "USERNAME")))
	(hostname (getenv "HOSTNAME")))	;with domain
    (lambda ()
      (if (not (and user hostname))
	  (call-with-tmpnam
	   (lambda (tmp)
	     (define command->string
	       (lambda (command)
		 (and (zero? (system (string-append command " >" tmp)))
		      (file-exists? tmp)
		      (let ((res #f))
			(call-with-input-file tmp
			  (lambda (port)
			    (and (eqv? 1 (fscanf port "%s" res)) res)))))))
	     (case (software-type)
	       ;;((AMIGA)				)
	       ;;((MACOS THINKC)			)
	       ((MS-DOS WINDOWS OS/2 ATARIST)
		(let ((compname (getenv "COMPUTERNAME")) ;without domain
		      (workgroup #f)
		      (netdir (or (getenv "windir")
				  (getenv "winbootdir")
				  (and (getenv "SYSTEMROOT")
				       (string-append (getenv "SYSTEMROOT")
						      "\\system32"))
				  "C:\\windows")))
		  (define (net . cmd)
		    (zero? (system (apply string-append
					  (or netdir "")
					  (if netdir "\\" "")
					  "NET " cmd))))
		  (and (not (and user hostname))
		       (zero? (system (string-append
				       (or netdir "")
				       (if netdir "\\" "")
				       "IPCONFIG /ALL > " tmp " ")))
		       (file-exists? tmp)
		       ;;(print tmp '=) (display-file tmp)
		       (call-with-input-file tmp
			 (lambda (port)
			   (find-string-from-port? "Host Name" port)
			   (fscanf port " %*[. ]: %s" hostname)
			   (delete-file tmp))))
		  (and (not (and user hostname))
		       (net "START /LIST >" tmp)
		       (file-exists? tmp)
		       (not (eof-object? (call-with-input-file tmp read-char)))
		       (cond
			((call-with-input-file tmp
			   (lambda (port)
			     (find-string-from-port? "o network servic" port)))
			 (and (net "CONFIG /YES >" tmp)
			      (net "STOP /YES")))
			(else (net "CONFIG /YES >" tmp)))
		       (call-with-input-file tmp
			 (lambda (port)
			   (do ((line (read-line port) (read-line port)))
			       ((eof-object? line))
			     (sscanf line " Workstation root directory %s"
				     netdir)
			     (sscanf line " Computer name \\\\%s" compname)
			     (sscanf line " Workstation Domain %s" workgroup)
			     (sscanf line " Workgroup %s" workgroup)
			     (sscanf line " User name %s" user)))))
		  (and netdir (not (and user hostname))
		       (set! netdir (string-append netdir "\\system.ini"))
		       (file-exists? netdir)
		       (call-with-input-file netdir
			 (lambda (port)
			   (and (find-string-from-port? "[DNS]" port)
				(read-line port) ;past newline
				(do ((line (read-line port) (read-line port)))
				    ((not (and (string? line)
					       (string-index line #\=))))
				  (sscanf line "HostName=%s" compname)
				  (sscanf line "DomainName=%s" workgroup)))))
		       (not user)
		       (call-with-input-file netdir
			 (lambda (port)
			   (and (find-string-from-port? "[Network]" port)
				(read-line port) ;past newline
				(do ((line (read-line port) (read-line port)))
				    ((not (and (string? line)
					       (string-index line #\=))))
				  (sscanf line "UserName=%s" user))))))
		  (if (and compname (not hostname))
		      (set! hostname
			    (string-append
			     compname "." (or workgroup "localnet"))))))
	       ;;((NOSVE)				)
	       ;;((VMS)					)
	       ((UNIX COHERENT)
		(if (not user)
		    (set! user (command->string "whoami")))
		(if (not hostname)
		    (set! hostname (command->string "hostname")))))
	     (if (not user) (set! user "John_Doe"))
	     (if (not hostname) (set! hostname "localhost")))))
      (string-append user "@" hostname))))

;;@args
;;@0 returns a string containing the absolute file name representing
;;the current working directory.  If this string cannot be obtained,
;;#f is returned.
;;
;;If @0 cannot be supported by the platform, the value of @0 is
;;#f.
(define current-directory
  (case (software-type)
    ;;((AMIGA)				)
    ;;((MACOS THINKC)			)
    ((MS-DOS WINDOWS ATARIST OS/2)
     (lambda ()
       (call-with-tmpnam
	(lambda (tmp)
	  (and (zero? (system (string-append "cd >" tmp)))
	       (file-exists? tmp)
	       (call-with-input-file tmp
		 (lambda (port)
		   (let ((lst (scanf-read-list "%[^:]%[:] %s" port)))
		     (and (pair? lst)
			  (eqv? 3 (length lst))
			  (apply string-append lst))))))))))
    ;;((NOSVE)				)
    ((UNIX COHERENT)
     (lambda ()
       (call-with-tmpnam
	(lambda (tmp)
	  (and (zero? (system (string-append "pwd >" tmp)))
	       (file-exists? tmp)
	       (let ((path (call-with-input-file tmp read-line)))
		 (and (string? path) path)))))))
    ;;((VMS)				)
    (else #f)))

;;@body
;;Creates a sub-directory @1 of the current-directory.  If successful,
;;@0 returns #t; otherwise #f.
(define (make-directory name)
  (zero? (system (string-append "mkdir " name))))

;;@body
;;Returns #t if changing directory to @1 makes the current working
;;directory the same as it is before changing directory; otherwise
;;returns #f.
(define (null-directory? file-name)
  (member file-name '("" "." "./" ".\\")))

;;@body
;;Returns #t if @1 is a fully specified pathname (does not depend on
;;the current working directory); otherwise returns #f.
(define (absolute-path? file-name)
  (and (string? file-name)
       (positive? (string-length file-name))
       (memv (string-ref file-name 0) '(#\\ #\/))))


;;@body Returns #t if the string @1 contains characters used for
;;specifying glob patterns, namely @samp{*}, @samp{?}, or @samp{[}.
(define (glob-pattern? str)
  (let loop ((idx (+ -1 (string-length str))))
    (if (negative? idx)
	#f
	(case (string-ref str idx)
	  ((#\* #\[ #\?) #t)
	  (else (loop (+ -1 idx)))))))

;;@body
;;Returns a list of the decoded FTP @1; or #f if indecipherable.  FTP
;;@dfn{Uniform Resource Locator}, @dfn{ange-ftp}, and @dfn{getit}
;;formats are handled.  The returned list has four elements which are
;;strings or #f:
;;
;;@enumerate 0
;;@item
;;username
;;@item
;;password
;;@item
;;remote-site
;;@item
;;remote-directory
;;@end enumerate
(define (parse-ftp-address uri)
  (define length? (lambda (len lst) (and (eqv? len (length lst)) lst)))
  (cond
   ((not uri) #f)
   ((length? 1 (scanf-read-list " ftp://%s %s" uri))
    => (lambda (host)
	 (let ((login #f) (path #f) (dross #f))
	   (sscanf (car host) "%[^/]/%[^@]%s" login path dross)
	   (and login
		(append (cond
			 ((length? 2 (scanf-read-list "%[^@]@%[^@]%s" login))
			  => (lambda (userpass@hostport)
			       (append
				(cond ((length? 2 (scanf-read-list
						   "%[^:]:%[^@/]%s"
						   (car userpass@hostport))))
				      (else (list (car userpass@hostport) #f)))
				(cdr userpass@hostport))))
			 (else (list "anonymous" #f login)))
			(list path))))))
   (else
    (let ((user@site #f) (colon #f) (path #f) (dross #f))
      (case (sscanf uri " %[^:]%[:]%[^@] %s" user@site colon path dross)
	((2 3)
	 (let ((user #f) (site #f))
	   (cond ((or (eqv? 2 (sscanf user@site "/%[^@/]@%[^@]%s"
				      user site dross))
		      (eqv? 2 (sscanf user@site "%[^@/]@%[^@]%s"
				      user site dross)))
		  (list user #f site path))
		 ((eqv? 1 (sscanf user@site "@%[^@]%s" site dross))
		  (list #f #f site path))
		 (else (list #f #f user@site path)))))
	(else
	 (let ((site (scanf-read-list " %[^@/] %s" uri)))
	   (and (length? 1 site) (list #f #f (car site) #f)))))))))

;;@body
;;@3 must be a non-empty string or #f.  @1 must be a non-empty list
;;of pathnames or Glob patterns (@pxref{Filenames}) matching files to
;;transfer.
;;
;;@0 puts the files specified by @1 into the @5 directory of FTP @4
;;using name @2 with (optional) @3.
;;
;;If @3 is #f and @2 is not @samp{ftp} or @samp{anonymous}, then @2 is
;;ignored; FTP takes the username and password from the @file{.netrc}
;;or equivalent file.
(define (ftp-upload paths user password remote-site remote-dir)
  (call-with-tmpnam
   (lambda (script logfile)
     (define local-path (current-directory))
     (define passwd (or password (user-email-address)))
     (dynamic-wind
      (lambda () #f)
      (lambda ()
	(call-with-current-continuation
	 (lambda (exit)
	   (define (run-ftp-script paths)
	     (call-with-output-file script
	       (lambda (port)
		 (define lcd "")
		 (cond ((or (member user '(ftp anonymous "ftp" "anonymous"))
			    password)
			(fprintf port "user %s %s\n" user passwd)))
		 (fprintf port "binary\n") ; Turn binary ON for all transfers
		 ;;(fprintf port "prompt\n") ; Turn prompt OFF for possible mget
		 (if (not (null-directory? remote-dir))
		     (fprintf port "cd %s\n" remote-dir))
		 (for-each
		  (lambda (path-name)
		    (let* ((r/i (string-reverse-index path-name #\/))
			   (dir (if r/i (substring path-name 0 (+ 1 r/i)) ""))
			   (file-name (if r/i
					  (substring path-name (+ 1 r/i)
						     (string-length path-name))
					  path-name)))
		      (cond ((and r/i (glob-pattern? dir))
			     (slib:warn
			      "Wildcard not allowed in directory component "
			      path-name)
			     (exit #f))
			    ((and (not (glob-pattern? file-name))
				  (not (file-exists? path-name)))
			     (slib:warn " file doesn't exist:" path-name)
			     (exit #f))
			    ((equal? lcd dir))
			    ((absolute-path? dir)
			     (fprintf port "lcd %s\n" dir))
			    ((eqv? 0 (substring? lcd dir))
			     (fprintf port "lcd %s\n"
				      (substring dir (string-length lcd)
						 (string-length dir))))
			    (else
			     (fprintf port "lcd %s\n" local-path)
			     (if (not (null-directory? dir))
				 (fprintf port "lcd %s\n" dir))))
		      (set! lcd dir)
		      (cond ((glob-pattern? file-name)
			     (fprintf port "mput %s\n" file-name))
			    (else
			     (fprintf port "put %s\n" file-name)))))
		  paths)))
	     ;;(display-file script)
	     (cond
	      ((zero? (system
		       (string-append
			"ftp "
			(if (or (member user '(ftp anonymous "ftp" "anonymous"))
				password)
			    "-inv" "-iv")
			" " remote-site
			" <" script
			" >" logfile)))
	       (file-exists? logfile)
	       (call-with-input-file logfile
		 (lambda (port)
		   (do ((line (read-line port) (read-line port)))
		       ((or (eof-object? line)
			    (substring-ci? "Unknown host" line)
			    (substring-ci? "Not connected" line)
			    (and (memv (string-ref line 0) '(#\4 #\5))
				 (not (substring-ci? "bytes" line))))
			(cond ((eof-object? line) #t)
			      (else (slib:warn line) #f)))
		     ;;(write-line line)
		     ))))
	      (else (slib:warn 'ftp 'failed) #f)))
	   (cond ((or local-path (every? absolute-file? paths))
		  (run-ftp-script paths))
		 (else (for-each (lambda (path) (run-ftp-script (list path)))
				 paths))))))
      (lambda ()
	(if (file-exists? script) (delete-file script))
	(if (file-exists? logfile) (delete-file logfile)))))
   2))

;;@body
;;Returns a URI-string for @1 on the local host.
(define (path->uri path)
  (if (absolute-path? path)
      (sprintf #f "file:%s" path)
      (sprintf #f "file:%s/%s" (current-directory) path)))

;;@body
;;If a @samp{netscape} browser is running, @0 causes the browser to
;;display the page specified by string @1 and returns #t.
;;
;;If the browser is not running, @0 runs @samp{netscape} with the
;;argument @1.  If the browser starts as a background job, @0 returns
;;#t immediately; if the browser starts as a foreground job, then @0
;;returns #t when the browser exits; otherwise it returns #f.
(define (browse-url-netscape url)
  (or (eqv? 0 (system (sprintf #f "netscape-remote -remote 'openURL(%s)'" url)))
      (eqv? 0 (system (sprintf #f "netscape -remote 'openURL(%s)'" url)))
      (eqv? 0 (system (sprintf #f "netscape '%s'&" url)))
      (eqv? 0 (system (sprintf #f "netscape '%s'" url)))))