From 02e38e71fe666262489e460860cf0250833a5092 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sun, 22 Sep 2019 15:50:11 +0200 Subject: 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. --- henrietta-cache.scm | 139 ++++++++++++++++++++++++++++++++++++++-------------- 1 file 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))) + ((stringstring 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) -- cgit v1.2.3