Add -k and -n flags, suggested by Diego "dieggsy"

The -k or -keep option tells henrietta-cache to throw away older
releases, so that only the supplied number of latest releases is kept.

The -n option tells henrietta-cache to not download any new releases.
It can be used if one wants to prune old releases, together with -k.

1 files changed, 101 insertions, 38 deletions

diff --git a/henrietta-cache.scm b/henrietta-cache.scm
index 15921af..5381935 100644
--- a/henrietta-cache.scm
+++ b/henrietta-cache.scm
@@ -8,7 +8,8 @@
   (chicken-5 (import (chicken base) (chicken condition) (chicken file)
                      (chicken format) (chicken string) (chicken port)
                      (chicken process) (chicken process-context)
-                     (chicken pathname) (chicken io) 
+                     (chicken pathname) (chicken io) (chicken sort)
+                     (chicken irregex)
                      http-client matchable uri-common srfi-1)))
 
 (define (usage code)
@@ -21,6 +22,8 @@ usage: henrietta-cache [OPTION ...]
                                 eggs, defaults to "egg-locations". Can be an URI
   -i   -init-file INITFILE      a file to load before starting the process
   -r   -chicken-release REL     the major CHICKEN release version for which to fetch (defaults to 4)
+  -k   -keep NUM                only keep this many latest releases, delete the rest
+  -n   -no-download             don't download any releases (useful for purging in combination with -k)
 
 Henrietta-cache will download cached copies of each egg listed in the file
 EGGLIST, to CACHEDIR.
@@ -33,6 +36,8 @@ EOF
 (define *egg-list* "egg-locations")
 (define *chicken-release* 4)
 (define *init-file* #f)
+(define *keep-number* #f)
+(define *no-download* #f)
 
 (define download-release-success-hook
   (make-parameter #f))
@@ -48,6 +53,25 @@ EOF
     (download-release-error   . ,download-release-error-hook)
     (read-release-info-file-error . ,read-release-info-file-error-hook)))
 
+(define (version<=? v1 v2)
+  (define (version->list v)
+    (map (lambda (x) (or (string->number x) x))
+         (irregex-split "[-\\._]" (->string v))))
+  (let loop ((p1 (version->list v1))
+             (p2 (version->list v2)))
+    (cond ((null? p1) (null? p2))
+          ((null? p2))
+          ((number? (car p1))
+           (and (number? (car p2))
+                (or (< (car p1) (car p2))
+                    (and (= (car p1) (car p2))
+                         (loop (cdr p1) (cdr p2))))))
+          ((number? (car p2)))
+          ((string<? (car p1) (car p2)))
+          (else
+           (and (string=? (car p1) (car p2))
+                (loop (cdr p1) (cdr p2)))))))
+
 (define (run-hook hook-name . args)
   (and-let* ((hook (or (alist-ref hook-name hooks)
                        (error "invalid hook" hook-name)))
@@ -233,42 +257,73 @@ EOF
     (else (error "Unknown distribution file type" distribution-file-type))))
 
 (define (download-all-release-files egg-name uris/releases uris)
-  (let ((egg-cache-dir (make-pathname *cache-directory* (->string egg-name))))
-    (for-each (lambda (uri/releases)
-                (and-let* ((uri-alias (car uri/releases))
-                           (uri-info (alist-ref uri-alias uris))
-                           (type (car uri-info))
-                           (uri-template (cadr uri-info)))
-                  (for-each
-                   (lambda (egg-release)
-                     (let ((cache-dir (make-pathname egg-cache-dir egg-release)))
-                       (unless (file-exists? cache-dir)
-                         (let* ((patterns `((egg-name . ,egg-name)
-                                            (egg-release . ,egg-release)
-                                            (chicken-release . ,*chicken-release*)))
-                                (uri (replace-uri-patterns uri-template patterns)))
-                           (printf "\tDownloading egg version ~A from ~A (CHICKEN release ~A)\n"
-                                   egg-release uri *chicken-release*)
-                           (flush-output)
-                           (handle-exceptions exn
-                             (begin
-                               (system (sprintf "rm -rf ~A" (qs cache-dir)))
-                               (fprintf (current-error-port)
-                                        "Error downloading or extracting egg '~A' release ~A (CHICKEN release ~A): "
-                                        egg-name egg-release *chicken-release*)
-                               (print-error-message exn (current-error-port))
-                               (flush-output (current-error-port))
-                               (run-hook 'download-release-error
-                                         *chicken-release*
-                                         egg-name
-                                         egg-release
-                                         (get-condition-property exn 'exn 'message)))
-                             (download-release type uri cache-dir)
-                             (run-hook 'download-release-success
-                                       *chicken-release*
-                                       egg-name egg-release))))))
-                   (cdr uri/releases))))
-              uris/releases)))
+  (let* ((egg-cache-dir (make-pathname *cache-directory* (->string egg-name)))
+         (all-versions-alist
+          (sort
+           (append-map
+            (lambda (uri/releases)
+              (or (and-let* ((uri-alias (car uri/releases))
+                             (uri-info (alist-ref uri-alias uris))
+                             (type (car uri-info)))
+                    (map
+                     (lambda (egg-release)
+                       (list egg-release type uri-alias))
+                     (cdr uri/releases)))
+                  '()))
+            uris/releases)
+           (lambda (a b) (version<=? (car a) (car b)))))
+         (num-versions (length all-versions-alist)))
+    (unless *no-download*
+     (for-each
+      (lambda (egg)
+        (let* ((egg-release (car egg))
+               (type (cadr egg))
+               (uri-alias (caddr egg))
+               (uri-template (cadr (alist-ref uri-alias uris)))
+               (cache-dir (make-pathname egg-cache-dir egg-release)))
+          (unless (file-exists? cache-dir)
+            (let* ((patterns `((egg-name . ,egg-name)
+                               (egg-release . ,egg-release)
+                               (chicken-release . ,*chicken-release*)))
+                   (uri (replace-uri-patterns uri-template patterns)))
+              (printf "\tDownloading egg version ~A from ~A (CHICKEN release ~A)\n"
+                egg-release uri *chicken-release*)
+              (flush-output)
+              (handle-exceptions exn
+                  (begin
+                    (system (sprintf "rm -rf ~A" (qs cache-dir)))
+                    (fprintf (current-error-port)
+                        "Error downloading or extracting egg '~A' release ~A (CHICKEN release ~A): "
+                      egg-name egg-release *chicken-release*)
+                    (print-error-message exn (current-error-port))
+                    (flush-output (current-error-port))
+                    (run-hook 'download-release-error
+                              *chicken-release*
+                              egg-name
+                              egg-release
+                              (get-condition-property exn 'exn 'message)))
+                (download-release type uri cache-dir)
+                (run-hook 'download-release-success
+                          *chicken-release*
+                          egg-name egg-release))))))
+      ;; TODO: Maybe avoid hitting the network at all when -n is
+      ;; supplied?  That would require us to sort the files on disk
+      ;; too, which is a bit annoying.
+      (if *keep-number*
+          (take-right all-versions-alist
+                      (if (< num-versions *keep-number*)
+                          num-versions
+                          *keep-number*))
+          all-versions-alist)))
+    (when (and *keep-number* (> num-versions *keep-number*))
+      (for-each
+       (lambda (egg)
+         (let* ((egg-release (car egg))
+                (cache-dir (make-pathname egg-cache-dir egg-release)))
+           (when (file-exists? cache-dir)
+             (printf "\tDeleting egg version ~A\n" egg-release)
+             (delete-directory cache-dir #t))))
+       (drop-right all-versions-alist *keep-number*)))))
 
 (define (alist-add! key value alist)
   (alist-update! key (cons value (alist-ref key alist eq? '())) alist))
@@ -335,7 +390,7 @@ EOF
          (call-with-input-request uri #f read-list)
          (call-with-input-file *egg-list* read-list)))))
 
-(define *short-options* '(#\h #\c #\e))
+(define *short-options* '(#\h #\c #\e #\n #\k))
 
 (define (main args)
   (let loop ((args args))
@@ -363,6 +418,14 @@ EOF
                  (handle-exceptions exn (usage 1)
                    (set! *chicken-release* (string->number (cadr args))))
                  (loop (cddr args)))
+                ((or (string=? arg "-k") (string=? arg "-keep"))
+                 (unless (pair? (cdr args)) (usage 1))
+                 (handle-exceptions exn (usage 1)
+                   (set! *keep-number* (string->number (cadr args))))
+                 (loop (cddr args)))
+                ((or (string=? arg "-n") (string=? arg "-no-download"))
+                 (set! *no-download* #t)
+                 (loop (cdr args)))
                 ((and (positive? (string-length arg))
                       (char=? #\- (string-ref arg 0)))
                  (if (> (string-length arg) 2)