source: project/release/3/egg-post-commit/trunk/egg-post-commit.scm @ 11445

Last change on this file since 11445 was 11445, checked in by elf, 12 years ago

added a rule to create nonextant toplevel dirs if needed.

File size: 16.1 KB
Line 
1;;;; egg-post-commit.scm
2;
3; Usage: egg-post-commit USERNAME PASSWORD EGGNAME
4;
5; 1. Creates .egg from files given in .meta file
6; 2. Rebuilds index.html for egg-info page and repository file
7; 3. FTPs .egg and .html to call/cc.org
8;
9; - expects to be run in egg toplevel directory
10
11
12(require-extension 
13 syntax-case matchable
14 utils srfi-1 srfi-13 srfi-18 srfi-69 posix regex
15 ftp http-client format-modular uri base64 svn-client 
16 srfi-40 stream-ext html-stream stream-wiki )
17
18(define-constant +call/cc-ftp-url+ "www.call-with-current-continuation.org")
19(define-constant +call/cc-eggs-url+ "http://www.call-with-current-continuation.org/eggs")
20(define +wiki-url+ "http://chicken.wiki.br")
21(define-constant +extension-path+ "release/2/stream-wiki/tags/1.9/extensions")
22
23
24(assert (string>=? (->string (cadr (assq 'version (extension-information 'http)))) "1.46")
25        "Please install a newer version of the http egg")
26
27(define username)
28(define password)
29
30(define *tar-cmd* "tar")
31(define *excl-file-tar-optn* "--exclude='.*'")
32(define *major-version* #f)
33(define *egg-dir*)
34(define *wiki-page*)
35(define *wiki-dir* (make-pathname (current-directory) "wiki"))
36
37(define categories
38  '((lang-exts "Language extensions")
39    (graphics "Graphics")
40    (debugging "Debugging tools")
41    (logic "Logic programming")
42    (net "Networking")
43    (io "Input/Output")
44    (db "Databases")
45    (os "OS interface")
46    (ffi "Interfacing to other languages")
47    (web "Web programing")
48    (xml "XML processing")
49    (doc-tools "Documentation tools")
50    (egg-tools "Egg tools")
51    (math "Mathematical libraries")
52    (oop "Object-oriented programming")
53    (data "Algorithms and data-structures")
54    (parsing "Data formats and parsing")
55    (tools "Tools")
56    (sound "Sound")
57    (testing "Unit-testing")
58    (crypt "Cryptography")
59    (ui "User interface toolkits")
60    (code-generation "Code generation")
61    (macros "Macros and meta-syntax")
62    (misc "Miscellaneous")
63    (hell "Concurrency and parallelism")
64    (obsolete "Unsupported or redundant") ) )
65
66(define (sxml->xml sxml . port)
67  (let ([port (:optional port (current-output-port))])
68    (let rec ([sxml sxml])
69      (match sxml
70        [(tag ('@ . attrs) . data)
71         (fprintf port "<~A" tag)
72         (for-each
73          (match-lambda 
74            [(name val) (fprintf port " ~A=\"~A\"" name (->string val))]
75            [(name) (fprintf port " ~A=\"~A\"" name name)]
76            [a (error "invalid SXML attribute syntax" a)] ) 
77          attrs) 
78         (if (null? data)
79             (display " />" port)
80             (begin
81               (write-char #\> port)
82               (for-each rec data)
83               (fprintf port "</~A>~%" tag) ) ) ]
84        [(tag . data) (rec `(,tag (@) . ,data))]
85        [_ (display (with-output-to-string (cut display sxml)) port)] ) ) ) )
86
87(define (htmlize str)
88  (string-translate* str '(("<" . "&lt;") (">" . "&gt;") ("\"" . "&quot;") ("&" . "&amp;"))) )
89
90(define eggs)
91
92(define (cleanup-links str)
93  (string-substitute*
94   str
95   '(("<a href=\"mailto:felix@call-with-current-continuation.org\">felix</a>" .
96      "felix winkelmann"))))
97
98(define (make-egg-index-page)
99  (define (t->d t)
100    (cdr (string-match "[A-Za-z]+ ([A-Za-z]+) +([0-9]+) [\\:0-9]+ ([0-9]+)\n" (seconds->string t))) )
101  (define (getprop p lst def)
102    (cond ((assq p lst) => cadr)
103          (else def) ) )
104  (define (entry info)
105    (let* ([ii (cdr info)]
106           [htmlfile (make-pathname #f (->string (car info)) "html")] )
107      (print
108       "<chickenegg name=\""
109       (car info)
110       "\" license=\""
111       (getprop 'license ii "unknown")
112       "\" author=\""
113       (cleanup-links (getprop 'author ii "unknown"))
114       "\" description=\""
115       (cleanup-links (getprop 'synopsis ii "unknown"))
116       "\" "
117       (if *major-version* (conc "major=\"" (->string *major-version*) "\"") "")
118       "/>\n")))
119  (print 
120   "[[tags: eggs]]\n[[toc:]]\n\n"
121   "== Eggs Unlimited (release branch " *major-version* ", updated "
122   (string-chomp (seconds->string (current-seconds)))
123   ")\n\n"
124   "A library of extensions for the Chicken Scheme system.\n\n"
125   "=== Installation\n\n"
126   "Just enter\n\n  $ chicken-setup EXTENSIONNAME\n\n"
127   "This will download anything needed to compile and install the library. "
128   "If your extension ''repository'' is placed at a location for which "
129   "you don't have write permissions, then run {{chicken-setup}} as root. "
130   "You can obtain the repository location by running\n\n"
131   "  $ chicken-setup -repository\n\n"
132   "If you only want to download the extension and install it later, pass the "
133   "{{-fetch}} option to {{chicken-setup}}:\n\n"
134   "  $ chicken-setup -fetch EXTENSIONNAME\n\n"
135   "By default the archive will be unpacked into a temporary directory (named "
136   "{{EXTENSIONNAME.egg-dir}} and the directory will be removed if the "
137   "installation completed successfully. To keep the extracted files add "
138   "{{-keep}} to the options passed to {{chicken-setup}}.\n\n"
139   "For more information, enter\n\n"
140   "  $ chicken-setup -help\n\n"
141   "If you would like to access the subversion repository, see "
142   "[[eggs tutorial]].\n\n"
143   "If you are looking for 3rd party libraries used by one the extensions, "
144   "check out the CHICKEN "
145   "[[http://www.call-with-current-continuation.org/tarballs/|tarball repository]]"
146   ".\n\n=== List of available eggs\n")
147  (for-each
148   (match-lambda 
149     [(cat catname)
150      (print "\n==== " catname "\n\n<table>\n")
151      (for-each
152       entry
153       (sort
154        (filter (lambda (info) 
155                  (and (eq? cat (cadr (assq 'category (cdr info))))
156                       (not (assq 'hidden (cdr info)))))
157                eggs) 
158        (lambda (e1 e2)
159          (string<? (symbol->string (car e1)) (symbol->string (car e2))))))
160      (print "\n</table>") ] )
161   categories) )
162
163(define (read-egg-list)
164  (filter-map 
165   (lambda (f)
166     (and (directory? f)
167          (let* ((mf (make-pathname (get-egg-dir f) f "meta")))
168            (and (file-exists? mf)
169                 (begin
170                   (print* f #\space)
171                   (cons (string->symbol f) (car (read-file mf))) ) ) ) ) )
172   (directory 
173    (current-directory)) ) )
174
175(define *progress-indicator*
176  (thread-start!
177   (rec (loop)
178     (thread-sleep! 1)
179     (print* ".")
180     (loop) ) ) )
181
182(thread-suspend! *progress-indicator*)
183
184(define (with-progress-indicator thunk)
185  (dynamic-wind
186      (cut thread-resume! *progress-indicator*)
187      thunk
188      (lambda ()
189        (thread-suspend! *progress-indicator*) ) ) )
190
191(define (upload . files)
192  (let ([ftp (ftp:connect +call/cc-ftp-url+ username password)])
193    (define (out fname)
194      (let* ([p (ftp:open-output-file ftp (pathname-strip-directory fname))]
195             [s (file-size fname)]
196             [fd (file-open fname open/read)]
197             [data (first (file-read fd s))] )
198        (print* fname " ")
199        (with-progress-indicator (cut display data p))
200        (newline)
201        (close-output-port p) ) )
202    (ftp:set-type! ftp 'binary)
203    (ftp:change-directory ftp "eggs")
204    (condition-case (ftp:change-directory ftp *major-version*)
205        (ign ()
206            (ftp:create-directory ftp *major-version*)
207            (ftp:change-directory ftp *major-version*)))
208    ;(ftp:change-directory ftp *major-version*)
209    (for-each out files)
210    (ftp:disconnect ftp) ) )
211
212; Convert a string with a version (such as "1.22.0") to a list of the
213; numbers (such as (1 22 0)). If one of the version components cannot
214; be converted to a number, then it is kept as a string.
215
216(define (version-string->numbers string)
217  (map (lambda (x) (or (string->number x) (->string x))) 
218       (string-split string ".")))
219
220; Given two lists with numbers corresponding to a software version (as returned
221; by version-string->numbers), check if the first is greater than the second.
222
223(define (version-numbers> a b)
224  (match (list a b)
225         ((() _)   #f)
226         ((_  ())  #t)
227         (((a1 . an) (b1 . bn))
228          (cond ((and (number? a1) (number? b1))
229                 (cond ((> a1 b1) #t) ((= a1 b1) (version-numbers> an bn)) (else #f)))
230                ((and (string? a1) (string? b1)) 
231                 (cond ((string> a1 b1) #t) ((string= a1 b1) (version-numbers> an bn)) (else #f)))
232                (else (version-numbers> (cons (->string a1) an) (cons (->string b1) bn)))))
233         (else (error 'version-numbers> "invalid revisions: " a b))))
234
235; tags-dir is a directory with files named as software versions (eg. "1.2.29",
236; "1.3").  Returns the name of the file corresponding to the greatest software
237; version.
238
239(define (pick-latest-version tags-dir)
240  (fold
241    (lambda (a pick)
242      (let ((a-nums (version-string->numbers a)))
243        (if (or (not pick) (version-numbers> a-nums (version-string->numbers pick))) a pick)))
244    #f
245    (directory tags-dir)))
246
247; Return the directory where the latest release for the egg is to be found,
248; relative to the base of the repository (eg. "svn-client/tags/1.2").
249
250; (flw) disabled use of "latest", since it quickly gets forgotten (and then
251; the egg ever updates)
252
253(define (get-egg-dir eggname)
254  (or (let ((tags-dir (make-pathname eggname "tags")))
255        (and (file-exists? tags-dir)
256             (make-pathname tags-dir (pick-latest-version tags-dir))))
257  eggname))
258
259(define *loaded-extensions* (make-hash-table))
260
261(define (make-html-from-wiki egg-dir egg)
262  (with-output-to-file (make-pathname egg-dir egg "html")
263    (lambda ()
264      (write-stream
265        (html-stream
266          "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"
267          "<!-- Generated by egg-post-commit from the wiki, revision $Rev: 5624 $ -->"
268          (html
269            (head
270              (title "Eggs Unlimited - " egg)
271              ((link rel "stylesheet" type "text/css" href (format #f "~A/style.css" *egg-dir*)))
272              ((base href +wiki-url+)))
273            (body
274              ((div id "header")
275               (h2 egg)
276               ((div id "eggheader")
277                ((a href (format #f "~A/index.html" *egg-dir*))
278                 ((img src (format #f "~A/egg.jpg" *egg-dir*) alt "egg")))))
279              ((div id "body")
280                (p (b "Note: ")
281                   "This is taken from "
282                   ((a href (format #f "~A/~A" +wiki-url+ egg)) "the Chicken Wiki")
283                   ", where a more recent version could be available.")
284                 (wiki->html
285                  (port->stream
286                   (open-input-file (make-pathname *wiki-dir* egg)))
287                  stream-null
288                  ""
289                  (constantly stream-null)
290                  (constantly stream-null)
291                  (make-hash-table)
292                  (make-html-header 1)
293                  (constantly stream-null)
294                  (constantly #t)
295                  *loaded-extensions*) )
296              ((div id "footer")
297               (hr)
298               ((a href (format #f "~A/index.html" *egg-dir*)) "&lt; Egg index")
299               ((div id "revision-history") "$Id: egg-post-commit.scm 5624 2007-08-23 00:19:13Z felix $")
300               "&nbsp;"))))))))
301
302(define (commit-index)
303  (system* 
304   "svn ci -m 'updated by egg-post-commit' '~a'" *wiki-page*))
305
306(define (post-commit eggnames pack-only?)
307  (set! *egg-dir* 
308    (if (not (string=? "2" *major-version*))
309        (conc +call/cc-eggs-url+ "/" *major-version*)
310        +call/cc-eggs-url+ ) )
311  (set! *wiki-page*
312    (make-pathname
313     *wiki-dir*
314     (if (not (string=? "2" *major-version*)) ; svn mv 'Eggs Unlimited' 'Eggs Unlimited 2' ?
315         (conc "Eggs Unlimited " *major-version*)
316         "Eggs Unlimited")))
317  (print "Building egg list...")
318  (set! eggs (read-egg-list))
319  (print "(" (length eggs) ")")
320  (when (null? eggnames) (exit 0))
321  (let ((eggfiles '()))
322    (for-each
323     (lambda (eggname)
324       (print "Reading meta-information...")
325       (let* ((egg-dir (get-egg-dir eggname))
326              (meta (car (read-file (make-pathname egg-dir eggname "meta"))))
327              (egg (or (alist-ref 'egg meta)
328                       (begin
329                         (fprintf 
330                          (current-error-port)
331                          "no `egg' property in meta info: ~a" meta)
332                         #f) ) ) )
333         (when egg
334           (let* ((files (alist-ref 'files meta)) 
335                  (hidden (alist-ref 'hidden meta))
336                  (ufile (car egg)) )
337             (match (string-match ".*/tags/([.0-9]+)" egg-dir)
338               ((_ v)
339                (print "generating version file (" v ") ...")
340                (set! files (cons "version" files))
341                (with-output-to-file (make-pathname egg-dir "version")
342                  (cut print v) ) )
343               (_ #f) )
344             (set! files (cons (make-pathname #f eggname "meta") files))
345             (print egg-dir)
346             (pp meta)
347             (cond ((assq 'doc-from-wiki meta)
348                    (cond ((file-exists? (make-pathname *wiki-dir* eggname))
349                           (print "Create HTML from wiki")
350                           (make-html-from-wiki egg-dir eggname))
351                          (else (print "wiki page missing: " eggname))))
352                   ((assq 'eggdoc meta) =>
353                    (lambda (edoc)
354                      (print "Creating HTML from eggdoc file " (cadr edoc))
355                      (system* "csi -s ~a >~a" 
356                               (make-pathname egg-dir (cadr edoc))
357                               (make-pathname egg-dir eggname "html")) ) ) )
358             (print "Creating egg...")
359             ;; Install additional documentation, if any.
360             (cond
361              ((assq 'documentation meta)
362               =>
363               (lambda (docs)
364                 (for-each
365                  (lambda (doc)
366                    (let ([doc-full (let ((doc (->string doc))
367                                          (eggname (->string eggname)))
368                                      (if (string-prefix? eggname doc) doc
369                                          (conc eggname "-" doc)))])
370                      (print "Installing additional docs: " doc-full)
371                      (set! eggfiles (cons (make-pathname egg-dir doc-full) eggfiles))))
372                  (if (assq 'doc-from-wiki meta) (let ((name (string-append (->string eggname) ".html")))
373                                                   (filter (lambda (x) (not (string=? (->string x) name)))
374                                                           (cdr docs)) )
375                      (cdr docs))))))
376             (if files
377                 (system* "D=`pwd`; cd \"~a\"; ~a cfz \"$D/~a\" ~a ~a 2>&1"
378                          egg-dir
379                          *tar-cmd* ufile *excl-file-tar-optn* (string-intersperse files))
380                 (set! ufile (make-pathname egg-dir ufile)) )
381             (let ((hfile (make-pathname egg-dir eggname "html")))
382               (when (file-exists? hfile)
383                 (set! eggfiles (cons hfile eggfiles))))
384             (set! eggfiles (cons ufile eggfiles)) ) ) ) )
385     eggnames)
386    (print "Creating index page " *wiki-page* " ...")
387    (with-output-to-file *wiki-page* make-egg-index-page)
388    (let ((rf (if pack-only?
389                  '()
390                  (begin
391                    (print "Reading current repository file from " *egg-dir* "/repository ...")
392                    (with-input-from-string (http:GET (conc *egg-dir* "/repository")) read)) ) ) )
393      (match-let ((#(_ m h md mo yr _ _ _ _) (seconds->utc-time (current-seconds))) )
394        (let* ((date (format #f "~d~2'0d~2'0d~2'0d~2'0d" (+ 1900 yr) (add1 mo) md h m))
395               (rf2 (filter-map
396                     (lambda (info) 
397                       (and-let* ((egg (alist-ref 'egg (cdr info))))
398                         `(,(car info)
399                           ,(let ((e (assq (car info) rf)))
400                              (if e
401                                  (let* ((props (cadr e))
402                                         (a (assq 'date props)) )
403                                    (cond ((and a (not (member (symbol->string (car info)) eggnames))) props)
404                                          (a (set-car! (cdr a) date) props)
405                                          (else (cons (list 'date date) props)) ) )
406                                  `((date ,date)
407                                    ) ) )
408                           ,(car egg)
409                           ,@(let ([needs (assq 'needs (cdr info))])
410                               (if needs
411                                   (cdr needs)
412                                   '() ) ) ) ) )
413                     eggs) ) )
414          (print "Creating repository file...")
415          (with-output-to-file "repository" (cut pp rf2)) ) ) )
416    (unless pack-only?
417      (print "Uploading files:")
418      (apply upload "repository"  (reverse eggfiles)) 
419      (commit-index) )
420    (print "(egg-post-commit) Finished.") ) )
421
422
423(define (usage code)
424  (print #<<EOF
425usage: egg-post-commit [ OPTION ... ] -rel MAJORVERSION USERNAME PASSWORD EGGNAME ...
426       egg-post-commit [ OPTION ... ] -pack EGGNAME ...
427       egg-post-commit [ OPTION ... ] -count
428
429  -help                 show this message
430  -tar TARCMD           command for tar'ing the created egg
431  -rel MAJORVERSION     number of release branch to use (implicitly
432                        cd's to "release/MAJORVERSION" subdirectory)
433  -pack                 create eggs but don't upload
434  -count                count number of eggs
435
436EOF
437)
438  (exit code) )
439
440(define (main args)
441
442  (unless (file-exists? ".egg-post-commit-anchor")
443    (error "egg-post-commit must be executed in root egg directory") )
444 
445  (for-each
446   (lambda (x)
447     (unless (string=? ".svn" (pathname-file x))
448       (load-extensions-from-file *loaded-extensions* x)))
449   (glob (conc +extension-path+ "/*.scm")) )
450
451  (assert (conjoin directory? file-exists?) *wiki-dir*)
452  (handle-exceptions ex
453      (begin
454        (print-error-message ex)
455        (print-call-chain)
456        (exit 1) )
457    (let loop ((args args))
458      (match args
459        (((or "-help" "-h" "--help") . _) (usage 0))
460        (("-tar" tar . more)
461         (set! *tar-cmd* tar)
462         (loop more) )
463        (("-rel" rel . more)
464         (set! *major-version* rel)
465         (change-directory (string-append "release/" rel))
466         (loop more) )
467        (("-pack" file1 ...)
468         (post-commit file1 #t) )
469        (("-count")
470         (post-commit '() #t) )
471        ((u p files ...) 
472         (set! username u)
473         (set! password p)
474         (unless *major-version*
475           (usage 1))
476         (post-commit files #f))
477        (_ (usage 1)))) 
478    0) )
479
480(main (command-line-arguments))
Note: See TracBrowser for help on using the repository browser.