| 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 '(("<" . "<") (">" . ">") ("\"" . """) ("&" . "&"))) ) |
|---|
| 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") ) ) |
|---|
