#!/usr/local/bin/scsh \
-o pp -e main -s

	Mirror the local directory on a remote server using scp.
	Run scp-sync --help for information.  2002-02-12

	TODO: subdirectories (scp is bad at that though)

!#

(define sync-file-name ".sync")

;; Return the md5sum of a file as a string.
(define (md5sum file-name)
  (car ((infix-splitter (rx (+ whitespace)))
	(run/string (md5sum ,file-name)))))

;; Return a list of (file-name . md5sum) from a list of file names.
(define (make-file-md5sum-list file-name-list)
  (map (lambda (f)
	 (cons f (md5sum f)))
       file-name-list))

;; Return a list of files in the current directory that don't exist in
;; file-names-list.
(define (find-new-files file-names-list)
  (filter (lambda (f)
	    (and (not (file-directory? f))
		 (not (member f file-names-list))))
	  (directory-files ".")))

;; Return a list of files that have different md5sums to what they
;; have in file-md5-list.  Prints a message to stderr for missing
;; files and drops them from the list.
(define (find-changed-files file-md5-list)
  (filter-map (lambda (f)
		(cond ((file-not-exists? (car f))
		       (format (current-output-port)
			       "~A no longer exists (skipping).\n" (car f))
		       #f)
		      ((string=? (md5sum (car f)) (cdr f))
		       #f)
		      (else
		       (car f))))
	      file-md5-list))

;; Merge two (file-name . md5sum) lists.  If a file name exists in
;; both lists, new-list prevails.
(define (merge-file-md5-lists old-list new-list)
  (fold (lambda (x lis)
	  (if (assoc (car x) new-list)
	      lis
	      (cons x lis)))
	new-list
	old-list))

;; Upload a list of files using scp.  Returns a new list of files, or
;; #f if the sync list doesn't need updating.  If check-only? is true,
;; don't actually do the uploading.
(define (upload-as-necessary upload-to file-md5-list . check-only?)
  (set! check-only? (and (pair? check-only?) (car check-only?)))
  (let ((work-files (append (find-new-files (map car file-md5-list))
			    (find-changed-files file-md5-list))))
    (cond
     ((null? work-files)
      (display "Nothing to be done.\n")
      #f)
     (else
      (display "Files to upload:\n")
      (for-each (lambda (s)
		  (format (current-output-port) "  ~A\n" s))
		work-files)
      (cond
       (check-only? #f)
       (else
	(display "Connecting...\n")
	(cond ((zero? (run (scp -p ,@work-files ,upload-to)))
	       (display "Done.\n")
	       (merge-file-md5-lists file-md5-list
				     (make-file-md5sum-list work-files)))
	      (else
	       (display "Error occurred (file list not updated).\n"
			(error-output-port))
	       #f))))))))

;; Return two values (upload-to, file-md5-list) read from disk.
(define (read-sync-file file-name)
  (close-after (open-input-file file-name)
    (lambda (port)
      (let* ((upload-to (read port))
	     (file-md5-list (read port)))
	(values upload-to file-md5-list)))))

;; Write upload-to and file-md5-list to disk.
(define (write-sync-file file-name upload-to file-md5-list)
  (close-after (open-output-file file-name)
    (lambda (port)
      (format port (string-append
		    "; automatically generated ~a\n\n"
		    "; where to upload to\n\"~a\"\n\n"
		    "; file list\n")
	      (date->string (date))
	      upload-to)
      (p file-md5-list port))))

;; Display help.
(define (display-help)
  (display "Mirror the local directory on a remote server using scp.

Usage: scp-sync [command]

where command is one of:

`-g USER@HOST:/PATH/TO/UPLOAD/TO'
	Generate a new .sync file.  This file is used to remember
	which files in this directory have already been uploaded and
	where we are uploading to.  All the files in the current
	directory will be assumed to already exist on the remote
	server (you can edit the file list if you want).

`-G USER@HOST:/PATH/TO/UPLOAD/TO'
	Same as `-g', but leave the file list blank.  The next time
	`scp-sync -u' is run the entire contents of the current
	directory will be uploaded.  Make sure the destination path
	already exists.

`-u'	Upload files.  Files in the current directory are compared to
	the list in the .sync file.  If there are any new files, they
	will be uploaded as well.  If the upload is successful, the
	.sync file is updated.

	This command does not delete removed files from the remote
	server.  You will have to do that manually using ssh, then
	update the .sync with the `-d' command.

`-c'	Check which files in this directory need uploading, but don't
	actually perform the uploading.

`-d'	Remove stale entries (i.e. files that no longer exist) from the
	.sync file

`-h'	Display this message.

If no command is specified, `-u' is assumed (i.e. upload).

"))

;; Main.
(define (main args)

  (set! args (if (null? (cdr args))
		 (list "-u")  ; default command
		 (cdr args))) ; drop argv[0]

  (cond

   ;; Display help.
   ((or (member "-h" args)
	(member "--help" args))
    (display-help))

   ;; Generate a new [blank] sync file.
   ((or (member "-g" args)
	(member "-G" args))
    => (lambda (dash-g)
	 (cond
	  ((null? (cdr dash-g))
	   (display "-g and -G commands require an argument.\n"
		    (error-output-port)))
	  (else
	   (format (current-output-port)
		   "Making a ~a file.\n" sync-file-name)
	   (write-sync-file sync-file-name
			    (cadr dash-g)
			    (if (string=? "-g" (car dash-g))
				(make-file-md5sum-list
				 (filter file-regular? (directory-files ".")))
				'()))))))

   ;; Commands that require a sync list:
   (else
    (receive (upload-to file-md5-list)    
	     (with-errno-handler
	      ((errno packet)
	       ((errno/noent)
		(format (error-output-port)
			"No ~a found, generate one with -g.\n" sync-file-name)
		(exit 1)))
	      (read-sync-file sync-file-name))
      (cond

       ;; Upload.
       ((member "-u" args)
	(let ((new-list (upload-as-necessary upload-to file-md5-list)))
	  (if new-list
	      (write-sync-file sync-file-name upload-to new-list))))

       ;; Check only.
       ((member "-c" args)
	(upload-as-necessary upload-to file-md5-list #t))

       ;; Delete stale entries.
       ((member "-d" args)
	(write-sync-file sync-file-name upload-to
			 (filter (lambda (f) (and (file-exists? (car f))
						  (file-regular? (car f))))
				 file-md5-list)))

       (else
	(display "Huh??\n" (error-output-port))))))))

;; Local Variables:
;; mode: scheme
;; End: