#! /bin/sh
exec rep "$0" -f sfs-main "$@"
!#

;; sfs -- Directory synchronisation program
;; Copyright 1999 John Harper <john@dcs.warwick.ac.uk>
;; $Id: sfs.jl,v 1.3 1999/07/09 15:13:06 john Exp john $

;;; sfs is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2, or (at your option)
;;; any later version.

;;; sfs 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 General Public License for more details.

;;; You should have received a copy of the GNU General Public License
;;; along with sfs; see the file COPYING.  If not, write to
;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.


;; Commentary:

;; The idea is for a utility that is a kind of combination between CVS
;; and coda -- retrieve/update a set of files from a server, edit them,
;; then synchronise with the server.

;; Rationale: although coda supports disconnected operation it requires
;; a lot of changes on the server side (multiple dedicated partitions,
;; non-standard file storage).

;; My requirement is a ``mostly-disconnected'' model of operation with
;; periodic synchronisation, much like a PalmPilot really.

;; Some notes/requirements:

;; * No special filesystems, server programs, or any type of
;;   configuration on the server side

;; * Only require a single operation: `sync'

;;   For each directory created, add a meta-data directory .sfs
;;   containing at least the following:

;;	Files		A list of the files/directories created,
;;			for each file also store original mtime,
;;			size, [crc?].
;;	Location	Location on the server (hostname/directory)

;;   And if required:

;;	Conflicts	List of conflicting entries

;;   sync algorithm:

;;	1. delete files from server which no longer exist on
;;	   client (and haven't been modified since last sync)

;;	2. add files to server which have been created on the client
;;	   since the last sync (and still don't exist on the server)

;;	3. update files on server which have been modified on the
;;	   client since the last sync (and haven't been updated/deleted
;;	   on the server in the meantime)

;;	4. delete files from the client which have been deleted on the
;;	   server (but not modified on the client)

;;	5. add files on the client that have been created on the server
;;	   (but not added on client)

;;	6. update files on client that have been updated on the server
;;	   (but not updated/deleted on the server)

;;   Then recreate the `Files' and `Conflicts' lists.

;;   All parenthesised cases require user intervention to resolve the
;;   conflict.

;;   These are the possible conflict types (CLIENT-SERVER)

;;	modify-delete
;;	delete-modify
;;	modify-modify
;;	insert-insert

;;   The first two can be handled by prompting the user at sync time.
;;   But a non-interactive method would be useful as well. The second
;;   two are both the same really. It will require user intervention to
;;   merge the changes, then update the server.

;;   Possibly copy the coda method and leave a conflicting entry as
;;   a dangling symbolic link. And leave both files in a subdirectory?

;;   Or perhaps use the CVS model: leave the client file where it is
;;   (possibly after merging server changes?) and put a copy of the
;;   server file somewhere. But then how do we handle deletions?

;;   The current method of resolving conflicts is via the
;;   --client-authoritative and --server-authoritative options. Any
;;   conflicts are assumed to have been resolved such that one of the
;;   two directories is in the correct state.

;;   But this introduces a huge race condition: the server may change
;;   between syncing and forcing.

;; * `discard' operation?: needed? why not sync then `rm -rf'?
;;
;;   Warn about conflicts?


;; Implementation notes:

;; In order to handle symlinks properly one would normally use
;; lstat(2). But librep only provides lstat functionality in one place:
;; the file-symlink-p predicate. What this means is that symlinks are
;; usually considered specially, and as the _first_ item in a list of
;; cases.

