;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Generate an override file for egg dependencies.
;;;
;;; Copyright (c) 2021-2022, 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
;;
;; This program works by fetching eggs into a temporary directory, so network
;; access is required. If a `-command` flag is given, the remaining arguments
;; will be called with the temporary egg cache directory name as a single
;; argument. In this case, output will be suppressed and the cache directory
;; will not be removed automatically. This feature can be used to print the
;; directory name, for example, or to hash the directory for use with Nix:
;;
;;     $ chicken-lock r7rs -command nix hash path
;;     ... some output ...
;;     sha256-ggZvueP0uJYl87AwTuTLYtRr2SmP3PeJqpMMFyDfS+U=
;;
;; 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 or "-test" to
;; include test dependencies.
;;
(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 ...] [-command arg ...]" (pathname-file (program-name)))
  (print)
  (exit status))

(define (status-file? path)
  (equal? (pathname-file path) "STATUS"))

(define (timestamp-file? path)
  (equal? (pathname-file path) "TIMESTAMP"))

(define (clean-cache-directory path)
  (find-files path limit: 1 test: (disjoin status-file? timestamp-file?) action: (lambda (f _) (delete-file* f))))

(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 (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 (print-cached-eggs #!optional (env '()))
  (for-each pretty-print (cached-eggs env)))

(define (create-cache #!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)
    (clean-cache-directory cache)
    (values cache repo env)))

(define (main)
  (let ((eggs '())
        (command '()))
    (let loop ((args (command-line-arguments)))
      (cond ((null? args))
            ((member (car args) '("-h" "-help" "--help"))
             (usage 0))
            ((member (car args) '("-c" "-command" "--command"))
             (set! command (cdr args)))
            (else
             (set! eggs (cons (car args) eggs))
             (loop (cdr args)))))
    (receive (cache repo env) (create-cache (reverse eggs))
      (if (null? command)
          (print-cached-eggs env)
          (process-execute (car command) (append (cdr command) (list cache)))))))

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