;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Generate an override file for egg dependencies.
;;;
;;; Copyright (c) 2021, Evan Hanson
;;;
;;; See LICENSE for details.
;;;

;;
;; The `chicken-lock` program generates a snapshot of all dependency versions
;; for the given eggs, or for 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 via the "-override" or "-from-list" flags to `chicken-install`.
;; 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 -from-list r7rs.lock
;;
;; If no egg names 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))