(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)