-
Notifications
You must be signed in to change notification settings - Fork 1
/
import-all.ss
218 lines (193 loc) · 9.54 KB
/
import-all.ss
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
(module import-all mzscheme
(provide (all-defined))
#| import-all.ss --- initial import of old planet files into the new server. |#
(require "db.ss" "package-creation.ss" "configuration.ss")
(require (lib "etc.ss") (lib "match.ss") (lib "list.ss"))
(startup)
(define default-repository-struct (car (get-all-repositories)))
;; ============================================================
;; import : path -> void
;; does the whole importing deal. relies on accurate information in the info table at the end
;; of this file
(define (import path)
(import-into-database (path->users path info)))
;; path->users : path (string -> (list string[realname] string[email])) -> (listof user)
;; read in a users record from an old-style planet repository
(define (path->users path info-about)
(listof-each
(directory-list path) (username-path)
(where (directory-exists? (build-path path username-path)))
(let ([username (path->string username-path)])
(match-let ([`(,realname ,email) (info-about username)])
(make-user
username
realname
email
(listof-each
(directory-list (build-path path username-path)) (pkg-path)
(unless (and (directory-exists? (build-path path username-path pkg-path))
(regexp-match #rx"^[a-zA-Z0-9-]*\\.plt$" (path->string pkg-path)))
(error 'path->users "found a weird path: ~e" (build-path path username-path pkg-path)))
(let* ([base (build-path path username-path pkg-path)]
[all-updates
(apply append
(listof-each (directory-list base) (maj)
(where (number? (string->number (path->string maj))))
(listof-each (directory-list (build-path base maj)) (min)
(where (number? (string->number (path->string min))))
(make-update (string->number (path->string maj))
(string->number (path->string min))
(build-path base maj min pkg-path)))))]
[sorted-updates
(sort
all-updates
(λ (a b)
(or (< (update-maj a) (update-maj b))
(and (= (update-maj a) (update-maj b))
(< (update-min a) (update-min b))))))])
(when (null? sorted-updates)
(error 'path->users "something went wrong, because this path has no pkgversions: ~e" base))
(make-package
(path->string pkg-path)
(update-file (car sorted-updates))
(cdr sorted-updates)))))))))
;; ============================================================
;; import proceeds as follows:
;; for each user:
;; - create user
;; - for each package owned by user:
;; * create the package
;; * for each package update:
;; # add the update, marking major or minor as appropriate
(define (import-into-database users)
(parameterize ([SEND-EMAILS? #f])
(do-for-each users (u)
(let ([user (create-new-user (user-name u) (user-realname u) (user-email u) (random-password))])
(do-for-each (user-packages u) (p)
(create-package user (package-name p) (get-package-bytes p) (list (DEFAULT-REPOSITORY)))
(let ([package (get-package (user-name u) (package-name p))])
(unless package
(error 'import
"something went wrong: added package but then it didn't exist when I looked it up: ~e ~e"
(user-name u)
(package-name p)))
(do-for-each (package-updates p) (update)
(update-package user
package
(backwards-compatible? update)
(get-update-bytes update)
(list default-repository-struct)))))))))
;; ----------------------------------------
(define-struct user (name ; string
realname ; string
email ; string
packages ; (listof package)
))
(define-struct package (name ; string
file ; path
updates ; listof update
))
(define-struct update (maj ; nat
min ; nat
file ; path
))
;; ----------------------------------------
;; get-package-bytes : package -> bytes
;; gets the bytes associated with this package (done on demand to avoid loading the whole repository in memory at once)
(define (get-package-bytes p)
(file->bytes (package-file p)))
;; ----------------------------------------
;; backwards-compatible? : update -> boolean
;; determines if the given update is marked as backwards-compatible
(define (backwards-compatible? u)
(not (= (update-min u) 0)))
;; get-update-bytes : update -> bytes
;; gets the bytes corresponding to this update.
(define (get-update-bytes u)
(file->bytes (update-file u)))
;; ----------------------------------------
;; file->bytes : path -> bytes
;; reads the entire given file into a byte string
(define (file->bytes file)
(let ([len (file-size file)])
(with-input-from-file file
(λ () (read-bytes len)))))
;; random-password : -> string
;; generates a random password to seed the database
(define (random-password)
(list->string (build-list 8 (λ (_) (integer->char (random-int-in 32 127))))))
;; random-int-in : int int -> int
;; delivers a random int in the range [lo,hi]
(define (random-int-in lo hi)
(+ (random (- hi lo)) lo))
;; ============================================================
;; scaffolding
(define-syntax do-for-each
(syntax-rules ()
[(do-for-each list-expr (name) body1 body2 ...)
(for-each
(λ (name)
body1 body2 ...)
list-expr)]))
(define-syntax listof-each
(syntax-rules (where)
[(listof-each list-expr (name) (where filter-expr) body1 body2 ...)
(map
(λ (name) body1 body2 ...)
(filter
(λ (name) filter-expr)
list-expr))]
[(listof-each list-expr (name) body1 body2 ...)
(listof-each list-expr (name) (where #t) body1 body2 ...)]))
;; ============================================================
;; missing data
(define-syntax info-fn
(syntax-rules ()
[(info-fn (e1 e2 ...) ...)
(let ([ht
(hash-table 'equal
(e1 (list e2 ...)) ...)])
(λ (arg)
(hash-table-get ht arg (λ () (list "unknown" "jacobm@cs.uchicago.edu")))))]))
(define info
(info-fn
("abromfie" "Aleks Bromfield" "abromfie@cs.brown.edu")
("ams" "Adam Shaw" "adamshaw@cs.uchicago.edu")
("cce" "Carl Eastlund" "cce@ccs.neu.edu")
("cdutchyn" "Christopher Dutchyn" "cdutchyn@cs.ubc.ca")
("clements" "John Clements" "clements@brinckerhoff.org")
("cobbe" "Richard Cobbe" "cobbe@ccs.neu.edu")
("daedalus" "Ryan Kaulakis" "rmk216@elvis.arl.psu.edu")
("dfisher" "David Fisher" "dfisher@cc.gatech.edu")
("dfriedman" "Dan Friedman" "jacobm+kanren@cs.uchicago.edu")
("dherman" "Dave Herman" "dherman@ccs.neu.edu")
("dignatof" "Daniel Ignatoff" "Daniel_Ignatoff@brown.edu")
("divascheme" "DivaScheme" "dyoo@hkn.eecs.berkeley.edu")
("dvanhorn" "David Van Horn" "dvanhorn@cs.brandeis.edu")
("dyoo" "Danny Yoo" "dyoo@hkn.eecs.berkeley.edu")
("evanfarrer" "Evan Farrer" "evan.farrer@gmail.com")
("jacobm" "Jacob Matthews" "jacobm@cs.uchicago.edu")
("jaymccarthy" "Jay McCarthy" "jaymccarthy@cs.brown.edu")
("jim" "Jim Bender" "jim@benderweb.net")
("kazzmir" "Jon Rafkind" "workmin@ccs.neu.edu")
("lizorkin" "Dmitry Lizorkin" "lizorkin@ispras.ru")
("lshift" "LShift Ltd." "tonyg@lshift.net")
("mato" "Robert Matovinovic" "robert.matovinovic@web.de")
("mburns" "Mike Burns" "netgeek@speakeasy.net")
("neil" "Neil Van Dyke" "neil@neilvandyke.org")
("oesterholt" "Hans Oesterholt-Dijkema" "hans@oesterholt.net")
("pjmatos" "Paulo Jorge Matos" "pocm@soton.ac.uk")
("planet" "PLaneT" "jacobm+planet@cs.uchicago.edu")
("plt" "PLT Scheme" "samth@ccs.neu.edu")
("robby" "Robby Findler" "robby@cs.uchicago.edu")
("ryanc" "Ryan Culpepper" "ryanc@ccs.neu.edu")
("samth" "Sam Tobin-Hochstadt" "samth@ccs.neu.edu")
("schematics" "Schematics" "noelwelsh@yahoo.com")
("soegaard" "Jens Axel Soegaard" "jensaxel@soegaard.net")
("sweeney" "Corey Sweeney" "corey.sweeney@gmail.com")
("untyped" "Untyped" "noelwelsh@yahoo.com")
("vyzo" "Dimitris Vyzovitis" "vyzo@media.mit.edu")
("williams" "Douglas Williams" "M.DOUGLAS.WILLIAMS@saic.com")
("wmfarr" "Will M. Farr" "farr@MIT.EDU")
("zck" "Chongkai Zhu" "czhu@cs.utah.edu")))
)