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

make snapshot-site: add "current" links for installers

Browse Source 
original commit: e4f4324fa9e17f8d2590d250dd9da4fcecf9a8cd
This commit is contained in:
Matthew Flatt 2013-10-19 07:35:34 -06:00
parent 6b69a14904
commit d19e124bd3
2 changed files with 37 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
pkgs/distro-build/download-page.rkt
View File

@ -41,6 +41,7 @@
#:docs-url [docs-url #f]
#:pdf-docs-url [pdf-docs-url #f]
#:title [title "Racket Downloads"]
#:current-rx [current-rx #f]
#:git-clone [git-clone #f]
#:post-content [post-content null])
@ -131,9 +132,12 @@
[(2) (~a "major" (if key "" " group"))]
[(3) "minor"]
[else "subminor"]))
(define num-cols (if current-rx
"7"
"5"))
(cond
[(not mid-cols)
`(tr (td ((colspan "5")) nbsp))]
`(tr (td ((colspan ,num-cols)) nbsp))]
[inst
`(tr (td
,@(for/list ([col (in-list mid-cols)])
@ -158,10 +162,24 @@
,(call-with-input-file*
(build-path (path-only table-file)
inst)
sha1)))))]
sha1))))
,@(if current-rx
`((td nbsp)
(td (span ([class "detail"])
,(if (regexp-match? current-rx inst)
`(a ([href ,(url->string
(combine-url/relative
(string->url installers-url)
(bytes->string/utf-8
(regexp-replace current-rx
(string->bytes/utf-8 inst)
#"current"))))])
"as " ldquo "current" rdquo)
'nbsp))))
null))]
[else
`(tr (td ((class ,level-class)
(colspan "5"))
(colspan ,num-cols))
,@(for/list ([col (in-list mid-cols)])
`(span nbsp nbsp nbsp))
,last-col))])))

17
pkgs/distro-build/manage-snapshots.rkt
View File

@ -50,9 +50,23 @@
(flush-output)
(delete-directory/files (build-path snapshots-dir s)))))
(printf "Creating \"current\" link\n")
(define current-rx (regexp (regexp-quote (version))))
(printf "Creating \"current\" links\n")
(flush-output)
(make-file-or-directory-link current-snapshot link-file)
(let ([installer-dir (build-path snapshots-dir current-snapshot "installers")])
(for ([f (in-list (directory-list installer-dir))])
(when (regexp-match? current-rx f)
(define file-link (build-path
installer-dir
(bytes->path
(regexp-replace current-rx
(path->bytes f)
"current"))))
(when (link-exists? file-link)
(delete-file file-link))
(make-file-or-directory-link f file-link))))
(make-download-page (build-path site-dir
installers-dir
@ -64,6 +78,7 @@
"current/pdf-doc/")
#:dest (build-path snapshots-dir
"index.html")
#:current-rx current-rx
#:git-clone (current-directory)
#:post-content `((p "Snapshot ID: "
(a ((href ,(string-append current-snapshot