slib 3b1-5 / usr / share / slib / transact.scm

;;; "transact.scm" Interface to programs.
; Copyright 1997, 1998, 2002, 2008 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 warranty 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 'filename)
(require 'line-i/o)
(require 'system)
(require 'printf)
(require 'scanf)
(require 'byte)
(require-if 'compiling 'directory)

;;@subsubheading File Locking
;;
;;@noindent
;;Unix file-locking is focussed on write permissions for segments of a
;;existing file.  While this might be employed for (binary) database
;;access, it is not used for everyday contention (between users) for
;;text files.
;;
;;@noindent
;;Microsoft has several file-locking protocols.  Their model denies
;;write access to a file if any reader has it open.  This is too
;;restrictive.  Write access is denied even when the reader has
;;reached end-of-file.  And tracking read access (which is much more
;;common than write access) causes havoc when remote hosts crash or
;;disconnect.
;;
;;@noindent
;;It is bizarre that the concept of multi-user contention for
;;modifying files has not been adequately addressed by either of the
;;large operating system development efforts.  There is further irony
;;that both camps support contention detection and resolution only
;;through weak conventions of some their document editing programs.
;;
;;@noindent
;;@cindex file-lock
;;The @dfn{file-lock} procedures implement a transaction method for file
;;replacement compatible with the methods used by the GNU @dfn{emacs}
;;text editor on Unix systems and the Microsoft @dfn{Word} editor.
;;@cindex emacs
;;
;;@noindent
;;@cindex certificate
;;Both protocols employ what I term a @dfn{certificate} containing the
;;user, hostname, time, and (on Unix) process-id.
;;Intent to replace @var{file} is indicated by adding to @var{file}'s
;;directory a certificate object whose name is derived from
;;@var{file}.
;;
;;@noindent
;;The Microsoft Word certificate is contained in a 162 byte file named
;;for the visited @var{file} with a @samp{~$} prefix.
;;Emacs/Unix creates a symbolic link to a certificate named for the
;;visited @var{file} prefixed with @samp{.#}.
;;Because Unix systems can import Microsoft file systems, these
;;routines maintain and check both Emacs and Word certificates.

;;Returns a string naming the path of the emacs-style file-lock symbolic
;;link associated with @1.
(define (emacs-lock:path path)
  (let* ((dir (pathname->vicinity path))
	 (file (substring path (string-length dir) (string-length path))))
    (in-vicinity dir (string-append ".#" file))))

;;Returns a string naming the path of the ms-word style lock file
;;associated with @1.
(define (word-lock:path path)
  (let* ((dir (pathname->vicinity path))
	 (file (substring path (string-length dir) (string-length path)))
	 (filen (string-length file)))
    (in-vicinity
     dir (string-append
	  "~$" (substring file (min 2 (max 0 (- filen 10))) filen)))))

(define (word-lock:certificate lockpath)
  (define iport (open-file lockpath 'rb))
  (and
   iport
   (call-with-open-ports
    (lambda (iport)
      (define len (read-byte iport))
      (define pos 1)
      (and (number? len)
	   (let ((name (make-string len)))
	     (define (discard cnt)
	       (do ((cnt (+ -1 cnt) (+ -1 cnt)))
		   ((or (eof-object? (peek-char iport)) (negative? cnt))
		    (negative? cnt))
		 (or (eof-object? (read-byte iport)) (set! pos (+ 1 pos)))))
	     (define (read-field)
	       (define len (read-byte iport))
	       (set! pos (+ 1 pos))
	       (or (eof-object? (read-byte iport)) (set! pos (+ 1 pos)))
	       (and (number? len)
		    (let ((str (make-string len)))
		      (do ((idx 0 (+ 1 idx)))
			  ((or (eof-object? (peek-char iport)) (>= idx len))
			   (and (>= idx len) str))
			(string-set! str idx (read-char iport))
			(or (eof-object? (read-char iport)) (set! pos (+ 2 pos)))))))
;;; read compact name
	     (do ((idx 0 (+ 1 idx)))
		 ((or (eof-object? (peek-char iport)) (>= idx len)))
	       (string-set! name idx (read-char iport))
	       (set! pos (+ 1 pos)))
;;; read expanded names (interleaved with nul)
;;; I think this is probably UTF-16.
	     (let* ((name2 (and (discard (- 54 pos)) (read-field)))
		    (company (and (discard 6) (read-field)))
		    (name3 (and (discard 8) (read-field))))
	       (define (check field fieldname)
		 (cond ((not field) (slib:warn 'missing fieldname))
		       ((equal? name field))
		       (else (slib:warn fieldname 'mismatch name field))))
	       (check name2 'name2)
	       (check name3 'name3)
	       (or (and (eof-object? (peek-char iport)) (= pos 162))
		   (and (not (and (discard (- 162 pos))
				  (eof-object? (peek-char iport))))
			(slib:error lockpath 'length pos '(not = 162))))
	       (and name company (sprintf #f "%s@%s" name company))))))
    iport)))

(define (emacs-lock:certificate lockpath)
  (define conflict
    (system->line (sprintf #f "ls -ld %#a 2>/dev/null" lockpath)))
  (cond ((and conflict (substring? "-> " conflict))
	 => (lambda (idx)
	      (substring conflict (+ 3 idx) (string-length conflict))))
	((and conflict (not (equal? conflict ""))) (slib:error 'bad 'emacs 'lock lockpath conflict))
	(else #f)))

(define (file-lock:certificate path)
  (or (case (software-type)
	((unix coherent plan9)
	 (emacs-lock:certificate (emacs-lock:path path)))
	(else #f))
      (word-lock:certificate (word-lock:path path))))

;;@body
;;Returns the string @samp{@var{user}@@@var{hostname}} associated with
;;the lock owner of file @1 if locked; and #f otherwise.
(define (file-lock-owner path)
  (or (emacs-lock:certificate (emacs-lock:path path))
      (word-lock:certificate (word-lock:path path))))

(define (word:lock! path email)
  (define lockpath (word-lock:path path))
  (define at (substring? "@" email))
  (let ((user (substring email 0 at))
	(hostname (substring email (+ 1 at) (string-length email)))
	(oport (open-file lockpath 'wb)))
    (define userlen (string-length user))
    (and oport
	 (call-with-open-ports
	  oport (lambda (oport)
		  (define pos 1)
		  (define (nulls cnt)
		    (write-bytes (make-bytes cnt 0) cnt oport)
		    (set! pos (+ cnt pos)))
		  (define (write-field field)
		    (define len (string-length field))
		    (write-byte len oport)
		    (write-byte 0 oport)
		    (set! pos (+ 2 pos))
		    (do ((idx 0 (+ 1 idx)))
			((>= idx len))
		      (write-char (string-ref field idx) oport)
		      (write-byte 0 oport)
		      (set! pos (+ 2 pos))))
		  (write-byte userlen oport)
		  (display user oport) (set! pos (+ userlen pos))
;;; write expanded names (interleaved with nul)
		  (nulls (- 54 pos))
		  (write-field user)
		  (nulls 6)
		  (write-field hostname)
		  (nulls 8)
		  (write-field user)
		  (nulls (- 162 pos))
		  (if (not (eqv? 162 pos))
		      (slib:error lockpath 'length pos '(not = 162)))
		  #t))
	 (let ((certificate (word-lock:certificate lockpath)))
	   (and (equal? email certificate) email)))))

(define (emacs:lock! path email)
  (define lockpath (emacs-lock:path path))
  (define certificate (sprintf #f "%s.%s:%d"
			       email
			       (or (system->line "echo $PPID") "")
			       (current-time)))
  (and (eqv? 0 (system (sprintf #f "ln -s %#a %#a" certificate lockpath)))
       (let ((e-cert (emacs-lock:certificate lockpath)))
	 (and (equal? certificate e-cert)
	      certificate))))

;;@args path email
;;@args path
;;
;;@1 must be a string naming the file to be locked.  If supplied, @2
;;must be a string formatted as @samp{@var{user}@@@var{hostname}}.  If
;;absent, @2 defaults to the value returned by @code{user-email-address}.
;;
;;If @1 is already locked, then @0 returns @samp{#f}.  If @1 is
;;unlocked, then @0 returns the certificate string associated with the
;;new lock for file @1.
(define (file-lock! path . email)
  (set! email (if (null? email) (user-email-address) (car email)))
  (and (string? email)
       (not (file-lock:certificate path))
       (let ((wl (word:lock! path email)))
	 (case (software-type)
	   ((unix coherent plan9)
	    ;; file-system may not support symbolic links.
	    (or (and (provided? 'current-time) (emacs:lock! path email))
		wl))
	   (else wl)))))

;;@body
;;@1 must be a string naming the file to be unlocked.  @2 must be the
;;string returned by @code{file-lock!} for @1.
;;
;;If @1 is locked with @2, then @0 removes the locks and returns
;;@samp{#t}.  Otherwise, @0 leaves the file system unaltered and returns
;;@samp{#f}.
(define (file-unlock! path certificate)
  (define w-path (word-lock:path path))
  (let ((w-cert (word-lock:certificate w-path)))
    (cond ((not w-cert) #f)
	  ((not certificate) #f)
	  ((equal? w-cert certificate)	; word certificate only
					; (emacs certificate is longer)
	   (delete-file w-path))
	  ((not (eqv? 0 (substring? w-cert certificate)))
	   ;; word certificate doesn't match emacs certificate
	   (slib:warn 'file-unlock! w-path 'mismatch certificate) #f)
	  (else
	   (let ((e-path (emacs-lock:path path)))
	     (define e-cert (emacs-lock:certificate e-path))
	     (case (software-type)
	       ((unix coherent plan9)
		(cond ((not (equal? e-cert certificate))
		       (slib:warn 'file-unlock! e-path 'mismatch certificate)
		       #f)
		      (else (and (delete-file e-path)
				 (delete-file w-path)))))
	       (else (delete-file w-path))))))))

;;@args path prefix
;;@args path
;;@1 must be a string naming a file.  Optional argument @2 is a string
;;printed before each line of the message.  @0 prints to
;;@code{(current-error-port)} that @1 is locked for writing and lists
;;its lock-files.
;;
;;@example
;;(describe-file-lock "my.txt" ">> ")
;;@print{}
;;>> "my.txt" is locked for writing by 'luser@@no.com.4829:1200536423'
;;>> (lock files are "~$my.txt" and ".#my.txt")
;;@end example
(define (describe-file-lock path . prefix)
  (define cep (current-error-port))
  (define w-path (word-lock:path path))
  (define e-path (emacs-lock:path path))
  (set! prefix (if (null? prefix) "" (car prefix)))
  (let ((w-cert (word-lock:certificate w-path))
	(e-cert (emacs-lock:certificate e-path)))
    (cond ((or (file-exists? w-path) (file-exists? e-path))
	   (fprintf cep
		    "%s\"%s\" is locked for writing by '%s'\\n"
		    prefix
		    path
		    (or e-cert w-cert '??)))
	  (else
	   (fprintf cep
		    "%s\"%s\" is not locked for writing\\n"
		    prefix
		    path)))
    (if e-cert
	(fprintf cep "%s(lock files are \"%s\" and \"%s\")\\n"
		 prefix w-path e-path)
	(fprintf cep "%s(lock file is \"%s\")\\n"
		 prefix w-path))
    (force-output cep)))

;;;@subsubheading File Transactions

(define (emacs:backup-number path)
  (let* ((dir (pathname->vicinity path))
	 (file (substring path (string-length dir) (string-length path)))
	 (largest #f))
    (require 'directory)
    (if (equal? "" dir) (set! dir "./"))
    (directory-for-each
     (lambda (str)
       (define left.~ (substring? ".~" str))
       (cond ((not left.~))
	     ((not (equal? file (substring str 0 left.~))))
	     ((string->number (substring str
					 (+ 2 left.~)
					 (string-reverse-index str #\~)))
	      => (lambda (number)
		   (set! largest (max number (or largest number)))))))
     dir (string-append file "*~*[0-9]~"))
    largest))

;;@body
;;@1 must be a string.  @2 must be a symbol.  Depending on @2, @0
;;returns:
;;@table @r
;;@item none
;;#f
;;@item simple
;;the string "@1~"
;;@item numbered
;;the string "@1.~@var{n}~", where @var{n} is one greater than the
;;highest number appearing in a filename matching "@1.~*~".  @var{n}
;;defauls to 1 when no filename matches.
;;@item existing
;;the string "@1.~@var{n}~" if a numbered backup already exists in
;;this directory; otherwise. "@1~"
;;@item orig
;;the string "@1.orig"
;;@item bak
;;the string "@1.bak"
;;@end table
(define (emacs:backup-name path backup-style)
  (define (numbered bn) (sprintf #f "%s.~%d~" path (+ 1 (or bn 0))))
  (define (simple) (string-append path "~"))
  (case backup-style
    ((none #f) #f)
    ((simple) (simple))
    ((numbered) (numbered (emacs:backup-number path)))
    ((existing) (let ((bn (emacs:backup-number path)))
		  (if bn (numbered bn) (simple))))
    ((orig bak) (sprintf #f "%s.%s" path backup-style))
    (else
     (slib:error 'emacs:backup-name 'unknown 'backup-style backup-style))))

;;@args proc path backup-style certificate
;;@args proc path backup-style
;;@args proc path
;;
;;@2 must be a string naming an existing file.  @3 is one of the
;;symbols @r{none}, @r{simple}, @r{numbered}, @r{existing}, @r{orig},
;;@r{bak} or @r{#f}; with meanings described above; or a string naming
;;the location of a backup file.  @3 defaults to @r{#f}.  If supplied,
;;@4 is the certificate with which @2 is locked.
;;
;;@1 must be a procedure taking two string arguments:
;;@itemize @bullet
;;@item
;;@2, the original filename (to be read); and
;;@item
;;a temporary file-name.
;;@end itemize
;;
;;If @2 is locked by other than @4, or if @4 is supplied and @2 is not
;;locked, then @0 returns #f.  If @4 is not supplied, then, @0 creates
;;temporary (Emacs and Word) locks for @2 during the transaction.  The
;;lock status of @2 will be restored before @0 returns.
;;
;;@0 calls @1 with @2 (which should not be modified) and a temporary
;;file path to be written.
;;If @1 returns any value other than @r{#t}, then the file named by @2
;;is not altered and @0 returns @r{#f}.
;;Otherwise, @code{emacs:backup-name} is called with @2 and @3.  If it
;;returns a string, then @2 is renamed to it.
;;
;;Finally, the temporary file is renamed @2.
;;@0 returns #t if @2 was successfully replaced; and #f otherwise.
(define (transact-file-replacement proc path . args)
  (define certificate (case (length args)
			((2) (cadr args))
			((1 0) #f)
			(else (slib:error 'transact-file-replacement
					  (+ 2 (length args)) 'args))))
  (define backup-style (if (null? args) #f (car args)))
  (define move (case (software-type)
		 ((unix coherent plan9) "mv -f")
		 ((ms-dos windows os/2 atarist) "MOVE /Y")
		 (else (slib:error (software-type) 'move?))))
  (define (move? tmpfn path)
    (eqv? 0 (system (sprintf #f "%s %#a %#a" move tmpfn path))))
  (let* ((dir (pathname->vicinity path))
	 (file (substring path (string-length dir) (string-length path)))
	 (tmpfn (in-vicinity dir (string-append "#" file "#"))))
    (cond ((not (file-exists? path)) (slib:warn 'file path 'missing) #f)
	  (else
	   (let ((f-cert (file-lock:certificate path)))
	     (cond ((and f-cert (not (equal? certificate f-cert)))
		    (slib:warn 'file path 'locked 'by f-cert) #f)
		   ((and (file-exists? tmpfn)
			 (slib:warn 'file tmpfn 'exists)
			 (not (delete-file tmpfn)))
		    #f)
		   ((or certificate (file-lock! path))
		    => (lambda (cert)
			 (define result (proc path tmpfn))
			 (cond
			  ((not (eqv? #t result))
			   (delete-file tmpfn)
			   (or f-cert (file-unlock! path cert)) #f)
			  (else
			   (let ((bakf
				  (if (symbol? backup-style)
				      (emacs:backup-name path backup-style)
				      backup-style)))
			     (cond
			      ((and bakf (not (move? path bakf)))
			       (or f-cert (file-unlock! path cert)) #f)
			      ((not (move? tmpfn path))
			       (or f-cert (file-unlock! path cert)) #f)
			      (else
			       (or f-cert (file-unlock! path cert)) #t)))))))
		   (else (slib:warn 'could 'not 'lock path) #f)))))))

(define (windows:user-email-address user hostname)
  (define compname (getenv "COMPUTERNAME")) ;without domain
  (define workgroup #f)
  (call-with-tmpnam
   (lambda (tmp)
     (and (zero? (system (string-append "net config workstation >" tmp)))
	  (file-exists? tmp)
	  (not (eof-object? (call-with-input-file tmp read-char)))
	  (call-with-input-file tmp
	    (lambda (port)
	      (do ((line (read-line port) (read-line port)))
		  ((eof-object? line))
		(sscanf line " User name %s" user)
		(sscanf line " Computer name \\\\%s" compname)
		;; Don't want "DNS" from "Workstation Domain DNS Name"
		(sscanf line " Workstation domain %s" workgroup)))))))
  (string-append (or user "John_Doe") "@"
		 (if (and compname (not hostname))
		     (string-append compname "." (or workgroup "localnet"))
		     (or hostname "localhost"))))

;;@subsubheading Identification

;;@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)
  (define user (or (getenv "USER") (getenv "USERNAME")))
  (define hostname (getenv "HOSTNAME")) ;with domain
  (cond ((and user hostname) (string-append user "@" hostname))
	(else (case (software-type)
		;;((amiga)				)
		;;((macos thinkc)			)
		((ms-dos windows os/2 atarist)
		 (windows:user-email-address user hostname))
		;;((nosve)				)
		;;((vms)				)
		((unix coherent plan9)
		 (call-with-tmpnam
		  (lambda (tmp)
		    (if (not user) (set! user (system->line "whoami" tmp)))
		    (if (not hostname) (set! hostname (system->line "hostname" tmp)))
		    (if (not user) (set! user "John_Doe"))
		    (if (not hostname) (set! hostname "localhost"))))
		 (string-append user "@" hostname))))))