suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

New archives, smaller

Browse Source
This commit is contained in:
Jay McCarthy 2012-05-15 21:49:22 -06:00
parent 14edb40d94
commit 7148cdf7f0
9 changed files with 162 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/meta/drdr/archive-repair.rkt Normal file
View File

@ -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))

8
collects/meta/drdr/archive-repair.sh Executable file
View File

@ -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

141
collects/meta/drdr/archive.rkt
View File

@ -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?)]

3
collects/meta/drdr/dirstruct.rkt
View File

@ -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?)])

30
collects/meta/drdr/main.rkt
View File

@ -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)))

21
collects/meta/drdr/make-archive-lib.rkt Normal file
View File

@ -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)

24
collects/meta/drdr/make-archive.rkt
View File

@ -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))

2
collects/meta/drdr/plt-build.rkt
View File

@ -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)

9
collects/meta/drdr/render.rkt
View File

@ -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)])