ADDED utils/fslutil.scm Index: utils/fslutil.scm ================================================================== --- /dev/null +++ utils/fslutil.scm @@ -0,0 +1,242 @@ +;; 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 . +;; + +(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) +