Megatest

fossilrebase.scm at [6c52169286]
Login

File fossil-utils/fossilrebase.scm artifact d36203f150 part of check-in 6c52169286


(use yaml matchable srfi-1 sqlite3 regex)

(define (get-timeline)
  (let* ((inp (open-input-pipe "fossil json timeline checkin -n 0"))
	 (res (yaml-load inp)))
    (close-input-pipe inp)
    res))

(define (get-val data key)
  (alist-ref key data equal?))

(define (any->string val)
  (if (string? val)
      val
      (conc val)))

(define (branch-match branches tags)
  (if (list? tags)
      (any (lambda (x)
	     (member x branches))
	   tags)
      (member tags branches)))

(define (refdb-set-value dbname sheetname row col value)
  (let ((pid (process-run "refdb" `("set" ,dbname ,sheetname ,row ,col ,value))))
    (let-values (((a b c)(process-wait pid)))
      b)))

(define (seconds->std-time-str sec)
  (time->string 
   (seconds->local-time sec)
   "%Y-%m-%d %H:%M:%S"))

(define (gen-refdb dbname branches)
  (if (not (file-exists? (conc dbname "/sheet-names.cfg")))
      (begin
	(print "ERROR: You must precreate the refdb with \"refdb edit <dbname>\"")
	(exit 1)))
  (print "Getting data from timeline...")
  (let* ((data (get-timeline))
	 (branches (string-split branches ",")))
    (print "Got data from timeline...")
    (let* ((timeline (get-val (get-val data "payload") "timeline")))
      (print "Got " (length timeline) " timeline records. Filling refdb...")
    (for-each
     (lambda (rec)
       (let ((uuid (get-val rec "uuid")))
	 (if (branch-match branches (get-val rec "tags"))
	     (let ((tagnum 0)
		   (tags   (get-val rec "tags")))
	       (print "uuid: " uuid " tags: " (get-val rec "tags"))
	       ;; First the tags so they are visible to left
	       (for-each
		(lambda (tagv)
		  (refdb-set-value dbname "timeline" uuid (conc "tag" tagnum) tagv)
		  (set! tagnum (+ tagnum 1)))
		(if (list? tags)
		    tags
		    (list tags)))
	       (for-each
		(lambda (key)
		  (refdb-set-value dbname "timeline" uuid key (any->string (get-val rec key))))
		'("user" "comment"))
	       (refdb-set-value dbname "extra" uuid "parents" (string-intersperse (get-val rec "parents") ","))
	       (refdb-set-value dbname "timeline" uuid "timestamp" (seconds->std-time-str (get-val rec "timestamp")))
	       (refdb-set-value dbname "timeline" uuid "timestamp_sec" (any->string (get-val rec "timestamp")))
	       ))))
     timeline))))

(define (escape-string-for-bash str)
  (string-substitute "'" "''" str #t))

;; tag0 tag1 tag2 cherrypick backout hide usedate recomment user
;; comment timestamp timestamp_sec
;;
(define (get-node-details db node-id)
  (let* ((result #f)
	 (count  0))
    (for-each-row
     (lambda (rowkey tag0 cmdnum cherrypick do-commit backout hide usedate recomment user comment timestamp timestamp_sec)
       (set! result `((uuid . ,rowkey)
		      (tag0 . ,tag0)
		      (cmdnum . ,cmdnum)
		      (cherrypick . ,cherrypick)
		      (do-commit  . ,do-commit)
		      (backout    . ,backout)
		      (hide . ,hide)
		      (usedate . ,usedate)
		      (recomment . ,recomment)
		      (user . ,user)
		      (comment . ,comment)
		      (timestamp . ,timestamp)
		      (timestamp_sec . ,timestamp_sec)))
       (set! count (+ count 1)))
     db
     "SELECT rowkey,tag0,cmdnum,cherrypick,do_commit,backout,hide,usedate,recomment,user,comment,timestamp,timestamp_sec FROM timeline WHERE rowkey LIKE ?;"
     node-id)
    (if (> count 1)
	(print "WARNING: more than one node matches " node-id ", found " count " nodes"))
    result))

