~evhan/beaker

d87efb5e3d03089bfcff7bba2efd4410f2bf3d97 — Evan Hanson 1 year, 8 months ago 5ac39f9 0.0.11
Add "chicken-lock" program
6 files changed, 141 insertions(+), 14 deletions(-)

M LICENSE
M README.md
M beaker.egg
M beaker.wiki.in
A chicken-lock.scm
M lib/beaker/repository.scm
M LICENSE => LICENSE +1 -1
@@ 1,4 1,4 @@
Copyright (c) 2015-2019, Evan Hanson <evhan@foldling.org>
Copyright (c) 2015-2021, Evan Hanson <evhan@foldling.org>
All rights reserved.

Redistribution and use in source and binary forms, with or without

M README.md => README.md +4 -4
@@ 6,10 6,10 @@ Lab supplies for CHICKEN Scheme.

Beaker is a collection of development tools.

It is currently fairly limited, including only two programs and a small
handful of libraries to make common development tasks easier. If you
have an idea for something that would be useful to include, don't
hesitate to contact the author.
It is currently fairly limited, containing only a few programs and a handful of
extension libraries to make common development tasks easier. If you have an
idea for something that would be useful to include, don't hesitate to contact
the author.

## Documentation


M beaker.egg => beaker.egg +2 -0
@@ 34,6 34,8 @@
  (extension beaker.markdown
   (source "lib/beaker/markdown.scm")
   (component-dependencies beaker.egg.info))
  (program chicken-lock
   (component-dependencies beaker.egg.info beaker.repository))
  (program cdb
   (component-dependencies))
  (program chicken-clean

M beaker.wiki.in => beaker.wiki.in +4 -0
@@ 29,6 29,10 @@ The project's source is available [[https://git.sr.ht/~evhan/beaker|here]].

#(document-program "chicken-lint.scm" "./chicken-lint -help")

=== chicken-lock

#(document-program "chicken-lock.scm" "./chicken-lock -help")

== Extensions

=== Repository Management

A chicken-lock.scm => chicken-lock.scm +112 -0
@@ 0,0 1,112 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Generate an override file for egg dependencies.
;;;
;;; Copyright (c) 2021, Evan Hanson
;;;
;;; See LICENSE for details.
;;;

;;
;; The `chicken-lock` program generates an snapshot of all dependency versions
;; for the given eggs, or any egg files in the current directory.
;;
;; The output is an override file that can then be used to install those same
;; versions later on using the "-override" or "-from-list" flags. For example,
;; you can record the current version of the r7rs egg and all of its
;; dependencies, and then restore them later, like this:
;;
;;     $ chicken-lock r7rs > r7rs.lock
;;     ... time passes...
;;     $ chicken-install -override r7rs.lock r7rs
;;
;; If no eggs are given on the command line, this program will look for egg
;; files in the current directory. This can be used to record the current
;; version of all dependencies for an egg in local development:
;;
;;     $ cat example.egg
;;     ((synopsis "A nice example library")
;;      (build-dependencies matchable)
;;      (dependencies r7rs)
;;      (components (extension example)))
;;     $ chicken-lock > example.egg.lock
;;     ... time passes ...
;;     $ chicken-install -override example.egg.lock
;;
;; Any extra arguments are passed through to `chicken-install` when fetching
;; eggs. So, you can use "-override" to fix some subset of an egg's dependency
;; versions when generating the snapshot, as well as other options like
;; "-verbose" to print more information about what's happening.
;;
(declare
  (module (chicken-lock))
  (import (beaker repository)
          (beaker egg info)
          (chicken condition)
          (chicken errno)
          (chicken file)
          (chicken file posix)
          (chicken format)
          (chicken gc)
          (chicken pathname)
          (chicken pretty-print)
          (chicken process)
          (chicken process-context)
          (chicken string)))

(define (usage status)
  (printf "Usage: ~a [egg ...]" (pathname-file (program-name)))
  (print)
  (exit status))

(define (create-temporary-directory*)
  (set-finalizer!
   (create-temporary-directory)
   (lambda (d)
     (condition-case (delete-directory d #t)
       (e (i/o file)
          (unless (= (errno) errno/noent)
            (signal e)))))))

(define (retrieve-eggs #!optional (eggs '()) (env '()))
  (receive (_ _ status) (process-wait
                         (process-fork
                          (lambda ()
                            (duplicate-fileno fileno/stderr fileno/stdout)
                            (process-execute
                             (chicken-install)
                             (append (list "-retrieve" "-recursive") eggs)
                             (merge-environment-variables env (get-environment-variables))))))
    (unless (zero? status) (exit status))))

(define (cached-eggs #!optional (eggs '()) (env '()))
  (let ((cache (alist-ref "CHICKEN_EGG_CACHE" env string=?)))
    (foldl (lambda (eggs dir)
             (cons (list (pathname-file dir)
                         (call-with-input-file (make-pathname dir "VERSION") read))
                   eggs))
           (list)
           (glob (make-pathname cache "*")))))

(define (generate-overrides #!optional (eggs '()))
  (let* ((cache (create-temporary-directory*))
         (repo  (create-temporary-directory*))
         (env   (list (cons "CHICKEN_EGG_CACHE" cache)
                      (cons "CHICKEN_INSTALL_REPOSITORY" repo)
                      (cons "CHICKEN_REPOSITORY_PATH" repo))))
    (retrieve-eggs eggs env)
    (for-each pretty-print (cached-eggs eggs env))))

(define (main)
  (let ((args '()))
    ((flip for-each)
     (command-line-arguments)
     (lambda (arg)
       (if (member arg '("-h" "-help" "--help"))
           (usage 0)
           (set! args (cons arg args)))))
  (generate-overrides (reverse args))))

(cond-expand
  (compiling (main))
  (else))

M lib/beaker/repository.scm => lib/beaker/repository.scm +18 -9
@@ 2,7 2,7 @@
;;;
;;; Procedures to help manage egg repositories.
;;;
;;; Copyright (c) 2018-2019, Evan Hanson
;;; Copyright (c) 2018-2021, Evan Hanson
;;;
;;; See LICENSE for details.
;;;


@@ 13,7 13,8 @@
;;
(declare
  (module (beaker repository))
  (export chicken-install egg-files repair-repository create-repository)
  (export chicken-install chicken-status egg-files repair-repository create-repository
          merge-environment-variables)
  (import (beaker egg info)
          (chicken condition)
          (chicken file)


@@ 25,17 26,22 @@
          (chicken string)
          (srfi 1)))

(define (alist-merge x . ys)
(define (merge-environment-variables x . ys)
  (foldl (lambda (x* y)
           (alist-update (car y) (cdr y) x*))
         x
         (if (null? ys)
             (list)
             (apply alist-merge ys))))
             (apply merge-environment-variables ys))))

(define (install-egg-home)
  (foreign-value "C_INSTALL_EGG_HOME" c-string))

(define (install-egg-home-files)
  (append (glob (make-pathname (install-egg-home) "/chicken.*.import.so"))
          (glob (make-pathname (install-egg-home) "/srfi-4.import.so"))
          (glob (make-pathname (install-egg-home) "/types.db"))))

;;
;; Returns the full pathname of the `chicken-install` command.
;;


@@ 44,10 50,13 @@
   (foreign-value "C_TARGET_BIN_HOME" c-string)
   (foreign-value "C_CHICKEN_INSTALL_PROGRAM" c-string)))

(define (install-egg-home-files)
  (append (glob (make-pathname (install-egg-home) "/chicken.*.import.so"))
          (glob (make-pathname (install-egg-home) "/srfi-4.import.so"))
          (glob (make-pathname (install-egg-home) "/types.db"))))
;;
;; Returns the full pathname of the `chicken-status` command.
;;
(define (chicken-status)
  (make-pathname
   (foreign-value "C_TARGET_BIN_HOME" c-string)
   (foreign-value "C_CHICKEN_STATUS_PROGRAM" c-string)))

;;
;; Returns a list of all egg-info files in the repository path.


@@ 99,7 108,7 @@
                                    (process-execute
                                     (chicken-install)
                                     (map symbol->string missing)
                                     (alist-merge
                                     (merge-environment-variables
                                      (list (cons "CHICKEN_INSTALL_REPOSITORY" repository)
                                            (cons "CHICKEN_REPOSITORY_PATH" path))
                                      (get-environment-variables)))))))