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

Last change on this file since 10313 was 10313, checked in by Ivan Raikov, 13 years ago

Simplified get-egg-dir implementation.

File size: 15.5 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       "\"/>\n")))
117  (print 
118   "[[tags: eggs]]\n[[toc:]]\n\n"
119   "== Eggs Unlimited (release branch " *major-version* ", updated "
120   (string-chomp (seconds->string (current-seconds)))
121   ")\n\n"
122   "A library of extensions for the Chicken Scheme system.\n\n"
123   "=== Installation\n\n"
124   "Just enter\n\n  $ chicken-setup EXTENSIONNAME\n\n"
125   "This will download anything needed to compile and install the library. "
126   "If your extension ''repository'' is placed at a location for which "
127   "you don't have write permissions, then run {{chicken-setup}} as root. "
128   "You can obtain the repository location by running\n\n"
129   "  $ chicken-setup -repository\n\n"
130   "If you only want to download the extension and install it later, pass the "
131   "{{-fetch}} option to {{chicken-setup}}:\n\n"
132   "  $ chicken-setup -fetch EXTENSIONNAME\n\n"
133   "By default the archive will be unpacked into a temporary directory (named "
134   "{{EXTENSIONNAME.egg-dir}} and the directory will be removed if the "
135   "installation completed successfully. To keep the extracted files add "
136   "{{-keep}} to the options passed to {{chicken-setup}}.\n\n"
137   "For more information, enter\n\n"
138   "  $ chicken-setup -help\n\n"
139   "If you would like to access the subversion repository, see "
140   "[[eggs tutorial]].\n\n"
141   "If you are looking for 3rd party libraries used by one the extensions, "
142   "check out the CHICKEN "
143   "[[http://www.call-with-current-continuation.org/tarballs/|tarball repository]]"
144   ".\n\n=== List of available eggs\n")
145  (for-each
146   (match-lambda 
147     [(cat catname)
148      (print "\n==== " catname "\n\n<table>\n")
149      (for-each
150       entry
151       (sort
152        (filter (lambda (info) 
153                  (and (eq? cat (cadr (assq 'category (cdr info))))
154                       (not (assq 'hidden (cdr info)))))
155                eggs) 
156        (lambda (e1 e2)
157          (string<? (symbol->string (car e1)) (symbol->string (car e2))))))
158      (print "\n</table>") ] )
159   categories) )
160
161(define (read-egg-list)
162  (filter-map 
163   (lambda (f)
164     (and (directory? f)
165          (let* ((mf (make-pathname (get-egg-dir f) f "meta")))
166            (and (file-exists? mf)
167                 (begin
168                   (print* f #\space)
169                   (cons (string->symbol f) (car (read-file mf))) ) ) ) ) )
170   (directory 
171    (current-directory)) ) )
172
173(define *progress-indicator*
174  (thread-start!
175   (rec (loop)
176     (thread-sleep! 1)
177     (print* ".")
178     (loop) ) ) )
179
180(thread-suspend! *progress-indicator*)
181
182(define (with-progress-indicator thunk)
183  (dynamic-wind
184      (cut thread-resume! *progress-indicator*)
185      thunk
186      (lambda ()
187        (thread-suspend! *progress-indicator*) ) ) )
188
189(define (upload . files)
190  (let ([ftp (ftp:connect +call/cc-ftp-url+ username password)])
191    (define (out fname)
192      (let* ([p (ftp:open-output-file ftp (pathname-strip-directory fname))]
193             [s (file-size fname)]
194             [fd (file-open fname open/read)]
195             [data (first (file-read fd s))] )
196        (print* fname " ")
197        (with-progress-indicator (cut display data p))
198        (newline)
199        (close-output-port p) ) )
200    (ftp:set-type! ftp 'binary)
201    (ftp:change-directory ftp "eggs")
202    (ftp:change-directory ftp *major-version*)
203    (for-each out files)
204    (ftp:disconnect ftp) ) )
205
206; Convert a string with a version (such as "1.22.0") to a list of the
207; numbers (such as (1 22 0)). If one of the version components cannot
208; be converted to a number, then it is kept as a string.
209
210(define (version-string->numbers string)
211  (map (lambda (x) (or (string->number x) (->string x))) 
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  (match (list a b)
219         ((() _)   #f)
220         ((_  ())  #t)
221         (((a1 . an) (b1 . bn))
222          (cond ((and (number? a1) (number? b1))
223                 (cond ((> a1 b1) #t) ((= a1 b1) (version-numbers> an bn)) (else #f)))
224                ((and (string? a1) (string? b1)) 
225                 (cond ((string> a1 b1) #t) ((string= a1 b1) (version-numbers> an bn)) (else #f)))
226                (else (version-numbers> (cons (->string a1) an) (cons (->string b1) bn)))))
227         (else (error 'version-numbers> "invalid revisions: " a b))))
228
229; tags-dir is a directory with files named as software versions (eg. "1.2.29",
230; "1.3").  Returns the name of the file corresponding to the greatest software
231; version.
232
233(define (pick-latest-version tags-dir)
234  (fold
235    (lambda (a pick)
236      (let ((a-nums (version-string->numbers a)))
237        (if (or (not pick) (version-numbers> a-nums (version-string->numbers pick))) a pick)))
238    #f
239    (directory tags-dir)))
240
241; Return the directory where the latest release for the egg is to be found,
242; relative to the base of the repository (eg. "svn-client/tags/1.2").
243
244; (flw) disabled use of "latest", since it quickly gets forgotten (and then
245; the egg ever updates)
246
247(define (get-egg-dir eggname)
248  (or (let ((tags-dir (make-pathname eggname "tags")))
249        (and (file-exists? tags-dir)
250             (make-pathname tags-dir (pick-latest-version tags-dir))))
251  eggname))
252
253(define *loaded-extensions* (make-hash-table))
254
255(define (make-html-from-wiki egg-dir egg)
256  (with-output-to-file (make-pathname egg-dir egg "html")
257    (lambda ()
258      (write-stream
259        (html-stream
260          "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"
261          "<!-- Generated by egg-post-commit from the wiki, revision $Rev: 5624 $ -->"
262          (html
263            (head
264              (title "Eggs Unlimited - " egg)
265              ((link rel "stylesheet" type "text/css" href (format #f "~A/style.css" *egg-dir*)))
266              ((base href +wiki-url+)))
267            (body
268              ((div id "header")
269               (h2 egg)
270               ((div id "eggheader")
271                ((a href (format #f "~A/index.html" *egg-dir*))
272                 ((img src (format #f "~A/egg.jpg" *egg-dir*) alt "egg")))))
273              ((div id "body")
274                (p (b "Note: ")
275                   "This is taken from "
276                   ((a href (format #f "~A/~A" +wiki-url+ egg)) "the Chicken Wiki")
277                   ", where a more recent version could be available.")
278                 (wiki->html
279                  (port->stream
280                   (open-input-file (make-pathname *wiki-dir* egg)))
281                  stream-null
282                  ""
283                  (constantly stream-null)
284                  (constantly stream-null)
285                  (make-hash-table)
286                  (make-html-header 1)
287                  (constantly stream-null)
288                  (constantly #t)
289                  *loaded-extensions*) )
290              ((div id "footer")
291               (hr)
292               ((a href (format #f "~A/index.html" *egg-dir*)) "&lt; Egg index")
293               ((div id "revision-history") "$Id: egg-post-commit.scm 5624 2007-08-23 00:19:13Z felix $")
294               "&nbsp;"))))))))
295
296(define (commit-index)
297  (system* 
298   "svn ci -m 'updated by egg-post-commit' '~a'" *wiki-page*))
299
300(define (post-commit eggnames pack-only?)
301  (set! *egg-dir* 
302    (if (not (string=? "2" *major-version*))
303        (conc +call/cc-eggs-url+ "/" *major-version*)
304        +call/cc-eggs-url+ ) )
305  (set! *wiki-page*
306    (make-pathname
307     *wiki-dir*
308     (if (not (string=? "2" *major-version*)) ; svn mv 'Eggs Unlimited' 'Eggs Unlimited 2' ?
309         (conc "Eggs Unlimited " *major-version*)
310         "Eggs Unlimited")))
311  (print "Building egg list...")
312  (set! eggs (read-egg-list))
313  (print "(" (length eggs) ")")
314  (when (null? eggnames) (exit 0))
315  (let ((eggfiles '()))
316    (for-each
317     (lambda (eggname)
318       (print "Reading meta-information...")
319       (let* ((egg-dir (get-egg-dir eggname))
320              (meta (car (read-file (make-pathname egg-dir eggname "meta"))))
321              (egg (or (alist-ref 'egg meta)
322                       (begin
323                         (fprintf 
324                          (current-error-port)
325                          "no `egg' property in meta info: ~a" meta)
326                         #f) ) ) )
327         (when egg
328           (let* ((files (alist-ref 'files meta)) 
329                  (hidden (alist-ref 'hidden meta))
330                  (ufile (car egg)) )
331             (match (string-match ".*/tags/([.0-9]+)" egg-dir)
332               ((_ v)
333                (print "generating version file (" v ") ...")
334                (set! files (cons "version" files))
335                (with-output-to-file (make-pathname egg-dir "version")
336                  (cut print v) ) )
337               (_ #f) )
338             (set! files (cons (make-pathname #f eggname "meta") files))
339             (print egg-dir)
340             (pp meta)
341             (cond ((assq 'doc-from-wiki meta)
342                    (cond ((file-exists? (make-pathname *wiki-dir* eggname))
343                           (print "Create HTML from wiki")
344                           (make-html-from-wiki egg-dir eggname))
345                          (else (print "wiki page missing: " eggname))))
346                   ((assq 'eggdoc meta) =>
347                    (lambda (edoc)
348                      (print "Creating HTML from eggdoc file " (cadr edoc))
349                      (system* "csi -s ~a >~a" 
350                               (make-pathname egg-dir (cadr edoc))
351                               (make-pathname egg-dir eggname "html")) ) ) )
352             (print "Creating egg...")
353             ;; Install additional documentation, if any.
354             (cond
355              ((assq 'documentation meta)
356               =>
357               (lambda (docs)
358                 (for-each
359                  (lambda (doc)
360                    (let ([doc-full (conc eggname "-" doc)])
361                      (print "Installing additional docs: " doc-full)
362                      (set! eggfiles (cons (make-pathname egg-dir doc-full) eggfiles))))
363                  (cdr docs)))))
364             (if files
365                 (system* "D=`pwd`; cd ~a; ~a cfz $D/~a ~a ~a 2>&1"
366                          egg-dir
367                          *tar-cmd* ufile *excl-file-tar-optn* (string-intersperse files))
368                 (set! ufile (make-pathname egg-dir ufile)) )
369             (let ((hfile (make-pathname egg-dir eggname "html")))
370               (when (file-exists? hfile)
371                 (set! eggfiles (cons hfile eggfiles))))
372             (set! eggfiles (cons ufile eggfiles)) ) ) ) )
373     eggnames)
374    (print "Creating index page " *wiki-page* " ...")
375    (with-output-to-file *wiki-page* make-egg-index-page)
376    (let ((rf (if pack-only?
377                  '()
378                  (begin
379                    (print "Reading current repository file from " *egg-dir* "/repository ...")
380                    (with-input-from-string (http:GET (conc *egg-dir* "/repository")) read)) ) ) )
381      (match-let ((#(_ m h md mo yr _ _ _ _) (seconds->utc-time (current-seconds))) )
382        (let* ((date (format #f "~d~2'0d~2'0d~2'0d~2'0d" (+ 1900 yr) (add1 mo) md h m))
383               (rf2 (filter-map
384                     (lambda (info) 
385                       (and-let* ((egg (alist-ref 'egg (cdr info))))
386                         `(,(car info)
387                           ,(let ((e (assq (car info) rf)))
388                              (if e
389                                  (let* ((props (cadr e))
390                                         (a (assq 'date props)) )
391                                    (cond ((and a (not (member (symbol->string (car info)) eggnames))) props)
392                                          (a (set-car! (cdr a) date) props)
393                                          (else (cons (list 'date date) props)) ) )
394                                  `((date ,date)) ) )
395                           ,(car egg)
396                           ,@(let ([needs (assq 'needs (cdr info))])
397                               (if needs
398                                   (cdr needs)
399                                   '() ) ) ) ) )
400                     eggs) ) )
401          (print "Creating repository file...")
402          (with-output-to-file "repository" (cut pp rf2)) ) ) )
403    (unless pack-only?
404      (print "Uploading files:")
405      (apply upload "repository"  (reverse eggfiles)) 
406      (commit-index) )
407    (print "(egg-post-commit) Finished.") ) )
408
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" subdirectory)
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
429  (unless (file-exists? ".egg-post-commit-anchor")
430    (error "egg-post-commit must be executed in root egg directory") )
431 
432  (for-each
433   (lambda (x)
434     (unless (string=? ".svn" (pathname-file x))
435       (load-extensions-from-file *loaded-extensions* x)))
436   (glob (conc +extension-path+ "/*.scm")) )
437
438  (assert (conjoin directory? file-exists?) *wiki-dir*)
439  (handle-exceptions ex
440      (begin
441        (print-error-message ex)
442        (print-call-chain)
443        (exit 1) )
444    (let loop ((args args))
445      (match args
446        (((or "-help" "-h" "--help") . _) (usage 0))
447        (("-tar" tar . more)
448         (set! *tar-cmd* tar)
449         (loop more) )
450        (("-rel" rel . more)
451         (set! *major-version* rel)
452         (change-directory (string-append "release/" rel))
453         (loop more) )
454        (("-pack" file1 ...)
455         (post-commit file1 #t) )
456        (("-count")
457         (post-commit '() #t) )
458        ((u p files ...) 
459         (set! username u)
460         (set! password p)
461         (unless *major-version*
462           (usage 1))
463         (post-commit files #f))
464        (_ (usage 1)))) 
465    0) )
466
467(main (command-line-arguments))
Note: See TracBrowser for help on using the repository browser.