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