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

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

reverted previous change

File size: 15.9 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    (ftp:change-directory ftp *major-version*)
205    (for-each out files)
206    (ftp:disconnect ftp) ) )
207
208; Convert a string with a version (such as "1.22.0") to a list of the
209; numbers (such as (1 22 0)). If one of the version components cannot
210; be converted to a number, then it is kept as a string.
211
212(define (version-string->numbers string)
213  (map (lambda (x) (or (string->number x) (->string x))) 
214       (string-split string ".")))
215
216; Given two lists with numbers corresponding to a software version (as returned
217; by version-string->numbers), check if the first is greater than the second.
218
219(define (version-numbers> a b)
220  (match (list a b)
221         ((() _)   #f)
222         ((_  ())  #t)
223         (((a1 . an) (b1 . bn))
224          (cond ((and (number? a1) (number? b1))
225                 (cond ((> a1 b1) #t) ((= a1 b1) (version-numbers> an bn)) (else #f)))
226                ((and (string? a1) (string? b1)) 
227                 (cond ((string> a1 b1) #t) ((string= a1 b1) (version-numbers> an bn)) (else #f)))
228                (else (version-numbers> (cons (->string a1) an) (cons (->string b1) bn)))))
229         (else (error 'version-numbers> "invalid revisions: " a b))))
230
231; tags-dir is a directory with files named as software versions (eg. "1.2.29",
232; "1.3").  Returns the name of the file corresponding to the greatest software
233; version.
234
235(define (pick-latest-version tags-dir)
236  (fold
237    (lambda (a pick)
238      (let ((a-nums (version-string->numbers a)))
239        (if (or (not pick) (version-numbers> a-nums (version-string->numbers pick))) a pick)))
240    #f
241    (directory tags-dir)))
242
243; Return the directory where the latest release for the egg is to be found,
244; relative to the base of the repository (eg. "svn-client/tags/1.2").
245
246; (flw) disabled use of "latest", since it quickly gets forgotten (and then
247; the egg ever updates)
248
249(define (get-egg-dir eggname)
250  (or (let ((tags-dir (make-pathname eggname "tags")))
251        (and (file-exists? tags-dir)
252             (make-pathname tags-dir (pick-latest-version tags-dir))))
253  eggname))
254
255(define *loaded-extensions* (make-hash-table))
256
257(define (make-html-from-wiki egg-dir egg)
258  (with-output-to-file (make-pathname egg-dir egg "html")
259    (lambda ()
260      (write-stream
261        (html-stream
262          "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"
263          "<!-- Generated by egg-post-commit from the wiki, revision $Rev: 5624 $ -->"
264          (html
265            (head
266              (title "Eggs Unlimited - " egg)
267              ((link rel "stylesheet" type "text/css" href (format #f "~A/style.css" *egg-dir*)))
268              ((base href +wiki-url+)))
269            (body
270              ((div id "header")
271               (h2 egg)
272               ((div id "eggheader")
273                ((a href (format #f "~A/index.html" *egg-dir*))
274                 ((img src (format #f "~A/egg.jpg" *egg-dir*) alt "egg")))))
275              ((div id "body")
276                (p (b "Note: ")
277                   "This is taken from "
278                   ((a href (format #f "~A/~A" +wiki-url+ egg)) "the Chicken Wiki")
279                   ", where a more recent version could be available.")
280                 (wiki->html
281                  (port->stream
282                   (open-input-file (make-pathname *wiki-dir* egg)))
283                  stream-null
284                  ""
285                  (constantly stream-null)
286                  (constantly stream-null)
287                  (make-hash-table)
288                  (make-html-header 1)
289                  (constantly stream-null)
290                  (constantly #t)
291                  *loaded-extensions*) )
292              ((div id "footer")
293               (hr)
294               ((a href (format #f "~A/index.html" *egg-dir*)) "&lt; Egg index")
295               ((div id "revision-history") "$Id: egg-post-commit.scm 5624 2007-08-23 00:19:13Z felix $")
296               "&nbsp;"))))))))
297
298(define (commit-index)
299  (system* 
300   "svn ci -m 'updated by egg-post-commit' '~a'" *wiki-page*))
301
302(define (post-commit eggnames pack-only?)
303  (set! *egg-dir* 
304    (if (not (string=? "2" *major-version*))
305        (conc +call/cc-eggs-url+ "/" *major-version*)
306        +call/cc-eggs-url+ ) )
307  (set! *wiki-page*
308    (make-pathname
309     *wiki-dir*
310     (if (not (string=? "2" *major-version*)) ; svn mv 'Eggs Unlimited' 'Eggs Unlimited 2' ?
311         (conc "Eggs Unlimited " *major-version*)
312         "Eggs Unlimited")))
313  (print "Building egg list...")
314  (set! eggs (read-egg-list))
315  (print "(" (length eggs) ")")
316  (when (null? eggnames) (exit 0))
317  (let ((eggfiles '()))
318    (for-each
319     (lambda (eggname)
320       (print "Reading meta-information...")
321       (let* ((egg-dir (get-egg-dir eggname))
322              (meta (car (read-file (make-pathname egg-dir eggname "meta"))))
323              (egg (or (alist-ref 'egg meta)
324                       (begin
325                         (fprintf 
326                          (current-error-port)
327                          "no `egg' property in meta info: ~a" meta)
328                         #f) ) ) )
329         (when egg
330           (let* ((files (alist-ref 'files meta)) 
331                  (hidden (alist-ref 'hidden meta))
332                  (ufile (car egg)) )
333             (match (string-match ".*/tags/([.0-9]+)" egg-dir)
334               ((_ v)
335                (print "generating version file (" v ") ...")
336                (set! files (cons "version" files))
337                (with-output-to-file (make-pathname egg-dir "version")
338                  (cut print v) ) )
339               (_ #f) )
340             (set! files (cons (make-pathname #f eggname "meta") files))
341             (print egg-dir)
342             (pp meta)
343             (cond ((assq 'doc-from-wiki meta)
344                    (cond ((file-exists? (make-pathname *wiki-dir* eggname))
345                           (print "Create HTML from wiki")
346                           (make-html-from-wiki egg-dir eggname))
347                          (else (print "wiki page missing: " eggname))))
348                   ((assq 'eggdoc meta) =>
349                    (lambda (edoc)
350                      (print "Creating HTML from eggdoc file " (cadr edoc))
351                      (system* "csi -s ~a >~a" 
352                               (make-pathname egg-dir (cadr edoc))
353                               (make-pathname egg-dir eggname "html")) ) ) )
354             (print "Creating egg...")
355             ;; Install additional documentation, if any.
356             (cond
357              ((assq 'documentation meta)
358               =>
359               (lambda (docs)
360                 (for-each
361                  (lambda (doc)
362                    (let ([doc-full (let ((doc (->string doc))
363                                          (eggname (->string eggname)))
364                                      (if (string-prefix? eggname doc) doc
365                                          (conc eggname "-" doc)))])
366                      (print "Installing additional docs: " doc-full)
367                      (set! eggfiles (cons (make-pathname egg-dir doc-full) eggfiles))))
368                  (if (assq 'doc-from-wiki meta) (let ((name (string-append (->string eggname) ".html")))
369                                                   (filter (lambda (x) (not (string=? (->string x) name)))
370                                                           (cdr docs)) )
371                      (cdr docs))))))
372             (if files
373                 (system* "D=`pwd`; cd \"~a\"; ~a cfz \"$D/~a\" ~a ~a 2>&1"
374                          egg-dir
375                          *tar-cmd* ufile *excl-file-tar-optn* (string-intersperse files))
376                 (set! ufile (make-pathname egg-dir ufile)) )
377             (let ((hfile (make-pathname egg-dir eggname "html")))
378               (when (file-exists? hfile)
379                 (set! eggfiles (cons hfile eggfiles))))
380             (set! eggfiles (cons ufile eggfiles)) ) ) ) )
381     eggnames)
382    (print "Creating index page " *wiki-page* " ...")
383    (with-output-to-file *wiki-page* make-egg-index-page)
384    (let ((rf (if pack-only?
385                  '()
386                  (begin
387                    (print "Reading current repository file from " *egg-dir* "/repository ...")
388                    (with-input-from-string (http:GET (conc *egg-dir* "/repository")) read)) ) ) )
389      (match-let ((#(_ m h md mo yr _ _ _ _) (seconds->utc-time (current-seconds))) )
390        (let* ((date (format #f "~d~2'0d~2'0d~2'0d~2'0d" (+ 1900 yr) (add1 mo) md h m))
391               (rf2 (filter-map
392                     (lambda (info) 
393                       (and-let* ((egg (alist-ref 'egg (cdr info))))
394                         `(,(car info)
395                           ,(let ((e (assq (car info) rf)))
396                              (if e
397                                  (let* ((props (cadr e))
398                                         (a (assq 'date props)) )
399                                    (cond ((and a (not (member (symbol->string (car info)) eggnames))) props)
400                                          (a (set-car! (cdr a) date) props)
401                                          (else (cons (list 'date date) props)) ) )
402                                  `((date ,date)
403                                    ) ) )
404                           ,(car egg)
405                           ,@(let ([needs (assq 'needs (cdr info))])
406                               (if needs
407                                   (cdr needs)
408                                   '() ) ) ) ) )
409                     eggs) ) )
410          (print "Creating repository file...")
411          (with-output-to-file "repository" (cut pp rf2)) ) ) )
412    (unless pack-only?
413      (print "Uploading files:")
414      (apply upload "repository"  (reverse eggfiles)) 
415      (commit-index) )
416    (print "(egg-post-commit) Finished.") ) )
417
418
419(define (usage code)
420  (print #<<EOF
421usage: egg-post-commit [ OPTION ... ] -rel MAJORVERSION USERNAME PASSWORD EGGNAME ...
422       egg-post-commit [ OPTION ... ] -pack EGGNAME ...
423       egg-post-commit [ OPTION ... ] -count
424
425  -help                 show this message
426  -tar TARCMD           command for tar'ing the created egg
427  -rel MAJORVERSION     number of release branch to use (implicitly
428                        cd's to "release/MAJORVERSION" subdirectory)
429  -pack                 create eggs but don't upload
430  -count                count number of eggs
431
432EOF
433)
434  (exit code) )
435
436(define (main args)
437
438  (unless (file-exists? ".egg-post-commit-anchor")
439    (error "egg-post-commit must be executed in root egg directory") )
440 
441  (for-each
442   (lambda (x)
443     (unless (string=? ".svn" (pathname-file x))
444       (load-extensions-from-file *loaded-extensions* x)))
445   (glob (conc +extension-path+ "/*.scm")) )
446
447  (assert (conjoin directory? file-exists?) *wiki-dir*)
448  (handle-exceptions ex
449      (begin
450        (print-error-message ex)
451        (print-call-chain)
452        (exit 1) )
453    (let loop ((args args))
454      (match args
455        (((or "-help" "-h" "--help") . _) (usage 0))
456        (("-tar" tar . more)
457         (set! *tar-cmd* tar)
458         (loop more) )
459        (("-rel" rel . more)
460         (set! *major-version* rel)
461         (change-directory (string-append "release/" rel))
462         (loop more) )
463        (("-pack" file1 ...)
464         (post-commit file1 #t) )
465        (("-count")
466         (post-commit '() #t) )
467        ((u p files ...) 
468         (set! username u)
469         (set! password p)
470         (unless *major-version*
471           (usage 1))
472         (post-commit files #f))
473        (_ (usage 1)))) 
474    0) )
475
476(main (command-line-arguments))
Note: See TracBrowser for help on using the repository browser.