Skip to content

Commit beff282

Browse files
ashinnashinn
authored
Merge pull request #1066 from Retropikzel/snow-chibi-git-repo-siblings
Snow chibi git repo siblings
2 parents 7887ecc + 9103646 commit beff282

File tree

5 files changed

+165
-48
lines changed

5 files changed

+165
-48
lines changed

‎lib/chibi/snow/commands.scm‎

Lines changed: 129 additions & 44 deletions
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,8 @@
33
;; This code was written by Alex Shinn in 2014 and placed in the
44
;; Public Domain. All warranties are disclaimed.
55

6+
(define git-repo-path ".snow-repo.scm")
7+
68
(define (impl-available? cfg spec confirm?)
79
(if (find-in-path (cadr spec))
810
(or (null? (cddr spec))
@@ -692,6 +694,74 @@
692694
(call-with-output-file repo-path
693695
(lambda (out) (write-simple-pretty repo out)))))
694696

697+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
698+
;; Git Index - add packages to a local repository file.
699+
700+
(define (process->pair-or-null key cmd)
701+
(let ((out (process->string cmd)))
702+
(if (string=? out "")
703+
'()
704+
`(,key ,(read-line (open-input-string out))))))
705+
706+
(define (command/git-index cfg spec . pkg-files)
707+
(when (null? pkg-files)
708+
(error "Give at least one package .tgz file as argument"))
709+
(for-each
710+
(lambda (pkg-file)
711+
(when (not (string-suffix? ".tgz" pkg-file))
712+
(error "All packages must be .tgz files. Use snow-chibi package command")))
713+
pkg-files)
714+
(let* ((repo-path git-repo-path)
715+
(dir (path-directory repo-path))
716+
;; If git repo url is ssh, switch it to https except if requested not to
717+
(fix-git-url
718+
(lambda (cfg url-pair)
719+
(let* ((uri (string->uri (cadr url-pair)))
720+
(use-ssh-url? (conf-get cfg '(command git-index use-ssh-url))))
721+
`(url ,(uri->string
722+
(uri-with-scheme uri
723+
(if use-ssh-url? 'ssh 'https)))))))
724+
(pkgs (filter-map
725+
(lambda (pkg-file)
726+
(let* ((pkg (package-file-meta pkg-file))
727+
(hash (process->pair-or-null 'hash "git rev-parse HEAD"))
728+
(tag (process->pair-or-null 'tag "git describe --exact-match --tags --abbrev=0"))
729+
(url (fix-git-url cfg (process->pair-or-null 'url "git config --get remote.origin.url")))
730+
(git (cons 'git (remove null? (list hash tag url))))
731+
(updated (tai->rfc-3339 (current-second))))
732+
(when (null? hash)
733+
(error "Directory is not a git repository"))
734+
(and pkg
735+
`(,(car pkg)
736+
,git
737+
,@(cdr pkg) (updated ,updated)))))
738+
(if (pair? pkg-files)
739+
pkg-files
740+
(filter package-file?
741+
(map
742+
(lambda (f) (make-path dir f))
743+
(directory-files dir))))))
744+
(repo (fold (lambda (pkg repo)
745+
(let ((name (package-name pkg))
746+
(version (package-version pkg)))
747+
(when (not version)
748+
(error "Can not index package without a version" pkg))
749+
`(,(car repo)
750+
,pkg
751+
,@(remove
752+
(lambda (x)
753+
(equal? name (package-name x))
754+
(equal? version (package-version x))
755+
)
756+
(cdr repo)))))
757+
(guard (exn (else (list 'repository)))
758+
(car (file->sexp-list repo-path)))
759+
pkgs)))
760+
(call-with-output-file repo-path
761+
(lambda (out) (write-simple-pretty repo out)))
762+
(display (string-append "Updated " git-repo-path))
763+
(newline)))
764+
695765
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
696766
;; Gen-key - generate a new RSA key pair.
697767

@@ -1190,13 +1260,20 @@
11901260
(local-base (string-append "repo-" repo-id ".scm")))
11911261
(make-path local-dir local-base)))
11921262

1193-
(define (update-repository cfg repo-uri)
1263+
(define (update-repository cfg repo-uri uri-type)
11941264
(let* ((local-path (repository-local-path cfg repo-uri))
11951265
(local-dir (path-directory local-path))
11961266
(local-tmp (string-append local-path ".tmp."
11971267
(number->string (current-second)) "-"
11981268
(number->string (current-process-id))))
1199-
(repo-str (utf8->string (resource->bytevector cfg repo-uri)))
1269+
(repo-str
1270+
(cond
1271+
((equal? uri-type 'http)
1272+
(utf8->string (resource->bytevector cfg repo-uri)))
1273+
((equal? uri-type 'git)
1274+
(utf8->string (git-resource->bytevector cfg
1275+
repo-uri
1276+
git-repo-path)))))
12001277
(repo (guard (exn (else #f))
12011278
(let ((repo (read (open-input-string repo-str))))
12021279
`(,(car repo) (url ,repo-uri) ,@(cdr repo))))))
@@ -1236,14 +1313,14 @@
12361313
#f)))
12371314

12381315
;; returns the single repo as a sexp, updated as needed
1239-
(define (maybe-update-repository cfg repo-uri)
1316+
(define (maybe-update-repository cfg repo-uri uri-type)
12401317
(or (guard (exn
12411318
(else
12421319
(warn "error updating remote repository: "
12431320
repo-uri " error: " exn)
12441321
#f))
12451322
(and (should-update-repository? cfg repo-uri)
1246-
(update-repository cfg repo-uri)))
1323+
(update-repository cfg repo-uri uri-type)))
12471324
(guard (exn
12481325
(else
12491326
(warn "error reading local repository: " exn)
@@ -1261,10 +1338,11 @@
12611338
;; not to be confused with the current-repo util in (chibi snow fort)
12621339
;; which returns the single host
12631340
(define (current-repositories cfg)
1264-
(define (make-loc uri trust depth) (vector uri trust depth))
1341+
(define (make-loc uri uri-type trust depth) (vector uri uri-type trust depth))
12651342
(define (loc-uri loc) (vector-ref loc 0))
1266-
(define (loc-trust loc) (vector-ref loc 1))
1267-
(define (loc-depth loc) (vector-ref loc 2))
1343+
(define (loc-uri-type loc) (vector-ref loc 1))
1344+
(define (loc-trust loc) (vector-ref loc 2))
1345+
(define (loc-depth loc) (vector-ref loc 3))
12681346
(define (adjust-package-urls ls uri)
12691347
(map
12701348
(lambda (x)
@@ -1278,7 +1356,7 @@
12781356
(and (pair? x)
12791357
(eq? 'url (car x))))
12801358
ls)))
1281-
(let lp ((ls (map (lambda (x) (make-loc x 1.0 0))
1359+
(let lp ((ls (map (lambda (x) (make-loc x 'http 1.0 0))
12821360
(get-repository-list cfg)))
12831361
(seen '())
12841362
(res '()))
@@ -1294,10 +1372,13 @@
12941372
(loc-uri (car ls)) (loc-trust (car ls)) )
12951373
(lp (cdr ls)))
12961374
(else
1297-
(let ((uri (uri-normalize (loc-uri (car ls)))))
1375+
(let* ((uri-type (loc-uri-type (car ls)))
1376+
(uri (if (equal? uri-type 'http)
1377+
(uri-normalize (loc-uri (car ls)))
1378+
(loc-uri (car ls)))))
12981379
(if (member uri seen)
12991380
(lp (cdr ls) seen res)
1300-
(let* ((repo (maybe-update-repository cfg uri))
1381+
(let* ((repo (maybe-update-repository cfg uri uri-type))
13011382
(siblings
13021383
(if (and (valid-repository? repo)
13031384
(conf-get cfg 'follow-siblings? #t))
@@ -1309,13 +1390,16 @@
13091390
(lambda (x)
13101391
(and (pair? x)
13111392
(eq? 'sibling (car x))
1312-
(assoc-get (cdr x) 'url)
1393+
(or (assoc-get (cdr x) 'url)
1394+
(assoc-get (cdr x) 'git))
13131395
(make-loc
1314-
(uri-resolve (assoc-get (cdr x) 'url)
1315-
uri-base)
1316-
(* (loc-trust (car ls))
1317-
(or (assoc-get (cdr x) 'trust) 1.0))
1318-
(+ (loc-depth (car ls)) 1))))
1396+
(if (assq 'git (cdr x))
1397+
(assoc-get (cdr (assoc 'git (cdr x))) 'url)
1398+
(uri-resolve (assoc-get (cdr x) 'url) uri-base))
1399+
(if (assq 'git (cdr x)) 'git 'http)
1400+
(* (loc-trust (car ls))
1401+
(or (assoc-get (cdr x) 'trust) 1.0))
1402+
(+ (loc-depth (car ls)) 1))))
13191403
(cdr repo)))
13201404
'()))
13211405
(res (if (valid-repository? repo)
@@ -2704,8 +2788,7 @@
27042788
(and (pair? x)
27052789
(eq? 'installed-files (car x))))
27062790
pkg)
2707-
(installed-files ,@installed-files)))
2708-
))
2791+
(installed-files ,@installed-files)))))
27092792
(preserve))))))))
27102793

27112794
(define (install-package-from-file repo impl cfg file)
@@ -2715,13 +2798,24 @@
27152798

27162799
(define (git-fetch-package repo cfg pkg)
27172800
(call-with-temp-dir
2718-
"pkg-git-clone"
2801+
"snow-fort-pkg-git-clone"
27192802
(lambda (dir preserve)
27202803
(let* ((git-tag (package-git-tag pkg))
27212804
(git-branch (cond ((equal? git-tag 'HEAD) `())
27222805
(git-tag `(--branch ,git-tag))
27232806
(else `())))
2724-
(git-hash (package-git-hash pkg))
2807+
(new-cfg
2808+
(conf-extend cfg `((version . ,(package-version pkg))
2809+
(author . ,(package-author repo pkg))
2810+
(maintainer . ,(package-maintainer repo pkg)))))
2811+
(git-hash
2812+
(let ((hash (package-git-hash pkg)))
2813+
(when
2814+
(and (not hash)
2815+
(not (yes-or-no? new-cfg
2816+
"Git hash missing.\nProceed anyway?")))
2817+
(die 2 "Git hash missing" pkg))
2818+
hash))
27252819
(git-commands
27262820
(cond (git-tag `((git clone
27272821
,(package-git-url pkg)
@@ -2740,36 +2834,27 @@
27402834
`((git clone
27412835
,(package-git-url pkg)
27422836
,dir)))))
2743-
(git-outputs (map process->output+error+status git-commands))
2744-
(cloned-hash (read-line
2745-
(open-input-string
2746-
(process->string `(git -C ,dir rev-parse HEAD)))))
2747-
(libs
2748-
(map (lambda (lib)
2749-
(make-path dir
2750-
(string-append (library->path cfg lib) ".sld")))
2751-
(package-libraries pkg)))
2752-
(new-cfg
2753-
(conf-extend cfg `((version . ,(package-version pkg))
2754-
(author . ,(package-author repo pkg))
2755-
(maintainer . ,(package-maintainer repo pkg)))))
2756-
(spec '())
2757-
(spec+files (package-spec+files new-cfg spec libs)))
2758-
(when (not (= (list-ref (list-ref git-outputs 0) 2) 0))
2759-
(error "Git clone failed" (list-ref git-outputs 0)))
2760-
(when (and (not git-hash)
2761-
(not (yes-or-no? new-cfg "Git hash missing.\nProceed anyway?")))
2762-
(die 2 "Git hash missing" pkg))
2837+
(git-outputs
2838+
(let ((outputs (map process->output+error+status git-commands)))
2839+
(when (not (= (list-ref (list-ref outputs 0) 2) 0))
2840+
(error "Git clone failed" outputs))))
2841+
(cloned-hash (read-line
2842+
(open-input-string
2843+
(process->string `(git -C ,dir rev-parse HEAD)))))
2844+
(libs
2845+
(map (lambda (lib)
2846+
(make-path dir
2847+
(string-append (library->path cfg lib) ".sld")))
2848+
(package-libraries pkg)))
2849+
(spec '())
2850+
(spec+files (package-spec+files new-cfg spec libs)))
27632851
(when (and git-hash
27642852
(not (string=? cloned-hash git-hash))
27652853
(not (yes-or-no? new-cfg
27662854
"Package git hash did not match.\n"
27672855
"Proceed anyway?")))
27682856
(die 2 "Git hash did not match" pkg))
2769-
(call-with-temp-file
2770-
"pkg"
2771-
(lambda (tmp-path out preserve)
2772-
(create-package (car spec+files) (cdr spec+files) tmp-path)))))))
2857+
(create-package (car spec+files) (cdr spec+files) dir)))))
27732858

27742859
(define (install-package repo impl cfg pkg)
27752860
(cond

‎lib/chibi/snow/commands.sld‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@
88
command/upload
99
command/implementations
1010
command/index
11+
command/git-index
1112
command/install
1213
command/install-dependencies
1314
command/remove

‎lib/chibi/snow/utils.scm‎

Lines changed: 24 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -173,6 +173,16 @@
173173
(call-with-input-url uri port->bytevector))
174174
(file->bytevector (uri-path uri)))))
175175

176+
(define (git-resource->bytevector cfg uri file-path)
177+
(call-with-temp-dir
178+
"snow-fort-repo-git-clone"
179+
(lambda (dir preserve)
180+
(let* ((git-commands `((git clone ,uri ,dir --depth=1)))
181+
(git-outputs (map process->output+error+status git-commands)))
182+
(when (not (= (list-ref (list-ref git-outputs 0) 2) 0))
183+
(error "Git clone failed" (list-ref git-outputs 0)))
184+
(file->bytevector (make-path dir file-path))))))
185+
176186
;; path-normalize either a uri or path, and return the result as a string
177187
(define (uri-normalize x)
178188
(cond
@@ -245,3 +255,17 @@
245255
(lp2 (cdr ls2)
246256
(cons (car ls2) seen)
247257
(cons (car ls2) res))))))))))))
258+
259+
(define (tai->rfc-3339 seconds)
260+
(define (pad2 n)
261+
(if (< n 10)
262+
(string-append "0" (number->string n))
263+
(number->string n)))
264+
(let ((tm (seconds->time (exact (round seconds)))))
265+
(string-append
266+
(number->string (+ 1900 (time-year tm))) "-"
267+
(pad2 (+ 1 (time-month tm))) "-"
268+
(pad2 (time-day tm)) "T"
269+
(pad2 (time-hour tm)) ":"
270+
(pad2 (time-minute tm)) ":"
271+
(pad2 (time-second tm)) "+00:00")))

‎lib/chibi/snow/utils.sld‎

Lines changed: 5 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -2,10 +2,11 @@
22
(define-library (chibi snow utils)
33
(export find-in-path find-sexp-in-path
44
write-to-string display-to-string
5-
resource->bytevector uri-normalize uri-directory
5+
resource->bytevector git-resource->bytevector
6+
uri-normalize uri-directory
67
version-split version-compare version>? version>=?
78
topological-sort assq-ref
8-
known-implementations impl->version impl->features)
9+
known-implementations impl->version impl->features tai->rfc-3339)
910
(import (scheme base)
1011
(scheme char)
1112
(scheme file)
@@ -21,7 +22,8 @@
2122
(chibi process)
2223
(chibi string)
2324
(chibi temp-file)
24-
(chibi uri))
25+
(chibi uri)
26+
(chibi time))
2527
(cond-expand
2628
(chibi (import (chibi io)))
2729
(chicken

‎tools/snow-chibi.scm‎

Lines changed: 6 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -158,6 +158,8 @@
158158
,@package-spec))
159159
(define index-spec
160160
'())
161+
(define git-index-spec
162+
'(use-ssh-url boolean))
161163
(define update-spec
162164
'())
163165
(define implementations-spec
@@ -214,7 +216,10 @@
214216
(@ ,upload-spec) (,command/upload files ...))
215217
(index
216218
"add a package to a local repository file"
217-
(@ ,index-spec) (,command/index files ...))
219+
(@ ,index-spec) (,command/index ...))
220+
(git-index
221+
"add a package to repository file in git repo"
222+
(@ ,git-index-spec) (,command/git-index files ...))
218223
(update
219224
"force an update of available package status"
220225
(@ ,update-spec) (,command/update))

0 commit comments

Comments
 (0)