add distro-builds/manage-snapshots

original commit: 41399c1f514b26557d68babf7313460371f038c8

pkgs/distro-build/config.rkt

@@ -164,8 +164,11 @@
 ;;                         machine starts by a `git pull' in <dir>; set
 ;;                         to #f, for example, for a repo checkout that is
 ;;                         shared with server; the default is #t
-;;   #:site-dest <path-string> --- destination for completed build; the default
-;;                                 is "build/site"
+;;   #:site-dest <path-string> --- destination for completed build, used
+;;                                 by the `site' makefile target; the
+;;                                 default is "build/site"
+;;   #:max-snapshots <number> --- number of snapshots to keep, used by
+;;                                the `snapshot-site' makefile target
 ;;
 ;; Machine-only keywords:
 ;;
@@ -217,6 +220,10 @@
 ;;   `CONFIG_MODE' variable. The default mode is "default". The
 ;;   interpretation of modes is completely up to the
 ;;   site configuration file.
+;;
+;;  (current-stamp) -> string?
+;;   Returns a string to identifiy the current build, normally a
+;;   combination of the date and a git commit hash.
 
 ;; ----------------------------------------
 
@@ -357,6 +364,7 @@
     [(#:clean?) (boolean? val)]
     [(#:pull?) (boolean? val)]
     [(#:site-dest) (path-string? val)]
+    [(#:max-snapshots) (real? val)]
     [else 'bad-keyword]))
 
 (define (check-machine-keyword kw val)

pkgs/distro-build/download-page.rkt

@@ -38,7 +38,8 @@
                             #:dest [dest "index.html"]
                             #:installers-url [installers-url "./"]
                             #:title [title "Racket Downloads"]
-                            #:git-clone [git-clone #f])
+                            #:git-clone [git-clone #f]
+                            #:post-content [post-content null])
 
   (define table (call-with-input-file table-file read))
 
@@ -94,6 +95,7 @@
                    `((p
                       (div (span ([class "detail"]) "Repository: " (span ([class "path"]) ,origin)))
                       (div (span ([class "detail"]) "Commit: " (span ([class "checksum"]) ,stamp))))))
-                 null)))
+                 null)
+           ,@post-content))
         o)
        (void)))))

pkgs/distro-build/manage-snapshots.rkt

@@ -0,0 +1,52 @@
+#lang racket/base
+(require racket/cmdline
+         racket/file
+         net/url
+         "download-page.rkt"
+         (only-in "config.rkt" extract-options))
+
+(define build-dir (build-path "build"))
+(define installers-dir (build-path "installers"))
+
+(define-values (config-file config-mode)
+  (command-line
+   #:args
+   (config-file config-mode)
+   (values config-file config-mode)))
+
+(define config (extract-options config-file config-mode))
+
+(define site-dir (hash-ref config
+                           '#:site-dest
+                           (build-path build-dir "site")))
+
+(define current-snapshot
+  (let-values ([(base name dir?) (split-path site-dir)])
+    (path-element->string name)))
+
+(define snapshots-dir (build-path site-dir 'up))
+
+(define snapshots (for/list ([p (in-list (directory-list snapshots-dir))]
+                             #:when (directory-exists? (build-path snapshots-dir p)))
+                    (path-element->string p)))
+
+(define n (hash-ref config '#:max-snapshots 5))
+(when (n . < . (length snapshots))
+  (define remove-snapshots (remove
+                            current-snapshot
+                            (list-tail (sort snapshots string>?) n)))
+  (for ([s (in-list remove-snapshots)])
+    (printf "Removing snapshot ~a\n" s)
+    (delete-directory/files (build-path snapshots-dir s))))
+
+(make-download-page (build-path site-dir
+                                installers-dir
+                                "table.rktd")
+                    #:installers-url (string-append current-snapshot "/installers/")
+                    #:dest (build-path snapshots-dir
+                                       "index.html")
+                    #:git-clone (current-directory)
+                    #:post-content `((p "Snapshot ID: " 
+                                        (a ((href ,(string-append current-snapshot
+                                                                  "/index.html")))
+                                           ,current-snapshot))))