diff options
Diffstat (limited to 'tekuti/git.scm')
| -rw-r--r-- | tekuti/git.scm | 170 |
1 files changed, 102 insertions, 68 deletions
diff --git a/tekuti/git.scm b/tekuti/git.scm index 723882a..d154f7c 100644 --- a/tekuti/git.scm +++ b/tekuti/git.scm @@ -20,7 +20,7 @@ ;;; Commentary: ;; -;; This is the main script that will launch tekuti. +;; Using git's object database as a persistent store. ;; ;;; Code: @@ -31,20 +31,25 @@ #:use-module (tekuti config) #:use-module (scheme kwargs) #:use-module (match-bind) + #:use-module ((srfi srfi-1) #:select (filter-map partition)) + #:use-module (srfi srfi-11) ; let-values #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:export (&git-condition git-condition? git-condition-argv git-condition-output git-condition-status false-if-git-error git git* ensure-git-repo git-ls-tree git-ls-subdirs - parse-metadata parse-commit commit-utc-timestamp - commit-parents git-mktree git-rev-parse - git-hash-object git-update-ref + git-mktree git-rev-parse git-hash-object git-update-ref git-commit-tree - with-output-to-blob with-input-from-blob + munge-tree parse-commit commit-utc-timestamp + + with-output-to-blob with-input-from-blob)) - write-indices read-indices)) + +;;; +;;; git conditions +;;; (define-condition-type &git-condition &condition git-condition? (argv git-condition-argv) @@ -55,6 +60,10 @@ `(,guard (c ((,git-condition? c) #f)) ,@body)) +;;; +;;; running git +;;; + (define *debug* #f) (define (trc . args) (if *debug* @@ -86,17 +95,7 @@ (output output) (status ret)))))))) -(define (call-with-temp-file contents proc) - (let* ((template (string-copy "/tmp/tekutiXXXXXX")) - (tmp (mkstemp! template))) - (display contents tmp) - (close tmp) - (unwind-protect - (proc template) - (delete-file template)))) - (define/kwargs (git* args (input #f) (env '())) - ;; foolishness regarding env (if input (call-with-temp-file input @@ -108,6 +107,10 @@ (define (git . args) (git* args)) +;;; +;;; git commands +;;; + (define (is-dir? path) (catch 'system-error (lambda () (eq? (stat:type (stat path)) 'directory)) @@ -137,45 +140,6 @@ (cons name object))) '())) -(define (parse-metadata treeish specs) - (filter - identity - (match-lines (git "show" treeish) - "^([^: ]+): +(.*)$" (_ k v) - (let* ((k (string->symbol k)) - (parse (assq-ref specs k))) - (if parse - (catch 'parse-error - (lambda () - (cons k (parse v))) - (lambda args #f)) - (cons k v)))))) - -(define (parse-commit commit) - (let ((text (git "cat-file" "commit" commit))) - (match-bind - "\n\n(.*)$" text (_ message) - (acons - 'message message - (match-lines (substring text 0 (- (string-length text) (string-length _))) - "^([^ ]+) (.*)$" (_ k v) - (cons (string->symbol k) v)))))) - -(define (commit-utc-timestamp commit) - (match-bind - "^(.*) ([0-9]+) ([+-][0-9]+)" (assq-ref (parse-commit commit) 'committer) - (_ who ts tz) - (let ((ts (string->number ts)) (tz (string->number tz))) - (- ts (* (+ (* (quotient tz 100) 60) (remainder tz 100)) 60))))) - -;; fixme: do to commits what i already did to posts - -(define (commit-parents commit) - (map cdr - (filter - (lambda (x) (eq? (car x) 'parent)) - (parse-commit commit)))) - (define (git-mktree alist) (string-trim-both (git* '("mktree") @@ -197,18 +161,6 @@ (string-trim-both (git* '("hash-object" "-w" "--stdin") #:input contents))) -(define (with-output-to-blob* thunk) - (git-hash-object (with-output-to-string thunk))) - -(define-macro (with-output-to-blob . forms) - `(,with-output-to-blob* (lambda () ,@forms))) - -(define (with-input-from-blob* sha1 thunk) - (with-input-from-string (git "show" sha1) thunk)) - -(define-macro (with-input-from-blob sha1 . forms) - `(,with-input-from-blob* ,sha1 (lambda () ,@forms))) - (define (git-update-ref refname proc count) (let* ((ref (git-rev-parse refname)) (commit (proc ref))) @@ -233,5 +185,87 @@ (format #f "GIT_AUTHOR_DATE=~a +0100" timestamp)) (list "GIT_COMMMITTER=tekuti"))))) -;; fixme: map-pairs +;;; +;;; utilities +;;; + +(define (munge-tree treeish add remove change) + (define (local? x) (null? (car x))) + (define (assert-added-files-not-present names dents) + (for-each + (lambda (dent) + (if (member (car dent) names) + (error "file already added" dent))) + dents)) + (define (assert-referenced-files-present names dents) + (for-each + (lambda (name) + (if (not (assoc name dent-names)) + (error "file already removed" name))) + names)) + (let-values (((dents) (if treeish (git-ls-tree treeish #f) '())) + ((ladd dadd) (partition local? add)) + ((lremove dremove) (partition local? remove)) + ((lchange dchange) (partition local? change))) + (assert-added-files-not-present (map cadr ladd) dents) + (assert-referenced-files-present + (append (map cdr lremove) (map caar lchange)) dents) + ; (trc 'munge-tree treeish add remove change) + (git-mktree + (append + (map cdr ladd) + (filter-map + (lambda (dent) + (cond + ((member (car dent) (map cdr lremove)) + #f) + ((member (car dent) (map cadr lchange)) + (cdr lchange)) + ((and (eq? (caddr dent) 'tree) + (member (car dent) + (map caar (append dadd dremove dchange)))) + (let ((level-down (lambda (x) + (if (equal? (caar x) (car dent)) + (cons (cdar x) (cdr x)) + #f)))) + (list (car dent) + (munge-tree (cadr dent) + (filter-map level-down dadd) + (filter-map level-down dremove) + (filter-map level-down dchange)) + 'tree))) + (else dent))) + (append (filter-map (lambda (x) + (and (not (assoc (caar x) dents)) + (list (caar x) #f 'tree))) + dadd) + dents)))))) + +(define (parse-commit commit) + (let ((text (git "cat-file" "commit" commit))) + (match-bind + "\n\n(.*)$" text (_ message) + (acons + 'message message + (match-lines (substring text 0 (- (string-length text) (string-length _))) + "^([^ ]+) (.*)$" (_ k v) + (cons (string->symbol k) v)))))) +(define (commit-utc-timestamp commit) + (match-bind + "^(.*) ([0-9]+) ([+-][0-9]+)" (assq-ref (parse-commit commit) 'committer) + (_ who ts tz) + (let ((ts (string->number ts)) (tz (string->number tz))) + (- ts (* (+ (* (quotient tz 100) 60) (remainder tz 100)) 60))))) + +(define (with-output-to-blob* thunk) + (git-hash-object (with-output-to-string thunk))) + +(define-macro (with-output-to-blob . forms) + `(,with-output-to-blob* (lambda () ,@forms))) + +(define (with-input-from-blob* sha1 thunk) + (with-input-from-string (git "show" sha1) thunk)) + +(define-macro (with-input-from-blob sha1 . forms) + `(,with-input-from-blob* ,sha1 (lambda () ,@forms))) |