;; Lock files are created on the server named `.sfs-lock' in each
;; directory currently being accessed. However librep gives no method
;; of guaranteeing atomicity of creation, so there are race conditions.
;; Some effort is made to avoid them, but in general other non-sfs
;; programs could be accessing the directory as well..


;; Customisation:

;; On startup the Lisp file `~/.sfsrc' is read as well as the standard
;; librep scripts. Any directories on the client or server that are
;; being synchronised may contain `.sfsignore' files. These should
;; contain a list of regular expressions matching file names to ignore
;; in that directory, one per line.


;; Todo:

;; * it works quite well for _whole_ directory hierarchies, but I
;;   want more control over what gets synchronised. Kind of like
;;   coda's hoard profiles..

;; * synchronise attributes separately -- currently if attributes change
;;   the whole file is copied

;; * check out symlink lossage (I think I've fixed it now..?)

;; * better conflict handling

;;	+ for example, compare files before assuming they've
;;	  both been modified

;;	+ what happens if the type of a file changes, i.e. delete
;;	  a file and create a directory of the same name..?


;; Variable/configuration

;; current client and server hosts (these are used very rarely)
(defvar sfs-client (system-name))
(defvar sfs-server "localhost")

;; current client and server directories
(defvar sfs-client-directory nil)
(defvar sfs-server-directory nil)

;; list of regexps matching files to ignore
(defvar sfs-default-ignore-regexps
  '("^\\.\\.?$" "~$" "^\\.sfs(-lock)?$" "^\\.#" "^#"))
(defvar sfs-ignore-regexps nil)

;; re-enable items that would otherwise be matched by sfs-ignore-regexps
(defvar sfs-default-noignore-regexps nil)
(defvar sfs-noignore-regexps nil)

;; use lock files?
(defvar sfs-lock-server nil)

;; seconds to wait between checking lock files
(defvar sfs-lock-wait-period 30)

;; list of [NAME TYPE MODE SIZE MTIME] for the current client directory
;; or [NAME TYPE MODE SIZE LINK-CONTENTS] for a symlink
(defvar sfs-entries nil)

;; list of (NAME . CONFLICT-TYPE)
(defvar sfs-conflicts nil)

;; list of options -- possible values no-descend, no-insert, no-insert-client,
;; no-insert-server, no-delete, no-delete-client, no-delete-server
(defvar sfs-options nil)

(defvar sfs-client-authorative nil)
(defvar sfs-server-authorative nil)
(defvar sfs-newest-authorative nil)

;; never synchronise in sub-directories when this is non-nil
(defvar sfs-no-descend nil)

;; when non-nil, try to compare conflicting files (i.e. is there
;; _really_ a conflict?)
(defvar sfs-compare-conflicts t)

;; when t check that the Location of a directory's server is the same as
;; that specified [on the command line]
(defvar sfs-match-server t)

;; nullify sfs-message when this is non-nil
(defvar sfs-quiet nil)


;; Lock files

;; List of (DIR . LOCK-COUNT)
(defvar sfs-server-locks nil)

(defun sfs-lock-directory (dir)
  (when sfs-lock-server
    (setq dir (directory-file-name dir))
    (let
	((tem (assoc dir sfs-server-locks)))
      (if tem
	  ;; we already have a lock on this directory
	  (rplacd tem (1+ (cdr tem)))
	(let
	    ((lock-file (expand-file-name ".sfs-lock" dir)))
	  (catch 'locked
	    (while t
	      ;; there's still a race condition here:
	      ;;
	      ;; host-1: file doesn't exist
	      ;; host-2: file doesn't exist
	      ;; host-2: write signature
	      ;; host-2: check signature
	      ;; host-1: write signature
	      ;; host-1: check signature
	      ;;
	      ;; both hosts think they have the lock..
	      ;; but this is only a prototype..
	      (while (file-exists-p lock-file)
		(sfs-message "waiting on lock `%s'\n" lock-file)
		(sleep-for sfs-lock-wait-period))
	      (let
		  ((file (open-file lock-file 'write))
		   ;; include pid?
		   (signature (format nil "%s\n" sfs-client)))
		(when file
		  (unwind-protect
		      (write file signature)
		    (close-file file)))
		(setq file (open-file lock-file 'read))
		(when file
		  (unwind-protect
		      (let
			  ((line (read-line file)))
			(when (string= line signature)
			  (throw 'locked t)))
		    (close-file file))))))
	  (setq sfs-server-locks (cons (cons dir 1) sfs-server-locks)))))))

(defun sfs-unlock-directory (dir)
  (when sfs-lock-server
    (setq dir (directory-file-name dir))
    (let
	((tem (assoc dir sfs-server-locks)))
      (when tem
	(rplacd tem (1- (cdr tem)))
	(when (zerop (cdr tem))
	  (sfs-delete-file (expand-file-name ".sfs-lock" (car tem)))
	  (setq sfs-server-locks (delq tem sfs-server-locks)))))))


;; Client meta-data

