source: project/egg-post-commit.scm @ 4

Last change on this file since 4 was 4, checked in by felix winkelmann, 16 years ago

added missing files

File size: 7.1 KB
Line 
1;;;; egg-post-commit.scm
2;
3; Usage: csi -s egg-post-commit.scm 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(use utils srfi-1 posix regex ftp)
13
14(define username)
15(define password)
16
17(define categories
18  '((lang-exts "Language extensions")
19    (graphics "Graphics")
20    (debugging "Debugging tools")
21    (net "Networking")
22    (io "Input/Output")
23    (db "Databases")
24    (ffi "Interfacing to other languages")
25    (web "Web programing")
26    (xml "XML processing")
27    (doc-tools "Documentation tools")
28    (math "Mathematical libraries")
29    (oop "Object-oriented programming")
30    (data "Algorithms and data-structures")
31    (parsing "Data formats and parsing")
32    (tools "Tools")
33    (testing "Unit-testing")
34    (crypt "Cryptography")
35    (ui "User interface toolkits")
36    (code-generation "Run-time code generation")
37    (misc "Miscellaneous") ) )
38
39(define (sxml->xml sxml . port)
40  (let ([port (:optional port (current-output-port))])
41    (let rec ([sxml sxml])
42      (match sxml
43        [(tag ('@ . attrs) . data)
44         (fprintf port "<~A" tag)
45         (for-each
46          (match-lambda 
47            [(name val) (fprintf port " ~A=\"~A\"" name (->string val))]
48            [(name) (fprintf port " ~A=\"~A\"" name name)]
49            [a (error "invalid SXML attribute syntax" a)] ) 
50          attrs) 
51         (if (null? data)
52             (display " />" port)
53             (begin
54               (write-char #\> port)
55               (for-each rec data)
56               (fprintf port "</~A>~%" tag) ) ) ]
57        [(tag . data) (rec `(,tag (@) . ,data))]
58        [_ (display (with-output-to-string (cut display sxml)) port)] ) ) ) )
59
60(define (htmlize str)
61  (string-translate* str '(("<" . "&lt;") (">" . "&gt;") ("\"" . "&quot;") ("&" . "&amp;"))) )
62
63(define eggs)
64
65(define (make-egg-index-page)
66  (define (t->d t)
67    (cdr (string-match "[A-Za-z]+ ([A-Za-z]+) +([0-9]+) [\\:0-9]+ ([0-9]+)\n" (seconds->string t))) )
68  (define (entry info color)
69    (let* ([ii (cdr info)]
70           [file (cadr (or (assq 'egg ii)
71                           (assq 'file ii)))]
72           [htmlfile (make-pathname #f (->string (car info)) "html")] )
73      `(tr (@ (style ,(conc "background-color: " color)))
74           (td (@ (width "15%"))
75               (a (@ (href ,htmlfile))
76                  (b ,(->string (car info))) ) )
77           (td (a (@ (href ,file)) ,file))
78           (td ,(cadr (assq 'synopsis ii)))
79           (td ,(cadr (assq 'license ii))) 
80           (td ,(cadr (assq 'author ii))) ) ) )
81  `(html
82    (head
83     (title "Eggs Unlimited") )
84    (body (@ (bgcolor "white") (text "black"))
85          (font (@ (face "Arial, Helvetica"))
86                (a (@ (href "../index.html")) "back to call/cc.org")
87                (center
88                 (img (@ (src "egg.jpg")))
89                 (h1 "Eggs Unlimited")
90                 (p (h2 (i "A library of extensions for the Chicken Scheme system"))) )
91                (p (h3 "Installation:")
92                   "Just enter"
93                   (pre "
94$ chicken-setup EXTENSIONNAME
95")
96                   "This will download anything needed to compile and install the library. If your extension "
97                   (i "repository")
98                   " is placed at a location for which you don't have write permissions, then run "
99                   (code "chicken-setup") "as root. You can obtain the repository location by running "
100                   (code "chicken-setup -repository") ".")
101                (p "If you only want to download the extension and install it later, pass the "
102                   (code "-fetch") "option to " (code "chicken-setup") ":"
103                   (pre "
104$ chicken-setup -fetch EXTENSIONNAME
105") )
106                (p "By default the archive will be unpacked into a temporary directory (named "
107                   (code "EXTENSIONNAME.egg.dir") ") and the directory will be removed if the installation "
108                   "completed successfully. To keep the extracted files add " (code "-keep") "to the "
109                   "options passed to " (code "chicken-setup") ".")
110                (p "For more information, enter ")
111                (pre "
112$ chicken-setup -help
113")
114                (p "If you would like to access the subversion repository, see "
115                   (a (@ (href "README")) "here") ".")
116                (hr)
117                ,@(map (match-lambda 
118                         [(cat catname)
119                          `(p (a (@ (name ,(->string cat)))
120                                 (h3 ,catname) )
121                              (table (@ (border "0"))
122                                     (col (@ (span "5") (align "left"))
123                                          ,@(map entry
124                                                 (filter (lambda (info) 
125                                                           (eq? cat (cadr (assq 'category (cdr info)))))
126                                                         eggs)
127                                                 (circular-list "#ffffff" "#c6eff7") ) ) ) ) ] )
128                       categories) 
129                (hr)
130                (a (@ (href "../index.html")) "back to call/cc.org")) ) ) )
131
132(define (read-egg-list)
133  (filter-map 
134   (lambda (f)
135     (and (directory? f)
136          (let ((mf (make-pathname f f "meta")))
137            (and (file-exists? mf)
138                 (begin
139                   (print* f #\space)
140                   (cons (string->symbol f) (car (read-file mf))) ) ) ) ) )
141   (cddr (directory ".") ) ) )          ; skip "." and ".."
142
143(define (upload . files)
144  (let ([ftp (ftp:connect "www.call-with-current-continuation.org" username password #f)])
145    (ftp:set-type! ftp 'binary)
146    (for-each
147     (lambda (fname)
148       (let* ([p (ftp:open-output-file ftp (make-pathname "eggs" fname))]
149              [s (file-size fname)]
150              [fd (file-open fname open/read)]
151              [data (first (file-read fd s))] )
152         (display data p)
153         (close-output-port p) ) )
154     files)
155    (ftp:disconnect ftp) ) )
156
157(define (post-commit eggnames)
158  (print "Building egg list...")
159  (set! eggs (read-egg-list))
160  (print "(" (length eggs) ")")
161  (for-each
162   (lambda (eggname)
163     (print "Reading meta-information...")
164     (let* ((meta (car (read-file (make-pathname eggname eggname "meta"))))
165            (egg (or (alist-ref 'egg meta)
166                     (alist-ref 'file meta) 
167                     (error "no `egg' or `file' property in meta info" meta))) 
168            (files (alist-ref 'files meta)) )
169       (pp meta)
170       (print "Creating egg...")
171       (when files
172         (change-directory eggname)
173         (system* "tar cfz ../~a.egg ~a" (car egg) (string-intersperse files))
174         (change-directory "..") ) ) )
175   eggnames) 
176  (print "Creating index page...")
177  (with-output-to-file "index.html"
178    (cut sxml->xml (make-egg-index-page)) )
179  (print "Creating repository file...")
180  (with-output-to-file "repository"
181    (cut pp (map (lambda (info) 
182                   `(,(car info) ()
183                     ,(car (or (alist-ref 'egg (cdr info))
184                               (alist-ref 'file (cdr info))
185                               (error "no `egg' or `file' property" info) ) )
186                     ,@(let ([needs (assq 'needs (cdr info))])
187                         (if needs
188                             (cdr needs)
189                             '() ) ) ) )
190                 eggs) ) )
191  (print "Uploading files...")
192  (upload (car egg) "index.html" "repository") 
193  (print "Finished.") )
194
195(define (build-archive name)
196  (let* ((dir (cddr (directory ".")))
197         (files 
198          (append-map
199           (lambda (f)
200             (if (and (directory? f)
201                      (file-exists? (make-pathname f f "meta")) )
202                 (let ((fs (glob (make-pathname f "*"))))
203                   (remove (lambda (fn)
204                             (or (char=? #\. (string-ref (pathname-file fn) 0))
205                                 (char=? #\~ (string-ref fn (sub1 (string-length fn))))
206                                 (member (pathname-extension fn) '("egg" "so" "rej" "orig")) ) )
207                           fs) )
208                 '() ) )
209           dir) )
210         (cmd (sprintf "tar cfz ~a ~a" name (string-intersperse files))) )
211    (print cmd)
212    (system* cmd) ) )
213
214(match (command-line-arguments)
215  (("-build-archive" name)
216   (build-archive name) )
217  ((u p file1 files ...) 
218   (set! username u)
219   (set! password p)
220   (post-commit (cons file1 files)))
221  (_ (print "Usage: egg-post-commit USERNAME PASSWORD EGGNAME") ) )
Note: See TracBrowser for help on using the repository browser.