;; get branches to create
;;
(define (get-new-branches db)
  (let* ((res '()))
    (for-each-row
     (lambda (rowkey node mode)
       (set! res (cons `((branch . ,rowkey)
			 (node   . ,node)
			 (mode   . ,mode))
		       res)))
     db
     "SELECT rowkey,node,mode FROM branches;")
    res))

;; get cherrypicks
;;
(define (get-cherry-picks db)
  (let* ((res '()))
    (for-each-row
     (lambda (rowkey tag0 cherrypick firstmerge do-commit usedate comment recomment)
       (set! res (cons `((uuid       . ,rowkey)
			 (tag0       . ,tag0)
			 (cherrypick . ,cherrypick)
			 (firstmerge . ,firstmerge)
			 (do-commit  . ,do-commit)
			 (usedate    . ,usedate)
			 (comment    . ,comment)
			 (recomment  . ,recomment))
		       res)))
     db ;; sort desc and the cons puts it back in correct order
     "SELECT rowkey,tag0,cherrypick,firstmerge,do_commit,usedate,comment,recomment FROM timeline WHERE cherrypick != '' AND cherrypick NOT NULL ORDER BY timestamp_sec DESC;")
    res))

;; always private and same time as parent node + 1 second
;;
;; fossil branch new BRANCH-NAME BASIS ?OPTIONS?
;; 
;;        Create a new branch BRANCH-NAME off of check-in BASIS.
;;        Supported options for this subcommand include:
;;        --private             branch is private (i.e., remains local)
;;        --bgcolor COLOR       use COLOR instead of automatic background
;;        --nosign              do not sign contents on this branch
;;        --date-override DATE  DATE to use instead of 'now'
;;        --user-override USER  USER to use instead of the current default
;; 
;;        DATE may be "now" or "YYYY-MM-DDTHH:MM:SS.SSS". If in
;;        year-month-day form, it may be truncated, the "T" may be
;;        replaced by a space, and it may also name a timezone offset
;;        from UTC as "-HH:MM" (westward) or "+HH:MM" (eastward).
;;        Either no timezone suffix or "Z" means UTC.
;; 
(define (create-branch db branch-name parent-node)
  (let* ((parent-info (get-node-details db (conc parent-node "%"))))
    (if (not parent-info)
	(print "ERROR: no info found for node " parent-node)
	(let* ((parent-date (alist-ref 'timestamp parent-info))
	       (parent-user (alist-ref 'user      parent-info)))
	  (print "fossil branch new " branch-name " " parent-node " --private --date-override '" parent-date "'")
	  ;; (print "Creating private branch " branch-name " from node " parent-node)
	  ;; (pp parent-info)
	  ;; (print "")
	  ))))

(define (do-cherrypick db cherrypick dbfname)
  (let* ((tag0       (alist-ref 'tag0 cherrypick))
	 (uuid       (alist-ref 'uuid cherrypick))
	 (nodeinf    (get-node-details db uuid))
	 (nodedate   (alist-ref 'timestamp nodeinf))
	 (user       (alist-ref 'user      nodeinf))
	 (targ       (alist-ref 'cherrypick cherrypick))     ;; do fossil up to this node
	 (firstmerge (alist-ref 'firstmerge cherrypick))
	 (do-commit  (alist-ref 'do-commit     cherrypick)) ;; if yes do a commit
	 (usedate    (alist-ref 'usedate    cherrypick)) ;; if no use current time
	 (comment    (alist-ref 'comment    cherrypick))
	 (recomment  (alist-ref 'recomment cherrypick)))
    (print "#======= Start of cherrypick for " uuid "=======")
    (print "fossil checkout " targ)
    ;; first - do we have a firstmerge?
    (if (and (string? firstmerge)
	     (> (string-length firstmerge) 0))
	(print "fossil merge " firstmerge))
    
    (print "fossil merge --cherrypick " uuid)
    (if #t ;;(member do-commit '("x" "yes"))
	(print "fossil commit -m '" (escape-string-for-bash comment) "' "
	       (if (equal? usedate "no")
		   ""
		   (conc " --date-override '" nodedate "'"))
	       " --user-override " user
	       ))
    (print "if [[ $(fossil status | grep CONFLICT | wc -l) -gt 0 ]];then")
    (print "  echo \"\nHAVE CONFLICT - STOPPING\n\"")
    (print "  echo \"cherry pick of " uuid " into " targ " resulted in conflicts\"")
    (print "  exit 1")
    (print "else")
    (print "  echo GOOD, marking node " uuid " as DONE")
    (print "  refdb set " dbfname " timeline " uuid " status DONE")
    (print "fi")
    (print "#======= end of cherrypick for " uuid "=======")
    (print "")
    ))
		   
;; 
(define (gen-rebase-commands dbname)
  (let* ((sqldbname (conc "/tmp/" (current-user-name) "-" dbname ".db"))
	 (dbfname   (conc (current-directory) "/" dbname))) ;; want the fully qualified path so we can call the generated script from anywhere
    (print "# Create sqlite db " sqldbname "...")
    (system (conc "refdb dump2sqlite3 " dbname " " sqldbname))
    (let* ((db (open-database sqldbname))
	   (branches (get-new-branches db))
	   (cherrypicks (get-cherry-picks db)))
      ;; create the setup
      (dump-setup db)
      
      ;; create the branches
      (for-each
       (lambda (branchdat)
	 (create-branch db
			(alist-ref 'branch branchdat)
			(alist-ref 'node   branchdat)))
       branches)

      ;; create the cherrypicks
      (for-each
       (lambda (cherrypick)
	 (do-cherrypick db cherrypick dbfname))
       cherrypicks)
      )))

(define (dump-setup db)
  (for-each-row
   (lambda (cmd)
     (print cmd))
   db
   "SELECT command FROM 'setup' ORDER BY rowkey ASC;"))

(define help
"fossilrebase - register commits in a refdb, edit them by hand then execute them

WARNING: It is highly recommended you do this on a disconnected copy of your fossil database!!

Usage: fossilrebase cmd [params ...]
  where cmd is one of:
    genrefdb fname b1,b2... : generate a refdb of all the commits for branches matching patterns listed, edit with \"refdb edit fname\"
    dumpcmds fname          : from refdb fname dump fossil commands to implement the rebase you want to do.
")

(define (main)
  (if (< (length (command-line-arguments)) 1)
      (begin
	(print help)
	(exit 1))
      (match (command-line-arguments)
	(("genrefdb" fname branches) (gen-refdb fname branches))
	(("dumpcmds" fname)          (gen-rebase-commands fname))
	(else
	 (print "Sorry, didn't know what to do with \"" (string-intersperse (command-line-arguments) " ") "\"")
	 (exit 1)))))


(main)