From 7148cdf7f0a65b01182ea0b383305daccec92864 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 15 May 2012 21:49:22 -0600 Subject: [PATCH] New archives, smaller --- collects/meta/drdr/archive-repair.rkt | 17 +++ collects/meta/drdr/archive-repair.sh | 8 ++ collects/meta/drdr/archive.rkt | 141 ++++++++++++++---------- collects/meta/drdr/dirstruct.rkt | 3 + collects/meta/drdr/main.rkt | 30 +++-- collects/meta/drdr/make-archive-lib.rkt | 21 ++++ collects/meta/drdr/make-archive.rkt | 24 +--- collects/meta/drdr/plt-build.rkt | 2 +- collects/meta/drdr/render.rkt | 9 ++ 9 files changed, 162 insertions(+), 93 deletions(-) create mode 100644 collects/meta/drdr/archive-repair.rkt create mode 100755 collects/meta/drdr/archive-repair.sh create mode 100644 collects/meta/drdr/make-archive-lib.rkt diff --git a/collects/meta/drdr/archive-repair.rkt b/collects/meta/drdr/archive-repair.rkt new file mode 100644 index 0000000000..dde4a684d5 --- /dev/null +++ b/collects/meta/drdr/archive-repair.rkt @@ -0,0 +1,17 @@ +#lang racket +(require "config.rkt" + "archive.rkt" + "path-utils.rkt" + "dirstruct.rkt" + "make-archive-lib.rkt") + +(init-revisions!) + +(define rev + (command-line #:program "archive-repair" + #:args (n) (string->number n))) + +(when (file-exists? (revision-archive rev)) + (archive-extract-to (revision-archive rev) (revision-dir rev) (revision-dir rev)) + (delete-file (revision-archive rev)) + (make-archive rev)) diff --git a/collects/meta/drdr/archive-repair.sh b/collects/meta/drdr/archive-repair.sh new file mode 100755 index 0000000000..cd6f7f4b03 --- /dev/null +++ b/collects/meta/drdr/archive-repair.sh @@ -0,0 +1,8 @@ +#!/bin/bash + +cd /opt/plt/builds +for i in * ; do + if [ -f ${i}/archive.db ] ; then + /opt/plt/plt/bin/racket -t /opt/svn/drdr/archive-repair.rkt -- $i + fi +done diff --git a/collects/meta/drdr/archive.rkt b/collects/meta/drdr/archive.rkt index 933282b297..7bca775151 100644 --- a/collects/meta/drdr/archive.rkt +++ b/collects/meta/drdr/archive.rkt @@ -13,28 +13,28 @@ (define vals empty) (define (make-table path) (for/hash ([p (in-list (directory-list path))]) - (define fp (build-path path p)) - (define directory? - (directory-exists? fp)) - (define val - (if directory? - (value->bytes (make-table fp)) - (file->bytes fp))) - (define len (bytes-length val)) - (begin0 - (values (path->string p) - (vector directory? start len)) - (set! start (+ start len)) - (set! vals (cons val vals))))) - (define root-table + (define fp (build-path path p)) + (define directory? + (directory-exists? fp)) + (define val + (if directory? + (value->bytes (make-table fp)) + (file->bytes fp))) + (define len (bytes-length val)) + (begin0 + (values (path->string p) + (vector directory? start len)) + (set! start (+ start len)) + (set! vals (cons val vals))))) + (define root-table (value->bytes (make-table root))) - + (with-output-to-file archive-path #:exists 'replace (lambda () (write (path->string* root)) (write root-table) - + (for ([v (in-list (reverse vals))]) (write-bytes v))))) @@ -54,70 +54,91 @@ archive-path (lambda (fport) (dynamic-wind - void - (lambda () - (define root-string (read/? fport string? bad-archive)) - (define root (string->path root-string)) - (define roots (explode-path root)) - (define root-len (length roots)) - (unless (root-len . <= . (length ps)) - (not-in-archive)) - (local [(define ps-roots (list-tail ps root-len)) - (define root-table-bytes (read/? fport bytes? bad-archive)) - (define root-table (bytes->value root-table-bytes hash? bad-archive)) - (define heap-start (file-position fport)) - (define (extract-bytes t p) - (match (hash-ref t (path->string p) not-in-archive) - [(vector directory? file-start len) - ; Jump ahead in the file - (file-position fport (+ heap-start file-start)) - ; Read the bytes - (local [(define bs (read-bytes len fport))] - (unless (= (bytes-length bs) len) - (bad-archive)) - (values directory? bs))])) - (define (extract-table t p) - (define-values (dir? bs) (extract-bytes t p)) - (if dir? - (bytes->value bs hash? bad-archive) - (not-in-archive))) - (define (find-file ps-roots table) - (match ps-roots - [(list p) - (extract-bytes table p)] - [(list-rest p rst) - (find-file rst (extract-table table p))]))] - (if (empty? ps-roots) - (values #t root-table-bytes) - (find-file ps-roots root-table)))) - (lambda () - (close-input-port fport)))))) + void + (lambda () + (define root-string (read/? fport string? bad-archive)) + (define root (string->path root-string)) + (define roots (explode-path root)) + (define root-len (length roots)) + (unless (root-len . <= . (length ps)) + (not-in-archive)) + (local [(define ps-roots (list-tail ps root-len)) + (define root-table-bytes (read/? fport bytes? bad-archive)) + (define root-table (bytes->value root-table-bytes hash? bad-archive)) + (define heap-start (file-position fport)) + (define (extract-bytes t p) + (match (hash-ref t (path->string p) not-in-archive) + [(vector directory? file-start len) + ; Jump ahead in the file + (file-position fport (+ heap-start file-start)) + ; Read the bytes + (local [(define bs (read-bytes len fport))] + (unless (= (bytes-length bs) len) + (bad-archive)) + (values directory? bs))])) + (define (extract-table t p) + (define-values (dir? bs) (extract-bytes t p)) + (if dir? + (bytes->value bs hash? bad-archive) + (not-in-archive))) + (define (find-file ps-roots table) + (match ps-roots + [(list p) + (extract-bytes table p)] + [(list-rest p rst) + (find-file rst (extract-table table p))]))] + (if (empty? ps-roots) + (values #t root-table-bytes) + (find-file ps-roots root-table)))) + (lambda () + (close-input-port fport)))))) (define (archive-extract-file archive-path fp) (define-values (dir? bs) (archive-extract-path archive-path fp)) (if dir? - (error 'archive-extract-file "~e is not a file" fp) - bs)) + (error 'archive-extract-file "~e is not a file" fp) + bs)) (define (archive-directory-list archive-path fp) (define (bad-archive) (error 'archive-directory-list "~e is not a valid archive" archive-path)) (define-values (dir? bs) (archive-extract-path archive-path fp)) (if dir? - (for/list ([k (in-hash-keys (bytes->value bs hash? bad-archive))]) - (build-path k)) - (error 'archive-directory-list "~e is not a directory" fp))) + (for/list ([k (in-hash-keys (bytes->value bs hash? bad-archive))]) + (build-path k)) + (error 'archive-directory-list "~e is not a directory" fp))) (define (archive-directory-exists? archive-path fp) - (define-values (dir? _) + (define-values (dir? _) (with-handlers ([exn:fail? (lambda (x) (values #f #f))]) (archive-extract-path archive-path fp))) dir?) +(define (archive-extract-to archive-file-path archive-inner-path to) + (printf "~a " to) + (cond + [(archive-directory-exists? archive-file-path archive-inner-path) + (printf "D\n") + (make-directory* to) + (for ([p (in-list (archive-directory-list archive-file-path archive-inner-path))]) + (archive-extract-to archive-file-path + (build-path archive-inner-path p) + (build-path to p)))] + [else + (printf "F\n") + (unless (file-exists? to) + (with-output-to-file to + #:exists 'error + (λ () + (write-bytes (archive-extract-file archive-file-path archive-inner-path)))))])) + (provide/contract [create-archive (-> path-string? path-string? void)] + [archive-extract-to + (-> path-string? path-string? path-string? + void)] [archive-extract-file (-> path-string? path-string? bytes?)] diff --git a/collects/meta/drdr/dirstruct.rkt b/collects/meta/drdr/dirstruct.rkt index 8c827c9dda..7651c17da1 100644 --- a/collects/meta/drdr/dirstruct.rkt +++ b/collects/meta/drdr/dirstruct.rkt @@ -64,6 +64,8 @@ (build-path (revision-dir rev) "trunk")) (define (revision-trunk.tgz rev) (build-path (revision-dir rev) "trunk.tgz")) +(define (revision-trunk.tar.7z rev) + (build-path (revision-dir rev) "trunk.tar.7z")) (define (revision-commit-msg rev) (build-path (revision-dir rev) "commit-msg")) @@ -126,5 +128,6 @@ [revision-analyze-dir (exact-nonnegative-integer? . -> . path-string?)] [revision-trunk-dir (exact-nonnegative-integer? . -> . path?)] [revision-trunk.tgz (exact-nonnegative-integer? . -> . path?)] + [revision-trunk.tar.7z (exact-nonnegative-integer? . -> . path?)] [revision-archive (exact-nonnegative-integer? . -> . path?)] [path->revision (path-string? . -> . exact-nonnegative-integer?)]) diff --git a/collects/meta/drdr/main.rkt b/collects/meta/drdr/main.rkt index 1c3fba0eb6..c5e67b716e 100644 --- a/collects/meta/drdr/main.rkt +++ b/collects/meta/drdr/main.rkt @@ -22,13 +22,13 @@ [previous-rev prev-rev]) (notify! "Removing future record for r~a" cur-rev) (safely-delete-directory (future-record-path cur-rev)) - + (notify! "Starting to integrate revision r~a" cur-rev) (integrate-revision cur-rev) - - (notify! "Analyzing logs of r~a [prev: r~a]" cur-rev prev-rev) + + (notify! "Analyzing logs of r~a [prev: r~a]" cur-rev prev-rev) (analyze-revision cur-rev) - + (notify! "Recording timing data") (cache/file/timestamp (build-path rev-dir "timing-done") @@ -36,11 +36,21 @@ (system*/exit-code (path->string (build-path (plt-directory) "plt" "bin" "racket")) - "-t" + "-t" (path->string (build-path (drdr-directory) "time.rkt")) "--" "-r" (number->string cur-rev)))) - + + (notify! "Recompressing") + (cache/file/timestamp + (build-path rev-dir "recompressing") + (lambda () + (parameterize ([current-directory rev-dir]) + (system*/exit-code + "/bin/bash" + (path->string + (build-path (drdr-directory) "recompress.sh")))))) + (notify! "Archiving old revisions") (cache/file/timestamp (build-path rev-dir "archiving-done") @@ -48,7 +58,7 @@ (system*/exit-code (path->string (build-path (plt-directory) "plt" "bin" "racket")) - "-t" + "-t" (path->string (build-path (drdr-directory) "make-archive.rkt")) "--" @@ -61,11 +71,11 @@ cur-rev (lambda (newer) (for ([rev (in-list newer)]) - (write-cache! + (write-cache! (future-record-path rev) (get-scm-commit-msg rev (plt-repository))))) (lambda (prev-rev cur-rev) (handle-revision prev-rev cur-rev) - - ; We have problems running for a long time so just restart after each rev + + ;; We have problems running for a long time so just restart after each rev (exit 0))) diff --git a/collects/meta/drdr/make-archive-lib.rkt b/collects/meta/drdr/make-archive-lib.rkt new file mode 100644 index 0000000000..8cec1545c4 --- /dev/null +++ b/collects/meta/drdr/make-archive-lib.rkt @@ -0,0 +1,21 @@ +#lang racket +(require racket/system + "config.rkt" + "archive.rkt" + "path-utils.rkt" + "dirstruct.rkt") + +(define (make-archive rev) + (define archive-path (revision-archive rev)) + (if (file-exists? archive-path) + (printf "r~a is already archived\n" rev) + (local [(define tmp-path (make-temporary-file))] + (printf "Archiving r~a\n" rev) + (safely-delete-directory (revision-trunk.tgz rev)) + (safely-delete-directory (revision-trunk.tar.7z rev)) + (create-archive tmp-path (revision-dir rev)) + (rename-file-or-directory tmp-path archive-path) + (safely-delete-directory (revision-log-dir rev)) + (safely-delete-directory (revision-analyze-dir rev))))) + +(provide make-archive) diff --git a/collects/meta/drdr/make-archive.rkt b/collects/meta/drdr/make-archive.rkt index 5ccfad2b7d..b8ae8e8d84 100644 --- a/collects/meta/drdr/make-archive.rkt +++ b/collects/meta/drdr/make-archive.rkt @@ -3,28 +3,8 @@ "config.rkt" "archive.rkt" "path-utils.rkt" - "dirstruct.rkt") - -(define (archive-directory pth) - (define tmp (path-add-suffix pth #".bak")) - (system* (find-executable-path "tar") - "czf" - (path->string (path-add-suffix pth #".tgz")) - (path->string pth)) - (rename-file-or-directory pth tmp) - (safely-delete-directory tmp)) - -(define (make-archive rev) - (define archive-path (revision-archive rev)) - (if (file-exists? archive-path) - (printf "r~a is already archived\n" rev) - (local [(define tmp-path (make-temporary-file))] - (printf "Archiving r~a\n" rev) - (safely-delete-directory (revision-trunk.tgz rev)) - (create-archive tmp-path (revision-dir rev)) - (rename-file-or-directory tmp-path archive-path) - (safely-delete-directory (revision-log-dir rev)) - (safely-delete-directory (revision-analyze-dir rev))))) + "dirstruct.rkt" + "make-archive-lib.rkt") (define mode (make-parameter 'single)) diff --git a/collects/meta/drdr/plt-build.rkt b/collects/meta/drdr/plt-build.rkt index fa7e53336a..e31b5d0d44 100644 --- a/collects/meta/drdr/plt-build.rkt +++ b/collects/meta/drdr/plt-build.rkt @@ -72,7 +72,7 @@ #:timeout (current-make-install-timeout-seconds) #:env (current-env) (build-path log-dir "src" "build" "archive") - (tar-path) + (tar-path) (list "-czvf" (path->string (revision-trunk.tgz rev)) "-C" (path->string rev-dir) diff --git a/collects/meta/drdr/render.rkt b/collects/meta/drdr/render.rkt index 24db2d1fdf..370117b5ab 100644 --- a/collects/meta/drdr/render.rkt +++ b/collects/meta/drdr/render.rkt @@ -146,6 +146,15 @@ (current-rev))]) "trunk.tgz")))) `()) + ,@(if (file-exists? (revision-trunk.tar.7z (current-rev))) + `((tr ([class "date"]) + (td "Archive") + (td (a + ([href + ,(format "/builds/~a/trunk.tar.7z" + (current-rev))]) + "trunk.tar.7z")))) + `()) (tr ([class "hash"]) (td "Diff:") (td (a ([href ,(log->url gp)])