Snow chibi git repo siblings

lib/chibi/snow/commands.scm

@@ -3,6 +3,8 @@
 ;; This code was written by Alex Shinn in 2014 and placed in the
 ;; Public Domain.  All warranties are disclaimed.
 
+(define git-repo-path ".snow-repo.scm")
+
 (define (impl-available? cfg spec confirm?)
   (if (find-in-path (cadr spec))
       (or (null? (cddr spec))
@@ -692,6 +694,74 @@
     (call-with-output-file repo-path
                            (lambda (out) (write-simple-pretty repo out)))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Git Index - add packages to a local repository file.
+
+(define (process->pair-or-null key cmd)
+  (let ((out (process->string cmd)))
+    (if (string=? out "")
+      '()
+      `(,key ,(read-line (open-input-string out))))))
+
+(define (command/git-index cfg spec . pkg-files)
+  (when (null? pkg-files)
+    (error "Give at least one package .tgz file as argument"))
+  (for-each
+    (lambda (pkg-file)
+      (when (not (string-suffix? ".tgz" pkg-file))
+        (error "All packages must be .tgz files. Use snow-chibi package command")))
+    pkg-files)
+  (let* ((repo-path git-repo-path)
+         (dir (path-directory repo-path))
+         ;; If git repo url is ssh, switch it to https except if requested not to
+         (fix-git-url
+           (lambda (cfg url-pair)
+             (let* ((uri (string->uri (cadr url-pair)))
+                    (use-ssh-url? (conf-get cfg '(command git-index use-ssh-url))))
+               `(url ,(uri->string
+                        (uri-with-scheme uri
+                                         (if use-ssh-url? 'ssh 'https)))))))
+         (pkgs (filter-map
+                 (lambda (pkg-file)
+                   (let* ((pkg (package-file-meta pkg-file))
+                          (hash (process->pair-or-null 'hash "git rev-parse HEAD"))
+                          (tag (process->pair-or-null 'tag "git describe --exact-match --tags --abbrev=0"))
+                          (url (fix-git-url cfg (process->pair-or-null 'url "git config --get remote.origin.url")))
+                          (git (cons 'git (remove null? (list hash tag url))))
+                          (updated (tai->rfc-3339 (current-second))))
+                     (when (null? hash)
+                       (error "Directory is not a git repository"))
+                     (and pkg
+                          `(,(car pkg)
+                             ,git
+                             ,@(cdr pkg) (updated ,updated)))))
+                 (if (pair? pkg-files)
+                   pkg-files
+                   (filter package-file?
+                           (map
+                             (lambda (f) (make-path dir f))
+                             (directory-files dir))))))
+         (repo (fold (lambda (pkg repo)
+                       (let ((name (package-name pkg))
+                             (version (package-version pkg)))
+                         (when (not version)
+                           (error "Can not index package without a version" pkg))
+                         `(,(car repo)
+                            ,pkg
+                            ,@(remove
+                                (lambda (x)
+                                  (equal? name (package-name x))
+                                  (equal? version (package-version x))
+                                  )
+                                (cdr repo)))))
+                     (guard (exn (else (list 'repository)))
+                       (car (file->sexp-list repo-path)))
+                     pkgs)))
+    (call-with-output-file repo-path
+                           (lambda (out) (write-simple-pretty repo out)))
+    (display (string-append "Updated " git-repo-path))
+    (newline)))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Gen-key - generate a new RSA key pair.
 
@@ -1190,13 +1260,20 @@
          (local-base (string-append "repo-" repo-id ".scm")))
     (make-path local-dir local-base)))
 
-(define (update-repository cfg repo-uri)
+(define (update-repository cfg repo-uri uri-type)
   (let* ((local-path (repository-local-path cfg repo-uri))
          (local-dir (path-directory local-path))
          (local-tmp (string-append local-path ".tmp."
                                    (number->string (current-second)) "-"
                                    (number->string (current-process-id))))
-         (repo-str (utf8->string (resource->bytevector cfg repo-uri)))
+         (repo-str
+           (cond
+             ((equal? uri-type 'http)
+              (utf8->string (resource->bytevector cfg repo-uri)))
+             ((equal? uri-type 'git)
+              (utf8->string (git-resource->bytevector cfg
+                                                      repo-uri
+                                                      git-repo-path)))))
          (repo (guard (exn (else #f))
                  (let ((repo (read (open-input-string repo-str))))
                    `(,(car repo) (url ,repo-uri) ,@(cdr repo))))))
@@ -1236,14 +1313,14 @@
      #f)))
 
 ;; returns the single repo as a sexp, updated as needed
-(define (maybe-update-repository cfg repo-uri)
+(define (maybe-update-repository cfg repo-uri uri-type)
   (or (guard (exn
               (else
                (warn "error updating remote repository: "
                      repo-uri " error: " exn)
                #f))
         (and (should-update-repository? cfg repo-uri)
-             (update-repository cfg repo-uri)))
+             (update-repository cfg repo-uri uri-type)))
       (guard (exn
               (else
                (warn "error reading local repository: " exn)
@@ -1261,10 +1338,11 @@
 ;; not to be confused with the current-repo util in (chibi snow fort)
 ;; which returns the single host
 (define (current-repositories cfg)
-  (define (make-loc uri trust depth) (vector uri trust depth))
+  (define (make-loc uri uri-type trust depth) (vector uri uri-type trust depth))
   (define (loc-uri loc) (vector-ref loc 0))
-  (define (loc-trust loc) (vector-ref loc 1))
-  (define (loc-depth loc) (vector-ref loc 2))
+  (define (loc-uri-type loc) (vector-ref loc 1))
+  (define (loc-trust loc) (vector-ref loc 2))
+  (define (loc-depth loc) (vector-ref loc 3))
   (define (adjust-package-urls ls uri)
     (map
      (lambda (x)
@@ -1278,7 +1356,7 @@
                (and (pair? x)
                     (eq? 'url (car x))))
              ls)))
-  (let lp ((ls (map (lambda (x) (make-loc x 1.0 0))
+  (let lp ((ls (map (lambda (x) (make-loc x 'http 1.0 0))
                     (get-repository-list cfg)))
            (seen '())
            (res '()))
@@ -1294,10 +1372,13 @@
             (loc-uri (car ls)) (loc-trust (car ls)) )
       (lp (cdr ls)))
      (else
-      (let ((uri (uri-normalize (loc-uri (car ls)))))
+      (let* ((uri-type (loc-uri-type (car ls)))
+             (uri (if (equal? uri-type 'http)
+                    (uri-normalize (loc-uri (car ls)))
+                    (loc-uri (car ls)))))
         (if (member uri seen)
             (lp (cdr ls) seen res)
-            (let* ((repo (maybe-update-repository cfg uri))
+            (let* ((repo (maybe-update-repository cfg uri uri-type))
                    (siblings
                     (if (and (valid-repository? repo)
                              (conf-get cfg 'follow-siblings? #t))
@@ -1309,13 +1390,16 @@
                            (lambda (x)
                              (and (pair? x)
                                   (eq? 'sibling (car x))
-                                  (assoc-get (cdr x) 'url)
+                                  (or (assoc-get (cdr x) 'url)
+                                      (assoc-get (cdr x) 'git))
                                   (make-loc
-                                   (uri-resolve (assoc-get (cdr x) 'url)
-                                                uri-base)
-                                   (* (loc-trust (car ls))
-                                      (or (assoc-get (cdr x) 'trust) 1.0))
-                                   (+ (loc-depth (car ls)) 1))))
+                                    (if (assq 'git (cdr x))
+                                      (assoc-get (cdr (assoc 'git (cdr x))) 'url)
+                                      (uri-resolve (assoc-get (cdr x) 'url) uri-base))
+                                    (if (assq 'git (cdr x)) 'git 'http)
+                                    (* (loc-trust (car ls))
+                                       (or (assoc-get (cdr x) 'trust) 1.0))
+                                    (+ (loc-depth (car ls)) 1))))
                            (cdr repo)))
                         '()))
                    (res (if (valid-repository? repo)
@@ -2704,8 +2788,7 @@
                                   (and (pair? x)
                                        (eq? 'installed-files (car x))))
                                 pkg)
-                      (installed-files ,@installed-files)))
-                   ))
+                      (installed-files ,@installed-files)))))
              (preserve))))))))
 
 (define (install-package-from-file repo impl cfg file)
@@ -2715,13 +2798,24 @@
 
 (define (git-fetch-package repo cfg pkg)
   (call-with-temp-dir
-    "pkg-git-clone"
+    "snow-fort-pkg-git-clone"
     (lambda (dir preserve)
       (let* ((git-tag (package-git-tag pkg))
              (git-branch (cond ((equal? git-tag 'HEAD) `())
                                (git-tag `(--branch ,git-tag))
                                (else `())))
-             (git-hash (package-git-hash pkg))
+             (new-cfg
+               (conf-extend cfg `((version . ,(package-version pkg))
+                                  (author . ,(package-author repo pkg))
+                                  (maintainer . ,(package-maintainer repo pkg)))))
+             (git-hash
+               (let ((hash (package-git-hash pkg)))
+                 (when
+                   (and (not hash)
+                        (not (yes-or-no? new-cfg
+                                         "Git hash missing.\nProceed anyway?")))
+                   (die 2 "Git hash missing" pkg))
+                 hash))
              (git-commands
                (cond (git-tag `((git clone
                                      ,(package-git-url pkg)
@@ -2740,36 +2834,27 @@
                        `((git clone
                               ,(package-git-url pkg)
                               ,dir)))))
-               (git-outputs (map process->output+error+status git-commands))
-               (cloned-hash (read-line
-                              (open-input-string
-                                (process->string `(git -C ,dir rev-parse HEAD)))))
-               (libs
-                 (map (lambda (lib)
-                        (make-path dir
-                                   (string-append (library->path cfg lib) ".sld")))
-                      (package-libraries pkg)))
-               (new-cfg
-                 (conf-extend cfg `((version . ,(package-version pkg))
-                                    (author . ,(package-author repo pkg))
-                                    (maintainer . ,(package-maintainer repo pkg)))))
-               (spec '())
-               (spec+files (package-spec+files new-cfg spec libs)))
-        (when (not (= (list-ref (list-ref git-outputs 0) 2) 0))
-          (error "Git clone failed" (list-ref git-outputs 0)))
-        (when (and (not git-hash)
-                   (not (yes-or-no? new-cfg "Git hash missing.\nProceed anyway?")))
-          (die 2 "Git hash missing" pkg))
+             (git-outputs
+               (let ((outputs (map process->output+error+status git-commands)))
+                 (when (not (= (list-ref (list-ref outputs 0) 2) 0))
+                   (error "Git clone failed" outputs))))
+             (cloned-hash (read-line
+                            (open-input-string
+                              (process->string `(git -C ,dir rev-parse HEAD)))))
+             (libs
+               (map (lambda (lib)
+                      (make-path dir
+                                 (string-append (library->path cfg lib) ".sld")))
+                    (package-libraries pkg)))
+             (spec '())
+             (spec+files (package-spec+files new-cfg spec libs)))
         (when (and git-hash
                    (not (string=? cloned-hash git-hash))
                    (not (yes-or-no? new-cfg
                                     "Package git hash did not match.\n"
                                     "Proceed anyway?")))
           (die 2 "Git hash did not match" pkg))
-        (call-with-temp-file
-          "pkg"
-          (lambda (tmp-path out preserve)
-            (create-package (car spec+files) (cdr spec+files) tmp-path)))))))
+        (create-package (car spec+files) (cdr spec+files) dir)))))
 
 (define (install-package repo impl cfg pkg)
   (cond

lib/chibi/snow/commands.sld

@@ -8,6 +8,7 @@
           command/upload
           command/implementations
           command/index
+          command/git-index
           command/install
           command/install-dependencies
           command/remove

lib/chibi/snow/utils.scm

@@ -173,6 +173,16 @@
             (call-with-input-url uri port->bytevector))
         (file->bytevector (uri-path uri)))))
 
+(define (git-resource->bytevector cfg uri file-path)
+  (call-with-temp-dir
+    "snow-fort-repo-git-clone"
+    (lambda (dir preserve)
+      (let* ((git-commands `((git clone ,uri ,dir --depth=1)))
+             (git-outputs (map process->output+error+status git-commands)))
+        (when (not (= (list-ref (list-ref git-outputs 0) 2) 0))
+          (error "Git clone failed" (list-ref git-outputs 0)))
+        (file->bytevector (make-path dir file-path))))))
+
 ;; path-normalize either a uri or path, and return the result as a string
 (define (uri-normalize x)
   (cond
@@ -245,3 +255,17 @@
                      (lp2 (cdr ls2)
                           (cons (car ls2) seen)
                           (cons (car ls2) res))))))))))))
+
+(define (tai->rfc-3339 seconds)
+  (define (pad2 n)
+    (if (< n 10)
+        (string-append "0" (number->string n))
+        (number->string n)))
+  (let ((tm (seconds->time (exact (round seconds)))))
+    (string-append
+     (number->string (+ 1900 (time-year tm))) "-"
+     (pad2 (+ 1 (time-month tm))) "-"
+     (pad2 (time-day tm)) "T"
+     (pad2 (time-hour tm)) ":"
+     (pad2 (time-minute tm)) ":"
+     (pad2 (time-second tm)) "+00:00")))

lib/chibi/snow/utils.sld

@@ -2,10 +2,11 @@
 (define-library (chibi snow utils)
   (export find-in-path find-sexp-in-path
           write-to-string display-to-string
-          resource->bytevector uri-normalize uri-directory
+          resource->bytevector git-resource->bytevector
+          uri-normalize uri-directory
           version-split version-compare version>? version>=?
           topological-sort assq-ref
-          known-implementations impl->version impl->features)
+          known-implementations impl->version impl->features tai->rfc-3339)
   (import (scheme base)
           (scheme char)
           (scheme file)
@@ -21,7 +22,8 @@
           (chibi process)
           (chibi string)
           (chibi temp-file)
-          (chibi uri))
+          (chibi uri)
+          (chibi time))
   (cond-expand
    (chibi (import (chibi io)))
    (chicken

tools/snow-chibi.scm

@@ -158,6 +158,8 @@
     ,@package-spec))
 (define index-spec
   '())
+(define git-index-spec
+  '(use-ssh-url boolean))
 (define update-spec
   '())
 (define implementations-spec
@@ -214,7 +216,10 @@
       (@ ,upload-spec) (,command/upload files ...))
      (index
       "add a package to a local repository file"
-      (@ ,index-spec) (,command/index files ...))
+      (@ ,index-spec) (,command/index ...))
+     (git-index
+      "add a package to repository file in git repo"
+      (@ ,git-index-spec) (,command/git-index files ...))
      (update
       "force an update of available package status"
       (@ ,update-spec) (,command/update))