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

Last change on this file since 8895 was 8895, checked in by felix winkelmann, 12 years ago

updates, update info in generated wikipage

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