source: project/release/3/egg-post-commit/branches/rrb2/egg-post-commit @ 8674

Last change on this file since 8674 was 8674, checked in by felix winkelmann, 13 years ago

tasks, alphabetic category sorting

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