-
-
Notifications
You must be signed in to change notification settings - Fork 15
/
Copy pathpack-and-upload.rkt
309 lines (272 loc) · 10.9 KB
/
pack-and-upload.rkt
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
#lang racket/base
;; SPDX-License-Identifier: (Apache-2.0 OR MIT)
(require aws/keys
aws/s3
racket/file
racket/cmdline
racket/set
racket/format
racket/port
racket/pretty
net/url
http/head
pkg/lib
"pack-all.rkt")
(define empty-source "empty.zip")
(define empty-source-checksum "9f098dddde7f217879070816090c1e8e74d49432")
;; Versions to map to the empty source:
(define compatibility-versions '("5.3.4" "5.3.5" "5.3.6"))
(define debug? #t)
(define dry-run? #f)
(define-values (src-dir work-dir s3-region-name bucket src-catalog dest-catalog)
(command-line
#:once-each
[("--dry-run") "Don't actually upload anything"
(set! dry-run? #t)]
#:args
(src-dir ; the enclosing directory
work-dir
[s3-region "us-west-2"]
[bucket "pkg-sources.racket-lang.org"]
[src-catalog "https://pkgs.racket-lang.org/"]
[dest-catalog "https://pkgd.racket-lang.org/"])
(values src-dir work-dir s3-region bucket src-catalog dest-catalog)))
(ensure-have-keys)
(s3-region s3-region-name)
(define s3-hostname (format "s3-~a.amazonaws.com" s3-region-name))
;; Generate ".zip" files:
(pack-all #:src-dir src-dir #:work-dir work-dir)
(define-values (catalog-email catalog-password)
(call-with-input-file*
(build-path (find-system-path 'home-dir) ".pkg-catalog-login")
(lambda (i) (values (read i) (read i)))))
(define (status fmt . args)
(apply printf fmt args)
(flush-output))
(status "Getting current packages at ~a...\n" src-catalog)
(define current-pkgs
(parameterize ([current-pkg-catalogs (list (string->url src-catalog))])
(get-all-pkg-details-from-catalogs)))
(status "... got it.\n")
(define new-pkgs
(let ([dir (build-path work-dir "catalog" "pkg")])
(for/hash ([i (in-list (directory-list dir))])
(define ht (call-with-input-file* (build-path dir i) read))
(values (path->string i)
(hash-set ht
'source
(format "https://~a/pkgs/~a/~a.zip"
bucket
(hash-ref ht 'checksum)
i))))))
;; Compute the package in the main distribution
(define main-dist-pkgs
;; A union-find would be better...
(let loop ([pkgs (set)] [check-pkgs (set "main-distribution")])
(cond
[(set-empty? check-pkgs) pkgs]
[else
(define a (set-first check-pkgs))
(define r (set-rest check-pkgs))
(if (set-member? pkgs a)
(loop pkgs r)
(loop (set-add pkgs a)
(set-union
r
(set-remove
(apply set (map (lambda (p) (if (pair? p) (car p) p))
(hash-ref (hash-ref current-pkgs a #hasheq())
'dependencies
'())))
"racket"))))])))
(status "Getting current S3 content...\n")
(define old-content (list->set (ls (string-append bucket "/pkgs"))))
(status "... got it.\n")
;; A tag that we install for each checksum that is used.
;; We can detect obsolete checksums as not having a recent
;; enough tag (i.e., older than an era). An "era" is
;; currently defined as a week.
(define now-era (quotient (current-seconds) (* 7 24 60 60)))
(define now (~a now-era))
(define recently (~a (sub1 now-era)))
(define rx:tag #rx"^[0-9]*$") ; should match timestamp tags and not packages
;; Map package names to chcksums, because we only want to delete
;; packages when we have more than one old version
(define-values (package-to-checksums checksum-to-package checksum-to-timestamp)
(for/fold ([ht #hash()] [rev-ht #hash()] [ts-ht #hash()]) ([p (in-set old-content)])
(define m (regexp-match #rx"^pkgs/([^/]*)/([^/]*)$" p))
(cond
[m
(define checksum (cadr m))
(define maybe-pkg (caddr m))
(cond
[(regexp-match? rx:tag maybe-pkg)
(values ht
rev-ht
(hash-set ts-ht checksum maybe-pkg))]
[else
(values
(hash-update ht maybe-pkg (lambda (cs) (set-add cs checksum)) (set))
(hash-set rev-ht checksum maybe-pkg)
ts-ht)])]
[else (values ht rev-ht ts-ht)])))
(when debug?
(displayln "Package to checksum")
(pretty-print package-to-checksums)
(displayln "Checksum to package")
(pretty-print checksum-to-package)
(displayln "Checksum to timestamp")
(pretty-print checksum-to-timestamp))
;; A list of `(cons checksum p)':
(define new-checksums&files
(let ([dir (build-path work-dir "pkgs")])
(for*/list ([checksum (in-list (directory-list dir))]
[p (in-list (directory-list (build-path dir checksum)))])
(cons (path->string checksum) (path->string p)))))
;; ----------------------------------------
;; Push one file at a given chcksum to the bucket
(define (sync-one checksum p)
(status "Checking ~a @ ~a\n" p checksum)
(define (at-checksum p)
(string-append "pkgs/" checksum "/" p))
(define (at-bucket&checksum p)
(string-append bucket "/" (at-checksum p)))
(define (put p content)
(status "Putting ~a\n" p)
(unless dry-run?
(define s (put/bytes p
content
"application/octet-stream"
#hash((x-amz-storage-class . "REDUCED_REDUNDANCY")
(x-amz-acl . "public-read"))))
(unless (member (extract-http-code s) '(200))
(error 'sync-one "put failed for ~s: ~s" p s))))
(unless (set-member? old-content (at-checksum now))
(put (at-bucket&checksum now)
#"ok"))
(unless (set-member? old-content (at-checksum p))
(put (at-bucket&checksum p)
(file->bytes (build-path work-dir "pkgs" checksum p)))))
;; Discard an obsolete file
(define (purge-one checksum raw-p)
(status "Removing ~a @ ~a\n" raw-p checksum)
(define p (string-append bucket "/pkgs/" checksum "/" raw-p))
(unless dry-run?
(define s (delete p))
(unless (member (extract-http-code s) '(200 204))
(error 'purge-one "delete failed for ~s: ~s" p s))))
;; Update the package catalog:
(define (update-catalog the-email the-password the-post expected-result)
(define the-url
(let ([u (string->url dest-catalog)])
(combine-url/relative u "api/upload")))
(cond
[dry-run?
(printf "Would upload to ~a:\n" (url->string the-url))
(pretty-print the-post)]
[else
(define bs
(call/input-url the-url
(λ (url)
(post-pure-port the-url
(with-output-to-bytes
(λ ()
(write (list the-email
(string->bytes/utf-8 the-password)
the-post))))))
port->bytes))
(define r (with-handlers ([exn:fail? (lambda (exn) exn)])
(read (open-input-bytes bs))))
(unless (equal? r expected-result)
(error 'update
(string-append
"unexpected result from catalog update\n"
" result: ~a\n"
" server response: ~s")
r
bs))]))
(define (add-compatibility-pkgs ht)
(hash-set ht 'versions
(for/fold ([ht2 (hash-ref ht 'versions (hash))]) ([v compatibility-versions])
(hash-set ht2 v (hash 'source
(format "https://~a/pkgs/~a"
bucket
empty-source)
'checksum
empty-source-checksum)))))
(define (add-ring-0 ht)
(hash-set ht 'ring 0))
;; ------------------------------
;; Upload current files:
(for ([p (in-list new-checksums&files)])
(sync-one (car p) (cdr p)))
;; Use 'default version, if any
(define (hash-ref* ht k def)
(define ht2 (hash-ref (hash-ref ht 'versions (hash))
'default
ht))
(hash-ref ht2 k (hash-ref ht k def)))
;; Update the catalog:
(let ([changed-pkgs
(for/hash ([(k v) (in-hash new-pkgs)]
#:unless (let ([ht (hash-ref current-pkgs k #hash())])
(and (equal? (hash-ref v 'source)
(hash-ref* ht 'source #f))
(equal? (hash-ref v 'checksum)
(hash-ref* ht 'checksum #f)))))
(define (add-tag v t)
(define l (hash-ref v 'tags '()))
(if (member t l)
v
(hash-set v 'tags (cons t l))))
(values k (add-ring-0
(add-compatibility-pkgs
(cond
[(set-member? main-dist-pkgs k)
(add-tag v "main-distribution")]
[(let ([m (regexp-match #rx"^(.*)-test$" k)])
(and m
(set-member? main-dist-pkgs (cadr m))))
(add-tag v "main-tests")]
[(equal? k "racket-test")
(add-tag v "main-tests")]
[else v])))))])
(unless (zero? (hash-count changed-pkgs))
(status "Updating catalog at ~a:\n" dest-catalog)
(for ([k (in-hash-keys changed-pkgs)])
(status " ~a\n" k))
(update-catalog catalog-email catalog-password changed-pkgs #t)))
(status "Catalog updated\n")
(status "Now = ~a\n" now)
;; Look for files that can be discarded:
(let ([new-checksums
(for/set ([pr (in-list new-checksums&files)])
(car pr))])
(for ([p (in-set old-content)])
(define m (regexp-match #rx"^pkgs/([^/]*)/([^/]*)$" p))
(when m
(define checksum (cadr m))
(define p (caddr m))
(cond
[(set-member? new-checksums checksum)
;; Keep this checksum, but look for old timestamp files.
(when (regexp-match? rx:tag p)
(unless (or (equal? p now)
(equal? p recently))
;; Looks like we can delete it
(purge-one checksum p)))]
[(or (set-member? old-content (string-append "pkgs/" checksum "/" now))
(set-member? old-content (string-append "pkgs/" checksum "/" recently)))
;; Recent enough timestamp; don't discard
(void)]
[else
;; Old checksum, but we want to keep up to one old checksum
(when (let ([checksums (hash-ref package-to-checksums
(hash-ref checksum-to-package checksum #f)
(set))])
(for/or ([cs (in-set checksums)])
(define ts (hash-ref checksum-to-timestamp cs now))
(and (not (equal? ts now))
(string<? p ts))))
;; Old checksum and not the newest old, so discard
(purge-one checksum p))]))))