From 771e9300ca10ac14d75808665f3973a3deaaaf76 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 2 Jul 2013 09:28:39 -0600
Subject: [PATCH] Change "farm" terminology to "site", mostly

original commit: 2e657af9b6473cb2aef4b4e8e40135b90c720dea
---
 pkgs/distro-build/assemble-site.rkt        |  64 ++++++++++++
 pkgs/distro-build/{farm.rkt => config.rkt} | 112 ++++++++++-----------
 pkgs/distro-build/download-page.rkt        |  99 ++++++++++++++++++
 pkgs/distro-build/drive-clients.rkt        |  22 ++--
 pkgs/distro-build/install-pkgs.rkt         |   2 +-
 pkgs/distro-build/set-config.rkt           |   2 +-
 pkgs/distro-build/url-options.rkt          |   2 +-
 7 files changed, 233 insertions(+), 70 deletions(-)
 create mode 100644 pkgs/distro-build/assemble-site.rkt
 rename pkgs/distro-build/{farm.rkt => config.rkt} (83%)
 create mode 100644 pkgs/distro-build/download-page.rkt

diff --git a/pkgs/distro-build/assemble-site.rkt b/pkgs/distro-build/assemble-site.rkt
new file mode 100644
index 0000000..334b2e7
--- /dev/null
+++ b/pkgs/distro-build/assemble-site.rkt
@@ -0,0 +1,64 @@
+#lang racket/base
+(require racket/cmdline
+         racket/file
+         net/url
+         "download-page.rkt"
+         (only-in "site.rkt" extract-options))
+
+(define build-dir (build-path "build"))
+(define dest-dir (build-path build-dir "site"))
+
+(define built-dir (build-path build-dir "built"))
+
+(define installers-dir (build-path "installers"))
+(define pkgs-dir (build-path "pkgs"))
+(define catalog-dir (build-path "catalog"))
+
+(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 (copy dir [build-dir build-dir])
+  (make-directory* dest-dir)
+  (printf "Copying ~s\n" (build-path build-dir dir))
+  (copy-directory/files (build-path build-dir dir)
+                        (build-path dest-dir dir)
+                        #:keep-modify-seconds? #t))
+
+(delete-directory/files dest-dir #:must-exist? #f)
+(copy pkgs-dir built-dir)
+
+(printf "Building catalog\n")
+(let ([c-dir (build-path built-dir catalog-dir "pkg")]
+      [d-dir (build-path dest-dir catalog-dir "pkg")])
+  (make-directory* d-dir)
+  (define base-url (string->url (hash-ref config '#:dist-base-url)))
+  (for ([f (in-list (directory-list c-dir))])
+    (define ht (call-with-input-file* (build-path c-dir f) read))
+    (define new-ht
+      (hash-set ht 'source (url->string
+                            (combine-url/relative
+                             base-url
+                             (path->string 
+                              (build-path
+                               "pkgs"
+                               (path-add-suffix f #".zip")))))))
+    (call-with-output-file* 
+     (build-path d-dir f)
+     (lambda (o)
+       (write new-ht o)
+       (newline o)))))
+
+(copy installers-dir)
+
+(make-download-page (build-path build-dir
+                                installers-dir
+                                "table.rktd")
+                    #:installers-url "installers/"
+                    #:dest (build-path dest-dir
+                                       "index.html")
+                    #:git-clone (current-directory))
diff --git a/pkgs/distro-build/farm.rkt b/pkgs/distro-build/config.rkt
similarity index 83%
rename from pkgs/distro-build/farm.rkt
rename to pkgs/distro-build/config.rkt
index dbd40ca..9f4a9bb 100644
--- a/pkgs/distro-build/farm.rkt
+++ b/pkgs/distro-build/config.rkt
@@ -1,15 +1,15 @@
 #lang racket/base
 
-;; A build farm is normally run via the `farm' target of the Racket
-;; repository's top-level makefile. That target, in turn, uses the
-;; `distro-build/drive-clients' module.
+;; A build farm is normally run via the `installers' target of the
+;; Racket repository's top-level makefile. That target, in turn, uses
+;; the `distro-build/drive-clients' module.
 ;;
 ;; The server machine first prepares packages for installation on
-;; clients.  The farm configuration's top-level entry is consulted for
+;; clients.  The site configuration's top-level entry is consulted for
 ;; a `#:pkgs' and/or `#:doc-search' option, which overrides any `PKGS'
 ;; and/or `DOC_SEARCH' configuration from the makefile.
 ;;
-;; The farm configuration file otherwise describes and configures
+;; The site configuration file otherwise describes and configures
 ;; client machines.  Each client is built by running commands via
 ;; `ssh', where the client's host (and optional port and/or user)
 ;; indicate the ssh target. Each client machine must be set up with a
@@ -52,11 +52,11 @@
 ;;      or  C:\Program Files (x86)\NSIS\makensis.exe
 ;;     or instaled so that `makensis' in in yur PATH.
 ;;
-;; Farm Configuration
+;; Site Configuration
 ;; -------------------
 ;;
-;; A farm configuration module is normally wriiten in the
-;; `distro-build/farm' language. The configuration describes
+;; A site configuration module is normally wriiten in the
+;; `distro-build/config' language. The configuration describes
 ;; individual machines, and groups them with `parallel' or
 ;; `sequential' to indicate whether the machine's builds should run
 ;; sequentially or in parallel.  Options specified at `parallel' or
@@ -64,7 +64,7 @@
 ;;
 ;; For example, a configuration module might look like this:
 ;;
-;;     #lang distro-build/farm
+;;     #lang distro-build/config
 ;;    
 ;;     (sequential
 ;;      #:pkgs '("drracket")
@@ -85,7 +85,7 @@
 ;;       #:bits 64))
 ;;
 ;;
-;; Farm-configuration keywords (where <string*> means no spaces, etc.):
+;; Site-configuration keywords (where <string*> means no spaces, etc.):
 ;;
 ;;   #:host <string*> --- defaults to "localhost"
 ;;   #:port <integer> --- ssh port for the client; defaults to 22
@@ -168,40 +168,40 @@
 ;;                       generated table of installer links, for example)
 ;;
 ;;
-;; More precisely, the `distro-build/farm' language is like
+;; More precisely, the `distro-build/config' language is like
 ;; `racket/base' except that the module body must have exactly one
 ;; expression (plus any number of definitions, etc.) that produces a
-;; farm-configuration value. The value is exported as `farm-config'
-;; from the module. Any module can act as a farm-configuration module
-;; a long as it exports `farm-config' as a farm-configuration value.
+;; site-configuration value. The value is exported as `site-config'
+;; from the module. Any module can act as a site-configuration module
+;; a long as it exports `site-config' as a site-configuration value.
 ;;
-;; The `distro-build/farm' language also adds the following functions
+;; The `distro-build/config' language also adds the following functions
 ;; to `racket/base':
 ;;
-;;  (machine <opt-kw> <opt-val> ... ...) -> farm-config?
-;;    Produces a farm configuration based on the given keyword-based
+;;  (machine <opt-kw> <opt-val> ... ...) -> site-config?
+;;    Produces a site configuration based on the given keyword-based
 ;;    options. The support keyword arguments are described above.
 ;;
 ;;  (sequential <opt-kw> <opt-val> ... ... config ...)
-;;    -> farm-config?
-;;     config : farm-config?
-;;    Produces a farm configuration that runs each `config'
+;;    -> site-config?
+;;     config : site-config?
+;;    Produces a site configuration that runs each `config'
 ;;    sequentially. The support keyword arguments are described above.
 ;;
 ;;  (parallel <opt-kw> <opt-val> ... ... config ...)
-;;    -> farm-config?
-;;     config : farm-config?
-;;    Produces a farm configuration that runs each `config' in
+;;    -> site-config?
+;;     config : site-config?
+;;    Produces a site configuration that runs each `config' in
 ;;    parallel. The support keyword arguments are described above.
 ;;
-;;  (farm-config? v) -> boolean?
-;;  (farm-config-tag config) -> (or/c 'machine 'sequential 'parallel)
-;;     config : farm-config?
-;;  (farm-config-options config) -> (hash/c keyword? any/c)
-;;     config : farm-config?
-;;  (farm-config-content config) -> (listof farm-config?)
-;;     config : farm-config?
-;;   Farm configuation inspection
+;;  (site-config? v) -> boolean?
+;;  (site-config-tag config) -> (or/c 'machine 'sequential 'parallel)
+;;     config : site-config?
+;;  (site-config-options config) -> (hash/c keyword? any/c)
+;;     config : site-config?
+;;  (site-config-content config) -> (listof site-config?)
+;;     config : site-config?
+;;   Site configuation inspection
 ;;
 ;;  (current-mode) -> string?
 ;;  (current-mode s) -> void?
@@ -210,7 +210,7 @@
 ;;   configuration, normally as provided via the makefile's
 ;;   `CONFIG_MODE' variable. The default mode is "default". The
 ;;   interpretation of modes is completely up to the
-;;   farm configuration file.
+;;   site configuration file.
 
 ;; ----------------------------------------
 
@@ -224,32 +224,32 @@
          sequential
          parallel
          machine
-         farm-config?
-         farm-config-tag
-         farm-config-options
-         farm-config-content
+         site-config?
+         site-config-tag
+         site-config-options
+         site-config-content
          current-mode
          extract-options)
 
 (module reader syntax/module-reader
-  distro-build/farm)
+  distro-build/site)
 
-(struct farm-config (tag options content))
+(struct site-config (tag options content))
 
 (define-syntax-rule (module-begin form ...)
-  (#%plain-module-begin (farm-begin #f form ...)))
+  (#%plain-module-begin (site-begin #f form ...)))
 
-(define-syntax (farm-begin stx)
+(define-syntax (site-begin stx)
   (syntax-case stx ()
     [(_ #t) #'(begin)]
     [(_ #f)
-     (raise-syntax-error 'farm
-                         "did not find an expression for the farm configuration")]
+     (raise-syntax-error 'site
+                         "did not find an expression for the site configuration")]
     [(_ found? next . rest) 
      (let ([expanded (local-expand #'next 'module (kernel-form-identifier-list))])
        (syntax-case expanded (begin)
          [(begin next1 ...)
-          #`(farm-begin found? next1 ... . rest)]
+          #`(site-begin found? next1 ... . rest)]
          [(id . _)
           (and (identifier? #'id)
                (ormap (lambda (kw) (free-identifier=? #'id kw))
@@ -262,24 +262,24 @@
                                        module*
                                        #%require
                                        #%provide))))
-          #`(begin #,expanded (farm-begin found? . rest))]
+          #`(begin #,expanded (site-begin found? . rest))]
          [_else
           (if (syntax-e #'found?)
-              (raise-syntax-error 'farm
+              (raise-syntax-error 'site
                                   "found second top-level expression"
                                   #'next)
               #`(begin
-                 (provide farm-config)
-                 (define farm-config (let ([v #,expanded])
-                                       (unless (farm-config? v)
-                                         (error 'farm
-                                                (~a "expression did not produce a farm configuration\n"
+                 (provide site-config)
+                 (define site-config (let ([v #,expanded])
+                                       (unless (site-config? v)
+                                         (error 'site
+                                                (~a "expression did not produce a site configuration\n"
                                                     "  result: ~e\n"
                                                     "  expression: ~.s")
                                                 v
                                                 'next))
                                        v))
-                 (farm-begin
+                 (site-begin
                   #t
                   . rest)))]))]))
 
@@ -300,7 +300,7 @@
                   check-machine-keyword 'machine))))
 
 (define (constructor kws kw-vals subs check tag)
-  (farm-config
+  (site-config
    tag
    (for/hash ([kw (in-list kws)]
               [val (in-list kw-vals)])
@@ -319,8 +319,8 @@
               val))
      (values kw val))
    (for/list ([sub subs])
-     (unless (farm-config? sub)
-       (raise-argument-error tag "farm-config?" sub))
+     (unless (site-config? sub)
+       (raise-argument-error tag "site-config?" sub))
      sub)))
 
 (define (check-group-keyword kw val)
@@ -368,7 +368,7 @@
   (or
    (and (file-exists? config-file)
         (parameterize ([current-mode config-mode])
-          (farm-config-options 
-           (dynamic-require (path->complete-path config-file) 'farm-config))))
+          (site-config-options 
+           (dynamic-require (path->complete-path config-file) 'site-config))))
    (hash)))
 
diff --git a/pkgs/distro-build/download-page.rkt b/pkgs/distro-build/download-page.rkt
new file mode 100644
index 0000000..7078750
--- /dev/null
+++ b/pkgs/distro-build/download-page.rkt
@@ -0,0 +1,99 @@
+#lang racket/base
+(require racket/format
+         racket/path
+         racket/system
+         net/url
+         openssl/sha1
+         xml)
+
+(provide make-download-page)
+
+(module+ main
+  (require racket/cmdline)
+
+  (define args null)
+  (define (arg! kw val)
+    (set! args (cons (cons kw val) args)))
+  
+  (define table-file
+    (command-line
+     #:once-each
+     [("--at") url "URL for installaters reletaive to download page"
+      (arg! '#:installers-url url)]
+     [("--dest") file "Write to <dest>"
+      (arg! '#:dest file)]
+     [("--git") dir "Report information from git clone <dir>"
+      (arg! '#:git-clone dir)]
+     #:args
+     (table-file)
+     table-file))
+
+  (let ([args (sort args keyword<? #:key car)])
+    (keyword-apply make-download-page
+                   (map car args)
+                   (map cdr args)
+                   table-file)))
+
+(define (make-download-page table-file
+                            #:dest [dest "index.html"]
+                            #:installers-url [installers-url "./"]
+                            #:title [title "Racket Downloads"]
+                            #:git-clone [git-clone #f])
+
+  (define table (call-with-input-file table-file read))
+
+  (unless (hash? table) 
+    (raise-user-error
+     'make-download-page
+     (~a "given file does not contain a hash table\n"
+         "  file: ~a")
+     table-file))
+
+  (define (system*/string . args)
+    (define s (open-output-string))
+    (parameterize ([current-output-port s])
+      (apply system* args))
+    (get-output-string s))
+
+  (call-with-output-file* 
+   dest
+   #:exists 'truncate/replace
+   (lambda (o)
+     (parameterize ([empty-tag-shorthand html-empty-tags])
+       (write-xexpr
+        `(html
+          (head (title ,title)
+                (style ,(~a " .detail { font-size: small; }"
+                            " .checksum, .path { font-family: monospace }")))
+          (body
+           (h2 ,title)
+           (table
+            ,@(for/list ([key (in-list (sort (hash-keys table) string<?))])
+                (define inst (hash-ref table key))
+                `(tr (td (a ((href ,(url->string
+                                     (combine-url/relative
+                                      (string->url installers-url)
+                                      inst))))
+                            ,key))
+                     (td nbsp)
+                     (td (span ([class "detail"])
+                               "SHA1: "
+                               (span ([class "checksum"])
+                                     ,(call-with-input-file*
+                                       (build-path (path-only table-file)
+                                                   inst)
+                                       sha1)))))))
+           ,@(if git-clone
+                 (let ([git (find-executable-path "git")])
+                   (define origin (let ([s (system*/string git "remote" "show" "origin")])
+                                    (define m (regexp-match #rx"(?m:Fetch URL: (.*)$)" s))
+                                    (if m
+                                        (cadr m)
+                                        "???")))
+                   (define stamp (system*/string git "log" "-1" "--format=%H"))
+                   `((p
+                      (div (span ([class "detail"]) "Repository: " (span ([class "path"]) ,origin)))
+                      (div (span ([class "detail"]) "Commit: " (span ([class "checksum"]) ,stamp))))))
+                 null)))
+        o)
+       (void)))))
diff --git a/pkgs/distro-build/drive-clients.rkt b/pkgs/distro-build/drive-clients.rkt
index ae6b1fc..c651e9e 100644
--- a/pkgs/distro-build/drive-clients.rkt
+++ b/pkgs/distro-build/drive-clients.rkt
@@ -5,13 +5,13 @@
          racket/format
          racket/file
          racket/string
-         (only-in "farm.rkt"
+         (only-in "config.rkt"
                   current-mode
-                  farm-config?
-                  farm-config-tag farm-config-options farm-config-content)
+                  site-config?
+                  site-config-tag site-config-options site-config-content)
          "url-options.rkt")
 
-;; See "farm.rkt" for an overview.
+;; See "config.rkt" for an overview.
 
 ;; ----------------------------------------
 
@@ -35,24 +35,24 @@
            dist-name dist-base dist-dir)))
 
 (define config (parameterize ([current-mode config-mode])
-                 (dynamic-require (path->complete-path config-file) 'farm-config)))
+                 (dynamic-require (path->complete-path config-file) 'site-config)))
 
-(unless (farm-config? config)
+(unless (site-config? config)
   (error 'drive-clients 
-         "configuration module did not provide a farm-configuration value: ~e"
+         "configuration module did not provide a site-configuration value: ~e"
          config))
 
 ;; ----------------------------------------
 
 (define (merge-options opts c)
-  (for/fold ([opts opts]) ([(k v) (in-hash (farm-config-options c))])
+  (for/fold ([opts opts]) ([(k v) (in-hash (site-config-options c))])
     (hash-set opts k v)))
 
 (define (get-opt opts kw [default #f])
   (hash-ref opts kw default))
 
 (define (get-content c)
-  (farm-config-content c))
+  (site-config-content c))
 
 (define (client-name opts)
   (or (get-opt opts '#:name)
@@ -333,12 +333,12 @@
             [mode 'sequential]
             [opts (hasheq)])
    (unless stop?
-     (case (farm-config-tag config)
+     (case (site-config-tag config)
        [(parallel sequential)
         (define new-opts (merge-options opts config))
         (define ts
           (map (lambda (c) (loop c
-                                 (farm-config-tag config)
+                                 (site-config-tag config)
                                  new-opts))
                (get-content config)))
         (define (wait)
diff --git a/pkgs/distro-build/install-pkgs.rkt b/pkgs/distro-build/install-pkgs.rkt
index f6446e9..ded1582 100644
--- a/pkgs/distro-build/install-pkgs.rkt
+++ b/pkgs/distro-build/install-pkgs.rkt
@@ -1,7 +1,7 @@
 #lang racket/base
 (require racket/cmdline
          racket/string
-         (only-in "farm.rkt" extract-options))
+         (only-in "site.rkt" extract-options))
 
 (define-values (config-file config-mode default-pkgs flags)
   (command-line
diff --git a/pkgs/distro-build/set-config.rkt b/pkgs/distro-build/set-config.rkt
index dacf67b..4ae3c07 100644
--- a/pkgs/distro-build/set-config.rkt
+++ b/pkgs/distro-build/set-config.rkt
@@ -2,7 +2,7 @@
 (require racket/cmdline
          racket/file
          racket/path
-         (only-in "farm.rkt" extract-options)
+         (only-in "config.rkt" extract-options)
          "url-options.rkt")
 
 (define-values (dest-config-file config-file config-mode default-doc-search default-catalogs)
diff --git a/pkgs/distro-build/url-options.rkt b/pkgs/distro-build/url-options.rkt
index a751541..3ccece2 100644
--- a/pkgs/distro-build/url-options.rkt
+++ b/pkgs/distro-build/url-options.rkt
@@ -17,6 +17,6 @@
       (let ([v (hash-ref config '#:dist-base-url #f)])
         (and v
              (list (url->string
-                    (combine-url/relative (string->url v) "catalog"))
+                    (combine-url/relative (string->url v) "catalog/"))
                    "")))
       default-catalogs))