download-page.rkt (15914B)
1 #lang at-exp racket/base 2 (require racket/format 3 racket/path 4 racket/system 5 racket/list 6 racket/date 7 racket/file 8 net/url 9 openssl/sha1 10 scribble/html 11 (only-in plt-web site page call-with-registered-roots) 12 (only-in plt-web/style columns)) 13 14 (provide make-download-page 15 get-installers-table 16 (struct-out past-success)) 17 18 (module+ main 19 (require racket/cmdline) 20 21 (define args null) 22 (define (arg! kw val) 23 (set! args (cons (cons kw val) args))) 24 25 (define table-file 26 (command-line 27 #:once-each 28 [("--at") url "URL for installers relative to download page" 29 (arg! '#:installers-url url)] 30 [("--dest") file "Write to <dest>" 31 (arg! '#:dest file)] 32 [("--git") dir "Report information from git clone <dir>" 33 (arg! '#:git-clone dir)] 34 [("--plt") "Use PLT web page style" 35 (arg! '#:plt-web-style? #t)] 36 #:args 37 (table-file) 38 table-file)) 39 40 (let ([args (sort args keyword<? #:key car)]) 41 (keyword-apply make-download-page 42 (map car args) 43 (map cdr args) 44 (list table-file)))) 45 46 (define (get-installers-table table-file) 47 (define table (call-with-input-file table-file read)) 48 (unless (hash? table) 49 (raise-user-error 50 'make-download-page 51 (~a "given file does not contain a hash table\n" 52 " file: ~a") 53 table-file)) 54 table) 55 56 (struct past-success (name relative-url file) #:prefab) 57 58 (define (make-download-page table-file 59 #:past-successes [past-successes (hash)] 60 #:dest [dest "index.html"] 61 #:installers-url [installers-url "./"] 62 #:log-dir [log-dir #f] 63 #:log-dir-url [log-dir-url #f] 64 #:docs-url [docs-url #f] 65 #:pdf-docs-url [pdf-docs-url #f] 66 #:title [page-title "Racket Downloads"] 67 #:current-rx [current-rx #f] 68 #:git-clone [git-clone #f] 69 #:help-table [site-help (hash)] 70 #:post-content [post-content null] 71 #:plt-www-site [www-site #f] 72 #:plt-web-style? [plt-style? (and www-site #t)]) 73 74 (define base-table (get-installers-table table-file)) 75 76 (define table-data (for/fold ([table-data base-table]) ([(k v) (in-hash past-successes)]) 77 (if (hash-ref table-data k #f) 78 table-data 79 (hash-set table-data k v)))) 80 81 (define (system*/string . args) 82 (define s (open-output-string)) 83 (parameterize ([current-output-port s]) 84 (apply system* args)) 85 (get-output-string s)) 86 87 (define log-link 88 (and log-dir-url 89 (div (a class: "detail" href: log-dir-url "Build Logs")))) 90 91 (define sorted 92 (sort (hash-keys table-data) string<?)) 93 (define sorted-and-split 94 (map (lambda (s) 95 (map (lambda (e) 96 (regexp-replace* #rx" *{[^}]*} *" 97 e 98 "")) 99 (regexp-split #rx" *[|] *" s))) 100 sorted)) 101 102 (define elems 103 (let loop ([l sorted-and-split] 104 [keys sorted] 105 [prev null] 106 [started? #f]) 107 (define len (length prev)) 108 (define (add-sep l) 109 (if (and started? 110 (null? prev)) 111 (cons '(#f) l) 112 l)) 113 (cond 114 [(null? l) `((#f) (#f ,nbsp))] 115 [(not (equal? prev (take (car l) len))) 116 ;; move out a layer: 117 (loop l keys (drop-right prev 1) #t)] 118 [(= (add1 len) (length (car l))) 119 ;; a leaf entry: 120 (add-sep 121 (cons (cons (car keys) 122 (append (make-list len nbsp) 123 (list (list-ref (car l) len)))) 124 (loop (cdr l) (cdr keys) prev #t)))] 125 [else 126 ;; add a heder 127 (define section (list-ref (car l) len)) 128 (add-sep 129 (cons (cons #f 130 (append (make-list len nbsp) 131 (list section))) 132 (loop l keys (append prev (list section)) #t)))]))) 133 134 (define (xexpr->html p) 135 (cond 136 [(pair? p) 137 (define has-attr? (or (and (pair? (cadr p)) 138 (pair? (cadr p))) 139 (null? (cadr p)))) 140 (apply element (car p) (if has-attr? 141 (cadr p) 142 null) 143 (map xexpr->html (if has-attr? (cddr p) (cdr p))))] 144 [(string? p) p] 145 [(or (symbol? p) (number? p)) (entity p)] 146 [else (error "unknown xexpr")])) 147 148 (define (get-site-help last-col) 149 (let ([h (hash-ref site-help last-col #f)]) 150 (if h 151 (let* ([id (~a "help" (gensym))] 152 [toggle (let ([elem (~a "document.getElementById" "('" id "')")]) 153 (~a elem ".style.display = ((" elem ".style.display == 'inline') ? 'none' : 'inline');" 154 " return false;"))]) 155 (list 156 " " 157 (div class: "helpbutton" 158 (a href: "#" 159 class: "helpbuttonlabel" 160 onclick: toggle 161 title: "explain" 162 nbsp "?" nbsp)) 163 (div class: "hiddenhelp" 164 id: id 165 onclick: toggle 166 style: "display: none" 167 (div class: "helpcontent" 168 (div class: "helptext" 169 (xexpr->html h)))))) 170 null))) 171 172 (define page-site (and plt-style? 173 (site "download-page" 174 #:url "http://page.racket-lang.org/" 175 #:navigation (if docs-url 176 (list nbsp 177 nbsp 178 (a href: docs-url "Documentation") 179 (if pdf-docs-url 180 (a href: pdf-docs-url "PDF") 181 nbsp)) 182 null) 183 #:share-from (or www-site 184 (site "www" 185 #:url "https://racket-lang.org/" 186 #:generate? #f))))) 187 188 (define orig-directory (current-directory)) 189 190 (define page-headers 191 (style/inline @~a|{ 192 .detail { font-size: small; font-weight: normal; } 193 .checksum, .path { font-family: monospace; } 194 .group { background-color : #ccccff; padding-left: 0.5ex; } 195 .major { font-weight : bold; font-size : large; left-border: 1ex; } 196 .minor { font-weight : bold; } 197 .download-table { border: 0px solid white; } 198 .download-table td { display: table-cell; padding: 0px 2px 0px 2px; border: 0px solid white; } 199 .helpbutton { 200 display: inline; 201 font-family: sans-serif; 202 font-size : x-small; 203 background-color: #ffffee; 204 border: 1px solid black; 205 vertical-align: top; 206 } 207 .helpbuttonlabel{ vertical-align: top; } 208 .hiddenhelp { 209 width: 0em; 210 position: absolute; 211 } 212 .helpcontent { 213 width: 20em; 214 font-size : small; 215 font-weight : normal; 216 background-color: #ffffee; 217 padding: 10px; 218 border: 1px solid black; 219 } 220 a { text-decoration: none; } 221 }|)) 222 223 (define (strip-detail s) 224 (if (string? s) 225 (regexp-replace #rx";.*" s "") 226 s)) 227 228 (define (add-detail s e) 229 (define m (and (string? s) 230 (regexp-match #rx"(?<=; )(.*)$" s))) 231 (cond 232 [m 233 (span e (span class: "detail" 234 nbsp 235 (cadr m)))] 236 [else e])) 237 238 (define page-body 239 (list 240 (if page-title 241 ((if plt-style? h3 h2) page-title) 242 null) 243 (table 244 class: "download-table" 245 (for/list ([elem (in-list elems)]) 246 (define key (car elem)) 247 (define inst (and key (hash-ref table-data key))) 248 (define mid-cols (if (null? (cdr elem)) 249 #f 250 (drop-right (cdr elem) 1))) 251 (define last-col (last elem)) 252 (define level-class 253 (case (length elem) 254 [(2) (~a "major" (if key "" " group"))] 255 [(3) "minor"] 256 [else "subminor"])) 257 (define num-cols (if current-rx 258 "7" 259 "5")) 260 (cond 261 [(not mid-cols) 262 (tr (td colspan: num-cols nbsp))] 263 [inst 264 (tr (td 265 (for/list ([col (in-list mid-cols)]) 266 (span nbsp nbsp nbsp)) 267 (add-detail 268 last-col 269 (if (past-success? inst) 270 ;; Show missing installer 271 (span class: (string-append "no-installer " level-class) 272 (strip-detail last-col)) 273 ;; Link to installer 274 (a class: (string-append "installer " level-class) 275 href: (url->string 276 (combine-url/relative 277 (string->url installers-url) 278 inst)) 279 (strip-detail last-col)))) 280 (get-site-help last-col)) 281 (td nbsp) 282 (td (if (past-success? inst) 283 (span class: "detail" "") 284 (span class: "detail" 285 (~r (/ (file-size (build-path (path-only table-file) 286 inst)) 287 (* 1024 1024)) 288 #:precision 1) 289 " MB"))) 290 (td nbsp) 291 (td (if (past-success? inst) 292 (span class: "detail" 293 (if (and log-dir 294 (file-exists? (build-path log-dir key))) 295 (list 296 (a href: (url->string 297 (combine-url/relative 298 (string->url log-dir-url) 299 key)) 300 "build failed") 301 "; ") 302 null) 303 "last success: " 304 (a href: (~a (past-success-relative-url inst)) 305 (past-success-name inst))) 306 (span class: "detail" 307 "SHA1: " 308 (span class: "checksum" 309 (call-with-input-file* 310 (build-path (path-only table-file) 311 inst) 312 sha1))))) 313 (if current-rx 314 (list 315 (td nbsp) 316 (td (span class: "detail" 317 (let ([inst-path (if (past-success? inst) 318 (past-success-file inst) 319 inst)]) 320 (if (regexp-match? current-rx inst-path) 321 (a href: (url->string 322 (combine-url/relative 323 (string->url installers-url) 324 (bytes->string/utf-8 325 (regexp-replace current-rx 326 (string->bytes/utf-8 inst-path) 327 #"current")))) 328 "as " ldquo "current" rdquo) 329 nbsp))))) 330 null))] 331 [else 332 (tr (td class: level-class 333 colspan: num-cols 334 (for/list ([col (in-list mid-cols)]) 335 (span nbsp nbsp nbsp)) 336 (add-detail 337 last-col 338 (strip-detail last-col)) 339 (get-site-help last-col)))]))) 340 (if (and docs-url 341 (not site)) 342 (p (a href: docs-url "Documentation") 343 (if pdf-docs-url 344 (list 345 nbsp 346 nbsp 347 (span class: "detail" 348 (a href: pdf-docs-url "[also available as PDF]"))) 349 null)) 350 null) 351 (if git-clone 352 (let ([git (find-executable-path "git")]) 353 (define origin (let ([s (system*/string git "remote" "show" "origin")]) 354 (define m (regexp-match #rx"(?m:Fetch URL: (.*)$)" s)) 355 (if m 356 (cadr m) 357 "???"))) 358 (define stamp (system*/string git "log" "-1" "--format=%H")) 359 (p 360 (div (span class: "detail" "Repository: " (span class: "path" origin))) 361 (div (span class: "detail" "Commit: " (span class: "checksum" stamp))) 362 (or log-link null))) 363 null) 364 (if (and log-link (not git-clone)) 365 (p log-link) 366 null) 367 post-content)) 368 369 (define-values (dest-dir dest-file dest-is-dir?) (split-path dest)) 370 371 (define page-content 372 (if page-site 373 (page #:site page-site 374 #:file (path-element->string dest-file) 375 #:title page-title 376 #:extra-headers page-headers 377 (columns 12 #:row? #t 378 page-body)) 379 (html (head (title page-title) 380 page-headers) 381 (body page-body)))) 382 383 (call-with-registered-roots 384 (lambda () 385 (cond 386 [page-site 387 ;; Render to "download-page", then move up: 388 (define base-dir (if (path? dest-dir) 389 dest-dir 390 (current-directory))) 391 (parameterize ([current-directory base-dir]) 392 (render-all)) 393 (define dp-dir (build-path base-dir "download-page")) 394 (for ([f (in-list (directory-list dp-dir))]) 395 (define f-dest (build-path base-dir f)) 396 (delete-directory/files f-dest #:must-exist? #f) 397 (rename-file-or-directory (build-path dp-dir f) f-dest)) 398 (delete-directory dp-dir)] 399 [else 400 (call-with-output-file* 401 dest 402 #:exists 'truncate/replace 403 (lambda (o) 404 (output-xml page-content o)))]))))