Megatest

;;  Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest 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 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest 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 Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

(module fslutil
   *
	
(import
 scheme
 chicken.base
 chicken.condition
 chicken.string
 chicken.time.posix
 chicken.pretty-print
 chicken.process-context
 chicken.process-context.posix
 chicken.file
 chicken.io
 chicken.port
 chicken.process
 scheme
 ;;extras
 regex
 regex-case
 matchable
 srfi-1
 srfi-69
 json
 fmt
 )

(define (portprint p . args)
  (with-output-to-port p
    (lambda ()
      (apply print args))))

;; abstract out the alist-ref a bit and re-order the params
;;
(define-inline (aref dat key)
  (alist-ref key dat equal?))

;; convert silly vectors in json data to nice clean alist
;;
(define (to-alist inlst)
  (handle-exceptions
      exn
      (begin
	(print-call-chain)
	(print inlst))
    (cond
     ((proper-list? inlst) (map to-alist inlst))
     ((or (list? inlst) ;; it is a pair
	  (pair? inlst))   (cons (car inlst) (to-alist (cdr inlst))))
     ((vector? inlst)      (to-alist (vector->list inlst)))
     (else                 inlst))))

;; columnar line printer
;;
(define (print-rows inlist)
  (define (print-line x)
    (cat (car x)
	 (space-to 10)(pad/left 3 (cadr x))
	 (space-to 25)(pad/left 3 (caddr x))
	 ))
  (fmt #t (pad-char #\  (fmt-join/suffix print-line inlist nl))))

;; from the command line pull branch, start-tag, end-tag
;;
(define (extract-history branch start-tag end-tag)
  (let* ((data      (to-alist  ;; get all the data
		      (with-input-from-pipe
			  "fossil json timeline checkin -n 0"
			  json-read)))
	 (timeline   (map (lambda (e)
			   (map pair-car->symbol e))
			  (aref (aref data "payload") "timeline"))) ;; extract the timeline alists
	 (start-flag #f)
	 (end-flag   #f))
    ;; now we have all needed data as a list of alists in time order, extract the
    ;; messages for given branch starting at start-tag and ending at end-tag
    (reverse ;; return results oldest to newest
     (filter
      (lambda (x) x)
      (map
       (lambda (entry)
	 (let ((tags (aref entry 'tags)))
	   (if (or (not tags) ;; eh?
		   (not (list? tags)))
	       (begin
		 ;; (with-output-to-port (current-error-port)
		 ;;   (lambda ()
		 ;;     (print "ERROR: bad entry. tags: " tags)))
		 #f)
	       (let* ((btag (car tags))  ;; first tag is the primary branch
		      (tags (cdr tags))  ;; remainder are actual tags
		      (cmt  (aref entry 'comment))
		      (usr  (aref entry 'user))
		      (tms  (aref entry 'timestamp)))
		 ;; (print "btag: " btag " tags: " tags " usr: " usr)
		 (if (equal? btag branch) ;; we are on the branch
		     (begin
		       (if (member start-tag tags)(set! start-flag #t))
		       (let ((res (if (and start-flag
					   (not end-flag))
				      `(,usr
					,(time->string (seconds->local-time tms) "WW%U.%w %H:%M")
					,cmt)
				      #f)))
			 (if (member end-tag tags)(set! end-flag #t))
			 res))
		     #f)))))
       (reverse timeline))))))

(define (pair-car->symbol x)
  (cons (string->symbol (car x))(cdr x)))

;; from the command line pull branch, start-tag, end-tag
;; return the list of alists in correct time order
;;
(define (extract-branch branch start-tag end-tag)
  (let* ((data       (to-alist  ;; get all the data
		      (with-input-from-pipe
			  "fossil json timeline checkin -n 0"
			json-read)))
	 (timeline   (map (lambda (e)
			   (map pair-car->symbol e))
			  (aref (aref data "payload") "timeline"))) ;; extract the timeline alists
	 ;;(timeline   (aref (aref data "payload") "timeline")) ;; extract the timeline alists
	 (start-flag #f)
	 (end-flag   #f))
    ;; now we have all needed data as a list of alists in time order, extract the
    ;; messages for given branch starting at start-tag and ending at end-tag
    (reverse ;; return results oldest to newest
     (filter
      (lambda (x) x)
      (map
       (lambda (entry)
	 (let ((tags (aref entry 'tags)))
	   (if (or (not tags) ;; eh?
		   (not (list? tags)))
	       (begin
		 ;; (with-output-to-port (current-error-port)
		 ;;   (lambda ()
		 ;;     (print "ERROR: bad entry. tags: " tags)))
		 #f)
	       (let* ((btag (car tags))  ;; first tag is the primary branch
		      (tags (cdr tags))  ;; remainder are actual tags
		      (cmt  (aref entry 'comment))
		      (usr  (aref entry 'user))
		      (tms  (aref entry 'timestamp)))
		 ;; (print "btag: " btag " tags: " tags " usr: " usr)
		 (if (equal? btag branch) ;; we are on the branch
		     (begin
		       (if (not start-flag)
			   (if (or (equal? start-tag "-")
				   (member start-tag tags))
			       (set! start-flag #t)))
		       (let ((res (if (and start-flag
					   (not end-flag))
				      (append entry (list (cons 'action 'copy)
							  (cons 'dest   #f)
							  (cons 'mode   'auto)))
				      #f)))
			 (if (member end-tag tags)(set! end-flag #t))
			 res))
		     #f)))))
       (reverse timeline))))))

(define (run-cmd-file cmdfile new-branch-name dest-node)
  (let* ((data (with-input-from-file cmdfile read)))
    (print "fossil set autosync 0")
    (print "fossil branch new "new-branch-name" "dest-node)
    (print "fossil co "new-branch-name)
    (for-each
     (lambda (node)
       (let* ((timestamp (alist-ref 'timestamp node))
	      (comment   (alist-ref 'comment   node))
	      (user      (alist-ref 'user      node))
	      (uuid      (alist-ref 'uuid      node))
	      (action    (alist-ref 'action    node))
	      (dest      (alist-ref 'dest      node))
	      (mode      (alist-ref 'mode      node))
	      (tags      (alist-ref 'tags      node))
	      (remtags   (if (list? tags)(cdr tags)'()))
	      (comfile   (conc "/tmp/"(current-user-name)"-"uuid"-comment.txt")))
	 (print "\nfossil merge --cherrypick "uuid)
	 (with-output-to-file comfile
	   (lambda ()
	     (print comment)
	     (print "From: "uuid)
	     (print "User: "user)))
	 (print "fossil commit -M "comfile)))
     data)
    (print "## fossil set autosync 1")))

(define (process-fossil branch start-tag end-tag)
  (print-rows
   (extract-history branch start-tag end-tag)))

(define usage "Usage: fslutil cmd [...]
  tlsum branch start-tag end-tag 
             : generate a timeline summary
               use - for tags to indicate n/a
               (i.e. get all)
  run cmdfile new-branch-name dest-node
             : migrate the nodes from cmdfile to dest-node
               using branch name new-branch-name
")

(define (main)
  (match
   (command-line-arguments)
   (("help")(print usage))
   (("tlsum" branch start-tag end-tag)
    (process-fossil branch start-tag end-tag))
   (("branchdat" branch start-tag end-tag)
    (pp (extract-branch branch start-tag end-tag)))
   (("run" cmdfile new-branch-name dest-node)
    (run-cmd-file cmdfile new-branch-name dest-node))
   (else
    (print "ERROR: Arguments not recognised.")
    (print usage))))

) ;; end module

(import fslutil)
(main)