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

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

created tags and branches

File size: 14.9 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       (filter (lambda (info)
153                 (and (eq? cat (cadr (assq 'category (cdr info))))
154                      (not (assq 'hidden (cdr info)))))
155               eggs) )
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.