manage-snapshots.rkt (6155B)
1 #lang racket/base 2 (require racket/cmdline 3 racket/file 4 net/url 5 scribble/html 6 "download-page.rkt" 7 (only-in distro-build/config extract-options)) 8 9 (module test racket/base) 10 11 (define build-dir (build-path "build")) 12 (define installers-dir (build-path "installers")) 13 14 (define-values (config-file config-mode) 15 (command-line 16 #:args 17 (config-file config-mode) 18 (values config-file config-mode))) 19 20 (define config (extract-options config-file config-mode)) 21 22 (define site-dir (hash-ref config 23 '#:site-dest 24 (build-path build-dir "site"))) 25 26 (define site-title (hash-ref config 27 '#:site-title 28 "Racket Downloads")) 29 30 (define current-snapshot 31 (let-values ([(base name dir?) (split-path site-dir)]) 32 (path-element->string name))) 33 34 (define snapshots-dir (build-path site-dir 'up)) 35 36 (define link-file (build-path snapshots-dir "current")) 37 38 (when (link-exists? link-file) 39 (printf "Removing old \"current\" link\n") 40 (flush-output) 41 (delete-file link-file)) 42 43 (define (get-snapshots) 44 (for/list ([p (in-list (directory-list snapshots-dir))] 45 #:when (directory-exists? (build-path snapshots-dir p))) 46 (path-element->string p))) 47 48 (define n (hash-ref config '#:max-snapshots 5)) 49 50 (let ([snapshots (get-snapshots)]) 51 (when (n . < . (length snapshots)) 52 (define remove-snapshots (remove 53 current-snapshot 54 (list-tail (sort snapshots string>?) n))) 55 (for ([s (in-list remove-snapshots)]) 56 (printf "Removing snapshot ~a\n" s) 57 (flush-output) 58 (delete-directory/files (build-path snapshots-dir s))))) 59 60 (printf "Loading past successes\n") 61 (define table-file (build-path site-dir installers-dir "table.rktd")) 62 (define past-successes 63 (let ([current-table (get-installers-table table-file)]) 64 (for/fold ([table (hash)]) ([s (in-list (reverse (remove current-snapshot (get-snapshots))))]) 65 (with-handlers ([exn:fail? (lambda (exn) 66 (log-error "failure getting installer table: ~a" 67 (exn-message exn)) 68 table)]) 69 (define past-table (get-installers-table 70 (build-path snapshots-dir s installers-dir "table.rktd"))) 71 (for/fold ([table table]) ([(k v) (in-hash past-table)]) 72 (if (or (hash-ref current-table k #f) 73 (hash-ref table k #f) 74 (not (file-exists? (build-path site-dir "log" k)))) 75 table 76 (hash-set table k (past-success s 77 (string-append s "/index.html") 78 v)))))))) 79 80 (define current-rx (regexp (regexp-quote (version)))) 81 82 (printf "Creating \"current\" links\n") 83 (flush-output) 84 (make-file-or-directory-link current-snapshot link-file) 85 (let ([installer-dir (build-path snapshots-dir current-snapshot "installers")]) 86 (define (currentize f) 87 (regexp-replace current-rx 88 (path->bytes f) 89 "current")) 90 (define (make-link f to-file) 91 (define file-link (build-path 92 installer-dir 93 (bytes->path (currentize f)))) 94 (when (link-exists? file-link) 95 (delete-file file-link)) 96 (make-file-or-directory-link to-file file-link)) 97 ;; Link current successes: 98 (for ([f (in-list (directory-list installer-dir))]) 99 (when (regexp-match? current-rx f) 100 (make-link f f))) 101 ;; Link past successes: 102 (for ([v (in-hash-values past-successes)]) 103 (when (regexp-match? current-rx (past-success-file v)) 104 (make-link (string->path (past-success-file v)) 105 (build-path 'up 'up 106 (past-success-name v) installers-dir 107 (past-success-file v)))))) 108 109 110 (printf "Generating web page\n") 111 (make-download-page table-file 112 #:title site-title 113 #:plt-web-style? (hash-ref config '#:plt-web-style? #t) 114 #:past-successes past-successes 115 #:installers-url "current/installers/" 116 #:log-dir (build-path site-dir "log") 117 #:log-dir-url "current/log/" 118 #:docs-url (and (directory-exists? (build-path site-dir "doc")) 119 "current/doc/index.html") 120 #:pdf-docs-url (and (directory-exists? (build-path site-dir "pdf-doc")) 121 "current/pdf-doc/") 122 #:dest (build-path snapshots-dir 123 "index.html") 124 #:current-rx current-rx 125 #:git-clone (current-directory) 126 #:help-table (hash-ref config '#:site-help (hash)) 127 #:post-content (list 128 (p "Snapshot ID: " 129 (a href: (string-append current-snapshot 130 "/index.html") 131 current-snapshot)) 132 (let ([snapshots (get-snapshots)]) 133 (if ((length snapshots) . < . 2) 134 null 135 (div class: "detail" 136 "Other available snapshots:" 137 (for/list ([s (remove "current" 138 (remove current-snapshot 139 (sort snapshots string>?)))]) 140 (span class: "detail" 141 nbsp 142 (a href: (string-append s "/index.html") 143 s))))))))