(defun sfs-read-meta-data ()
  (let
      ((meta-dir (concat sfs-client-directory ".sfs/")))
    (when (file-directory-p meta-dir)
      (let
	  ((entries-file (concat meta-dir "Entries"))
	   (location-file (concat meta-dir "Location"))
	   (conflicts-file (concat meta-dir "Conflicts"))
	   (options-file (concat meta-dir "Options"))
	   file)
	(when (and (file-regular-p entries-file)
		   (setq file (open-file entries-file 'read)))
	  (unwind-protect
	      (condition-case nil
		  (while t
		    (setq sfs-entries (cons (read file) sfs-entries)))
		(end-of-stream
		 (setq sfs-entries (nreverse sfs-entries))))
	    (close-file file)))
	(when (and (file-regular-p location-file)
		   (setq file (open-file location-file 'read)))
	  (unwind-protect
	      (progn
		(setq sfs-server-directory (read-line file))
		(when (string-match "\n$" sfs-server-directory)
		  (setq sfs-server-directory
			(substring sfs-server-directory 0 (match-start))))
		(when (string-match "^/([^:]+):" sfs-server-directory)
		  (setq sfs-server (expand-last-match "\\1"))))
	    (close-file file)))
	(when (and (file-regular-p conflicts-file)
		   (setq file (open-file conflicts-file 'read)))
	  (unwind-protect
	      (condition-case nil
		  (while t
		    (setq sfs-conflicts (cons (read file) sfs-conflicts)))
		(end-of-stream
		 (setq sfs-conflicts (nreverse sfs-conflicts))))
	    (close-file file)))
	(when (and (file-regular-p options-file)
		   (setq file (open-file options-file 'read)))
	  (unwind-protect
	      (progn
		(setq sfs-options (read file))
		(when (sfs-option-p 'no-descend)
		  (setq sfs-no-descend t)))
	    (close-file file)))))))

(defun sfs-write-meta-data ()
  (let
      ((meta-dir (concat sfs-client-directory ".sfs/")))
    (sfs-make-directory sfs-client-directory)
    (sfs-make-directory meta-dir)
    (let
	((entries-file (concat meta-dir "Entries"))
	 (location-file (concat meta-dir "Location"))
	 (conflicts-file (concat meta-dir "Conflicts"))
	 (options-file (concat meta-dir "Options"))
	 file)
      (when (setq file (open-file entries-file 'write))
	(unwind-protect
	    (sfs-output-list sfs-entries file)
	  (close-file file)))
      (when (setq file (open-file location-file 'write))
	(unwind-protect
	    (format file "%s\n" sfs-server-directory)
	  (close-file file)))
      (if sfs-conflicts
	  (when (setq file (open-file conflicts-file 'write))
	    (unwind-protect
		(sfs-output-list sfs-conflicts file)
	      (close-file file)))
	(sfs-delete-file conflicts-file))
      (if sfs-options
	  (when (setq file (open-file options-file 'write))
	    (unwind-protect
		(format file "%S\n" sfs-options)
	      (close-file file)))
	(sfs-delete-file options-file)))))

(defun sfs-read-ignore-list ()
  (let
      (file line)
    (cond ((file-exists-p (concat sfs-client-directory ".sfsignore"))
	   (setq file (concat sfs-client-directory ".sfsignore")))
	  ((file-exists-p (concat sfs-server-directory ".sfsignore"))
	   (setq file (concat sfs-server-directory ".sfsignore"))))
    (when (and file (file-regular-p file)
	       (setq file (open-file file 'read)))
      (unwind-protect
	  (condition-case nil
	      (while (setq line (read-line file))
		(when (string-match "\n$" line)
		  (setq line (substring line 0 (match-start))))
		(if (= (aref line 0) ?!)
		    ;; noignore field
		    (setq sfs-noignore-regexps (cons (substring line 1)
						     sfs-noignore-regexps))
		  (setq sfs-ignore-regexps (cons line sfs-ignore-regexps))))
	    (end-of-stream))
	(close-file file)))))

(defun sfs-insert-entry (entry)
  (setq sfs-entries (cons entry sfs-entries)))

(defun sfs-delete-entry (entry)
  (setq sfs-entries (delq entry sfs-entries)))

(defun sfs-fill-entry (entry file-1 file-2)
  (aset entry 0 (file-name-nondirectory file-1))
  (aset entry 1 (cond ((file-symlink-p file-1) 'symlink)
		      ((file-regular-p file-1) 'file)
		      ((file-directory-p file-1) 'directory)))
  (aset entry 2 (file-modes file-1))
  (aset entry 3 (file-size file-1))
  (aset entry 4 (cond ((file-symlink-p file-1)
		       ;; store link contents not mtime
		       (read-symlink file-1))
		      ((file-directory-p file-1)
		       ;; don't compare mtimes of directories
		       nil)
		      (t
		       ;; librep doesn't allow mtimes to be set explicitly;
		       ;; this stops files being updated when they haven't
		       ;; actually changed, just copied from elsewhere
		       (max (file-modtime file-1) (file-modtime file-2)))))
  (sfs-clear-conflict entry file-1 file-2))

;; return t if FILE has been updated since ENTRY was created. for files
;; this may just mean that the permissions have been updated
(defun sfs-updated (entry file)
  (cond ((and (eq (aref entry 1) 'symlink) (file-symlink-p file))
	 (not (string= (aref entry 4) (read-symlink file))))
	((eq (aref entry 1) 'directory)
	 (not (and (not (file-symlink-p file)) (file-directory-p file))))
	(t
	 (or (> (file-modtime file) (aref entry 4))
	     (/= (file-modes file) (aref entry 2))))))

(defmacro sfs-option-p (option)
  `(memq ,option sfs-options))


;; Utilities

(defun sfs-make-directory (dir)
  (cond ((file-directory-p dir))
	((not (or (file-symlink-p dir) (file-exists-p dir)))
	 (make-directory dir))
	(t
	 (error "Not a directory: %s" dir))))

(defun sfs-copy-file (source dest)
  (when (or (file-symlink-p dest) (file-exists-p dest))
    (sfs-delete-file dest))
  (cond ((file-symlink-p source)
	 (make-symlink dest (read-symlink source)))
	((file-regular-p source)
	 (copy-file source dest))
	((file-directory-p source)
	 (error "Trying to copy directories: %s, %s" source dest))))

(defun sfs-delete-file (file)
  (cond ((file-symlink-p file)
	 (delete-file file))
	((file-directory-p file)
	 (mapc #'(lambda (f)
		   (unless (or (string= "." f) (string= ".." f))
		     (sfs-delete-file
		      (concat (file-name-as-directory file) f))))
	       (directory-files file))
	 (delete-directory file))
	((file-exists-p file)
	 (delete-file file))))

(defun sfs-output-list (list file)
  (mapc #'(lambda (x)
	    (format file "%S\n" x)) list))

(defun sfs-match-ignore (file)
  (catch 'return
    (mapc #'(lambda (r)
	      (when (string-match r file)
		(throw 'return nil))) sfs-noignore-regexps)
    (mapc #'(lambda (r)
	      (when (string-match r file)
		(throw 'return t))) sfs-ignore-regexps)
    nil))

(defun sfs-message (format &rest args)
  (unless sfs-quiet
    (apply 'format standard-error format args)))

(defun sfs-log (format &rest args)
  (apply 'format standard-output format args))

(defun sfs-union (x y)
  (mapc #'(lambda (a)
	    (unless (memq a x)
	      (setq x (nconc x (list a))))) y)
  x)


;; Synchronisation, the heart of the code

;; returns t if no conflicts were found
(defun sfs-sync (client-dir &optional server-dir restrictions options)
  (let
      ((sfs-client-directory (file-name-as-directory client-dir))
       (sfs-server-directory nil)
       (sfs-ignore-regexps sfs-default-ignore-regexps)
       (sfs-noignore-regexps sfs-default-noignore-regexps)
       (sfs-entries nil)
       (sfs-conflicts nil)
       (sfs-no-descend sfs-no-descend)
       (sfs-options options)
       (lower-conflicts nil)
       client-files server-files entries saved-entries)
    (sfs-message "synchronising %s\n" sfs-client-directory)
    (sfs-read-meta-data)
    (when server-dir
      (setq server-dir (file-name-as-directory server-dir)))
    (cond ((and server-dir sfs-server-directory sfs-match-server)
	   (or (string= server-dir sfs-server-directory)
	       (error "Server directories don't match: %s, %s"
		      server-dir sfs-server-directory)))
	  (server-dir
	   (setq sfs-server-directory server-dir))
	  ((not sfs-server-directory)
	   (error "No server directory for client: %s" sfs-client-directory)))
    (setq sfs-server-directory (file-name-as-directory sfs-server-directory))
    (sfs-lock-directory sfs-server-directory)
    (unwind-protect
	(progn
	  (sfs-read-ignore-list)
	  (sfs-make-directory client-dir)
	  (setq client-files (sort (directory-files sfs-client-directory)))
	  (setq server-files (sort (directory-files sfs-server-directory)))

	  (setq client-files (delete-if 'sfs-match-ignore client-files))
	  (setq server-files (delete-if 'sfs-match-ignore server-files))

	  (when restrictions
	    (setq saved-entries
		  ;; we'll add these entries back later
		  (filter #'(lambda (e)
			      (not (member (aref e 0) restrictions)))
			  sfs-entries))
	    (setq sfs-entries
		  (delete-if-not #'(lambda (e)
				     (member (aref e 0) restrictions))
				 sfs-entries))
	    (setq client-files (delete-if-not #'(lambda (f)
						  (member f restrictions))
					      client-files))
	    (setq server-files (delete-if-not #'(lambda (f)
						  (member f restrictions))
					      server-files)))

	  (setq entries sfs-entries)
	  (while entries
	    (cond ((and (equal (aref (car entries) 0) (car client-files))
			(equal (aref (car entries) 0) (car server-files)))
		   ;; update files existing on both client and server
		   (let
		       ((tem (car entries)))
		     (setq server-files (cdr server-files))
		     (setq client-files (cdr client-files))
		     (setq entries (cdr entries))
		     (unless (sfs-check-updated tem)
		       (setq lower-conflicts t))))

		  ((and (equal (aref (car entries) 0) (car server-files))
			(or (not client-files)
			    (> (car client-files) (aref (car entries) 0))))
		   ;; delete files from server which no longer exist on
		   ;; client
		   (let
		       ((tem (car entries)))
		     (setq entries (cdr entries))
		     (setq server-files (cdr server-files))
		     (when (or restrictions
			       (not (or (sfs-option-p 'no-delete)
					(sfs-option-p 'no-delete-server))))
		       (unless (sfs-client-deletion tem)
			 (setq lower-conflicts t)))))

		  ((and (equal (aref (car entries) 0) (car client-files))
			(or (not server-files)
			    (> (car server-files) (aref (car entries) 0))))
		   ;; delete files from the client which have been deleted
		   ;; on the server
		   (let
		       ((tem (car entries)))
		     (setq entries (cdr entries))
		     (setq client-files (cdr client-files))
		     (when (or restrictions
			       (not (or (sfs-option-p 'no-delete)
					(sfs-option-p 'no-delete-client))))
		       (unless (sfs-server-deletion tem)
			 (setq lower-conflicts t)))))

		  ((and client-files server-files
			(equal (car client-files) (car server-files))
			(not (equal (aref (car entries) 0)
				    (car client-files))))
		   ;; file has been created on both client and server
		   (when (or restrictions
			     (not (or (sfs-option-p 'no-insert)
				      (sfs-option-p 'no-insert-client)
				      (sfs-option-p 'no-insert-server))))
		     (sfs-conflicting-insertion (car server-files))
		     (setq lower-conflicts t))
		   (setq server-files (cdr server-files))
		   (setq client-files (cdr client-files)))

		  ((and client-files
			(or (not server-files)
			    (> (car server-files) (car client-files)))
			(< (car client-files) (aref (car entries) 0)))
		   ;; add files to server which have been created on the
		   ;; client since the last sync
		   (when (or restrictions
			     (not (or (sfs-option-p 'no-insert)
				      (sfs-option-p 'no-insert-server))))
		     (unless (sfs-client-insertion (car client-files))
		       (setq lower-conflicts t)))
		   (setq client-files (cdr client-files)))

		  ((and server-files
			(or (not client-files)
			    (> (car client-files) (car server-files)))
			(< (car server-files) (aref (car entries) 0)))
		   ;; add files on the client that have been created on
		   ;; the server
		   (when (or restrictions
			     (not (or (sfs-option-p 'no-insert)
				      (sfs-option-p 'no-insert-client))))
		     (unless (sfs-server-insertion (car server-files))
		       (setq lower-conflicts t)))
		   (setq server-files (cdr server-files)))

		  ((and (or (not server-files)
			    (> (car server-files) (aref (car entries) 0)))
			(or (not client-files)
			    (> (car client-files) (aref (car entries) 0))))
		   ;; both client and server files have been deleted
		   (let
		       ((tem (car entries)))
		     (sfs-message
		      "warning: `%s' has disappeared\n" (aref tem 0))
		     (setq entries (cdr entries))
		     (sfs-delete-entry tem)))))

	  (if (or restrictions (not (sfs-option-p 'no-insert)))
	      (progn
		(while (and client-files server-files)
		  (cond ((equal (car client-files) (car server-files))
			 (unless (sfs-conflicting-insertion (car client-files))
			   (setq lower-conflicts t))
			 (setq client-files (cdr client-files))
			 (setq server-files (cdr server-files)))
			((< (car client-files) (car server-files))
			 (unless (sfs-client-insertion (car client-files))
			   (setq lower-conflicts t))
			 (setq client-files (cdr client-files)))
			((< (car server-files) (car client-files))
			 (unless (sfs-server-insertion (car server-files))
			   (setq lower-conflicts t))
			 (setq server-files (cdr server-files)))))

		(while server-files
		  (unless (sfs-server-insertion (car server-files))
		    (setq lower-conflicts t))
		  (setq server-files (cdr server-files)))

		(while client-files
		  (unless (sfs-client-insertion (car client-files))
		    (setq lower-conflicts t))
		  (setq client-files (cdr client-files))))

	    (setq server-files nil)
	    (setq client-files nil))

	  (setq sfs-entries (sort (nconc sfs-entries saved-entries)
				  #'(lambda (x y) (< (aref x 0) (aref y 0))))))
      (sfs-unlock-directory sfs-server-directory))
    (sfs-write-meta-data)
    (and (not lower-conflicts) (null sfs-conflicts))))


;; sync primitives, all return t if no conflict occurred

(defun sfs-check-updated (entry)
  (let
      ((server-file (concat sfs-server-directory (aref entry 0)))
       (client-file (concat sfs-client-directory (aref entry 0)))
       (no-conflict t))
    (cond ((and (file-symlink-p server-file) (file-symlink-p client-file))
	   (unless (sfs-update-symlink entry server-file client-file)
	     (setq no-conflict nil)))
	  ((and (file-directory-p server-file) (file-directory-p client-file))
	   (unless sfs-no-descend
	     (unless (sfs-sync client-file server-file)
	       (setq no-conflict nil))))
	  ((and (sfs-updated entry server-file)
		(sfs-updated entry client-file))
	   ;; both sides have changed since last sync!
	   (cond ((or sfs-client-authorative
		      (and sfs-newest-authorative
			   (> (file-modtime client-file)
			      (file-modtime server-file))))
		  (sfs-log "UC %s\n" server-file)
		  (sfs-copy-file client-file server-file)
		  (sfs-fill-entry entry client-file server-file))
		 ((or sfs-server-authorative
		      (and sfs-newest-authorative
			   (> (file-modtime server-file)
			      (file-modtime client-file))))
		  (sfs-log "UC %s\n" client-file)
		  (sfs-copy-file server-file client-file)
		  (sfs-fill-entry entry client-file server-file))
		 (t
		  (setq no-conflict
			(sfs-mark-conflict 'modify-modify entry
					   client-file server-file)))))
	  ((sfs-updated entry server-file)
	   ;; server has changed
	   (sfs-log "U  %s\n" client-file)
	   (sfs-copy-file server-file client-file)
	   (sfs-fill-entry entry client-file server-file))
	  ((sfs-updated entry client-file)
	   ;; client has changed
	   (sfs-log "U  %s\n" server-file)
	   (sfs-copy-file client-file server-file)
	   (sfs-fill-entry entry client-file server-file)))
    no-conflict))

;; symlinks are special
(defun sfs-update-symlink (entry server-file client-file)
  ;; can't get true mtime of symlink, we'll get the mtime
  ;; of the file that's pointed to
  (let
      ((client-link (read-symlink client-file))
       (server-link (read-symlink server-file))
       (old-link (aref entry 4))
       (no-conflict t))
    (cond ((and (string= client-link old-link)
		(string= server-link old-link)))	;no change
	  ((string= client-link server-link))		;both changed
	  ((string= client-link old-link)
	   ;; only server link has been modified
	   (sfs-log "U  %s\n" client-file)
	   (sfs-copy-file server-file client-file))
	  ((string= server-link old-link)
	   ;; only client has changed
	   (sfs-log "U  %s\n" server-file)
	   (sfs-copy-file client-file server-file))
	  (t
	   ;; both links have changed
	   (cond (sfs-client-authorative
		  (sfs-log "UC %s\n" server-file)
		  (sfs-copy-file client-file server-file))
		 (sfs-server-authorative
		  (sfs-log "UC %s\n" client-file)
		  (sfs-copy-file server-file client-file))
		 (t
		  (setq no-conflict
			(sfs-mark-conflict 'modify-modify entry
					   client-file server-file))))))
    (sfs-fill-entry entry client-file server-file)
    no-conflict))

(defun sfs-client-deletion (entry)
  (let
      ((server-file (concat sfs-server-directory (aref entry 0)))
       (client-file (concat sfs-client-directory (aref entry 0)))
       (no-conflict t))
    (cond ((sfs-updated entry server-file)
	   ;; file has been updated on server
	   (cond (sfs-client-authorative
		  (sfs-log "DC %s\n" server-file)
		  (sfs-delete-file server-file)
		  (sfs-delete-entry entry))
		 (sfs-server-authorative
		  (sfs-log "AC %s\n" client-file)
		  (sfs-copy-file server-file client-file)
		  (sfs-fill-entry entry client-file server-file))
		 (t
		  (setq no-conflict
			(sfs-mark-conflict 'delete-modify entry
					   client-file server-file)))))
	  (t
	   (sfs-log "D  %s\n" server-file)
	   (sfs-delete-file server-file)
	   (sfs-delete-entry entry)))
    no-conflict))

(defun sfs-client-insertion (file)
  (let
      ((entry (make-vector 5))
       (server-file (concat sfs-server-directory file))
       (client-file (concat sfs-client-directory file)))
    (sfs-log "A  %s\n" server-file)
    (if (and (not (file-symlink-p client-file)) (file-directory-p client-file))
	(progn
	  (sfs-make-directory server-file)
	  (sfs-sync client-file server-file))
      (sfs-copy-file client-file server-file))
    (sfs-fill-entry entry client-file server-file)
    (sfs-insert-entry entry)
    t))

(defun sfs-server-deletion (entry)
  (let
      ((server-file (concat sfs-server-directory (aref entry 0)))
       (client-file (concat sfs-client-directory (aref entry 0)))
       (no-conflict t))
    (cond ((sfs-updated entry client-file)
	   ;; file has been updated on client
	   (cond (sfs-client-authorative
		  (sfs-log "AC %s\n" server-file)
		  (sfs-copy-file client-file server-file)
		  (sfs-fill-entry entry client-file server-file))
		 (sfs-server-authorative
		  (sfs-log "DC %s\n" client-file)
		  (sfs-delete-file client-file)
		  (sfs-delete-entry entry))
		 (t
		  (setq no-conflict
			(sfs-mark-conflict 'modify-delete entry
					   client-file server-file)))))
	  (t
	   (sfs-log "D  %s\n" client-file)
	   (sfs-delete-file client-file)
	   (sfs-delete-entry entry)))
    no-conflict))

(defun sfs-server-insertion (file)
  (let
      ((entry (make-vector 5))
       (server-file (concat sfs-server-directory file))
       (client-file (concat sfs-client-directory file)))
    (sfs-log "A  %s\n" client-file)
    (if (and (not (file-symlink-p server-file)) (file-directory-p server-file))
	(sfs-sync client-file server-file)
      (sfs-copy-file server-file client-file))
    (sfs-fill-entry entry client-file server-file)
    (sfs-insert-entry entry)
    t))

(defun sfs-conflicting-insertion (file)
  (let
      ((server-file (concat sfs-server-directory file))
       (client-file (concat sfs-client-directory file)))
    (cond ((or sfs-client-authorative
	       (and sfs-newest-authorative
		    (> (file-modtime client-file) (file-modtime server-file))))
	   (sfs-client-insertion file))
	  ((or sfs-server-authorative
	       (and sfs-newest-authorative
		    (> (file-modtime server-file) (file-modtime client-file))))
	   (sfs-server-insertion file))
	  (t
	   (let
	       ((entry (make-vector 5)))
	     (sfs-fill-entry entry client-file server-file)
	     (sfs-mark-conflict 'insert-insert entry
				client-file server-file))))))


;; Conflict resolution

(defsubst sfs-conflict-file (client-file server-file)
  (concat (file-name-directory client-file)
	  (concat ".#" (file-name-nondirectory client-file) ?: sfs-server)))

;; returns nil if a conflict, t if no conflict
(defun sfs-mark-conflict (type entry client-file server-file)
  (setq sfs-conflicts (delete-if #'(lambda (cell)
				     (string= (car cell) (aref entry 0)))
				 sfs-conflicts))
  (catch 'return
    (when (memq type '(delete-modify modify-modify insert-insert))
      (let
	  ((conflict-file (sfs-conflict-file client-file server-file)))
	;; copy server file to CLIENT-DIR/.#NAME:SERVER
	(sfs-copy-file server-file conflict-file)
	(unless (or (eq type 'delete-modify) (not sfs-compare-conflicts))
	  (when (and (= (file-modes client-file) (file-modes conflict-file))
		     (zerop (system (format nil "cmp %s %s >/dev/null 2>&1 </dev/null"
					    client-file conflict-file))))
	    ;; files are actually the same, so no conflict
	    (sfs-fill-entry entry client-file server-file)
	    (throw 'return t)))))
    (setq sfs-conflicts (cons (cons (aref entry 0) type) sfs-conflicts))
    (sfs-log "C  %s [%s]\n" client-file type)
    nil))

(defun sfs-clear-conflict (entry client-file server-file)
  (let
      ((tem (assoc (aref entry 0) sfs-conflicts))
       (server-file (sfs-conflict-file client-file server-file)))
    (when tem
      (setq sfs-conflicts (delq tem sfs-conflicts)))
    (sfs-delete-file server-file)))


;; Profiles

(defun sfs-exec-profile (profile &optional server)
  (let
      ((file (open-file profile 'read))
       spec)
    (when file
      (unwind-protect
	  (condition-case nil
	      (while t
		(let
		    ((spec (read file)))
		  (cond ((stringp spec)
			 (sfs-sync spec (and server (concat server spec))))
			((listp spec)
			 (sfs-sync (or (nth 1 spec) (car spec))
				   (and server (concat server (car spec)))
				   (nth 2 spec) (nth 3 spec))))))
	    (end-of-stream))
	(close-file file)))))


;; Entry points

(defun sfs-main ()
  (let
      ((sync-pwd t)
       server profile)
    (load "~/.sfsrc" t t)
    (when (or (get-command-line-option "--sfs-help")
	      (get-command-line-option "-h"))
      (write standard-error "\
Usage: sfs [OPTION]... [DIRECTORIES or FILES...]

Synchronise the DIRECTORIES (the current directory by default) with their
remote servers.

  -d, --server=DIR		Specify the server directory; format
				 is `[/[USER@]HOST:]DIRECTORY'
  -p, --profile=PROFILE		Synchronise files based on the contents
				 of the file PROFILE

  -c, --client-authoritative	If conflicts are found, always update
				 the server to match the client
  -s, --server-authoritative	Do the opposite
  -r, --recent-authoritative	For insert-insert or modify-modify
				 conflicts, treat the most recently
				 modified of the two files as being
				 authoritative

  -l, --no-descend		Don't recurse into subdirectories of
				 any directories being synchronised
  -L, --lock-server		Create lock files on server (not perfect)
  -f, --force-server		Don't check that the server directories
				 being synchronised with are the same
				 as the directories first retrieved
  -q, --quiet			Don't print informational messages
  -h, --sfs-help		Show this message\n")
      (throw 'exit 0))
    (when (setq server (or (get-command-line-option "--server" t)
			   (get-command-line-option "-d" t)))
      (if (string-match "^/([^:]+):" server)
	  (setq sfs-server (expand-last-match "\\1"))
	(setq sfs-server "localhost"))
      (setq server (expand-file-name server)))
    (when (or (get-command-line-option "--client-authoritative")
	      (get-command-line-option "-c"))
      (setq sfs-client-authorative t))
    (when (or (get-command-line-option "--server-authoritative")
	      (get-command-line-option "-s"))
      (setq sfs-server-authorative t))
    (when (or (get-command-line-option "--recent-authoritative")
	      (get-command-line-option "-r"))
      (setq sfs-server-authorative t))
    (when (or (get-command-line-option "--no-descend")
	      (get-command-line-option "-l"))
      (setq sfs-no-descend t))
    (when (or (get-command-line-option "--lock-server")
	      (get-command-line-option "-L"))
      (setq sfs-lock-server t))
    (when (or (get-command-line-option "--force-server")
	      (get-command-line-option "-f"))
      (setq sfs-match-server nil))
    (when (or (get-command-line-option "--quiet")
	      (get-command-line-option "-q"))
      (setq sfs-quiet t))
    (while (setq profile (or (get-command-line-option "--profile" t)
			     (get-command-line-option "-p" t)))
      (sfs-exec-profile profile server)
      (setq sync-pwd nil))
    (if command-line-args
	(while command-line-args
	  (let
	      ((arg (car command-line-args)))
	    (if (and (or (file-symlink-p arg) (file-exists-p arg))
		     (not (file-directory-p arg)))
		(sfs-sync (file-name-directory arg)
			  server (list (file-name-nondirectory arg)))
	      (sfs-sync arg server)))
	  (setq command-line-args (cdr command-line-args)))
      (when sync-pwd
	(sfs-sync ".")))))


;; Local variables:
;; major-mode: lisp-mode
;; End: