source: project/release/3/svnwiki-chicken/trunk/svnwiki-chicken.scm @ 13918

Last change on this file since 13918 was 13918, checked in by Ivan Raikov, 11 years ago

Slight correction in the chickenegg tag.

  • Property svn:keywords set to id
File size: 9.9 KB
Line 
1; $id$
2;
3; License: GPL-3
4
5(declare (export))
6(use svnwiki-extensions-support svn-post-commit-hooks orders format-modular srfi-40 html-stream stream-ext embedded-test sqlite3 stream-wiki)
7
8(define *url-eggs*
9  "http://www.call-with-current-continuation.org/eggs/")
10
11(define (chicken-egg-html env)
12  (let-from-environment env (params parse path-in)
13    (or
14      (and-let* ((name-stream (assoc 'name params))
15                 (name (stream->string (cdr name-stream)))
16                 (description (assoc 'description params))
17                 (license (assoc 'license params))
18                 (author (assoc 'author params))
19                 (major (assoc 'major params))
20                 )
21        (parse
22          (html-stream 
23            (tr (td (if major
24                        (let ((version (stream->string (cdr major))))
25                         (if (file-exists? (svnwiki-make-pathname path-in 
26                                             (format #f "eggref/~A/~A" version name)))
27                             (format #f "[[/eggref/~A/~A]]" version name)
28                             (format #f "[[~A~A/~A.html|~A]]" *url-eggs* version name name)))
29                        ;; Shouldn't happen.  Likely this isn't an URL either
30                        (format #f "[[~A~A.html|~A]]" *url-eggs* name name)))
31                (td (cdr description))
32                (td (cdr license))
33                (td "[[" (cdr author) "]]")
34                (td "[[http://chicken.wiki.br/dep-graphs/" name ".png|Dependencies]]")))))
35      stream-null)))
36
37(define *db* #f)
38(define *max-retries* 8)
39
40(define (db-run env query . params)
41  (let-from-environment env (data)
42    (unless *db*
43      (let* ((db-path (svnwiki-make-pathname data "scheme-definitions" "db"))
44             (existed (file-exists? db-path)))
45        (format (current-error-port) "Opening DB: ~A~%" db-path)
46        (set! *db* (sqlite3:open db-path))
47        (unless existed
48          (format (current-error-port) "Creating initial tables in DB: ~A~%" db-path)
49          (scheme-definitions-db-create env))))
50    (let loop ((attempt 0))
51      (condition-case
52        (let ((result
53                (iterator->stream
54                  (lambda (capture stop)
55                    (receive (stmt rest)
56                             (sqlite3:prepare *db* query)
57                      (apply (stream-wrap-proc-string sqlite3:for-each-row) (compose capture vector) stmt params)
58                      (sqlite3:finalize! stmt))))))
59          (stream-length result) ; force execution
60          result)
61        (e (exn sqlite3)
62           (format (current-error-port) "SQLite error: ~A, attempt ~A~%"
63                   ((condition-property-accessor 'sqlite3 'status) e)
64                   attempt)
65           (cond
66             ((and (member ((condition-property-accessor 'sqlite3 'status) e) '(locked busy))
67                   (< attempt *max-retries*))
68              (let ((seconds-wait (expt 2 attempt)))
69                (format (current-error-port) (svnwiki-translate #f "scheme-definitions database locked, attempt #~A, retry in ~A seconds~%") attempt seconds-wait)
70                (sleep seconds-wait))
71              (loop (+ attempt 1)))
72             (else
73              (signal e))))))))
74
75(define (scheme-definitions-db-create env)
76  (db-run env "CREATE TABLE definitions ( name varchar, type varchar, page varchar );")
77  (db-run env "CREATE TABLE tests ( expr varchar, expect varchar, cmp varchar, page varchar, blessed varchar );")
78  (db-run env "CREATE TABLE tests_results ( version varchar, received varchar, pass boolean, date integer );"))
79
80(test-group definition-list?
81  (test (definition-list? (string->stream "(foo bar)")))
82  (test (not (definition-list? (string->stream "foo"))))
83  (test (not (definition-list? (string->stream "")))))
84
85(define (definition-list? text)
86  (and (not (stream-null? text))
87       (char=? (stream-car text) #\()
88       (char=? (stream-last text) #\))))
89
90(test-group get-definition-name
91  (test (stream->string (get-definition-name (string->stream "(foo bar)")))
92        "foo")
93  (test (stream->string (get-definition-name (string->stream "bar")))
94        "bar"))
95
96(define (get-definition-name text)
97  (stream-take-while
98    (complement char-whitespace?)
99    (if (definition-list? text)
100      (stream-cdr (stream-butlast text))
101      text)))
102
103(define (chicken-def name env)
104  (let-from-environment env (path text parse output-format)
105    ; Remove whitespace at beginning or end
106    (let ((text (stream-reverse
107                  (stream-drop-while
108                    char-whitespace?
109                    (stream-reverse
110                      (stream-drop-while
111                        char-whitespace?
112                        text))))))
113      (case output-format
114        ((scheme-definitions)
115          (let-from-environment env (return)
116            (return (list name (get-definition-name text))))
117          stream-null)
118        (else
119          (parse
120            (html-stream
121              ((a name (format #f "xsvnwiki-scheme-~A" (stream->string (get-definition-name text))))
122               "["
123               name
124               "] {{"
125               (if (definition-list? text)
126                 (receive (name rest)
127                          (stream-break char-whitespace?
128                                        (stream-cdr (stream-butlast text)))
129                   (html-stream
130                     "('''" name "'''" rest ")"))
131                 text)
132               "}}\n\n"))))))))
133
134(define (chicken-examples env)
135  (let-from-environment env (params parse text output-format)
136    (let ((filename (assoc 'filename params))
137          (testgroup (assoc 'testgroup params)))
138      (format (current-error-port) "Tests: [filename:~A][testgroup:~A]~%"
139              (and filename (stream->string (cdr filename)))
140              (and testgroup (stream->string (cdr testgroup))))
141      (if (or (not (eq? output-format 'enscript))
142              (and filename testgroup))
143        (parse
144          (html-stream
145            "Examples:\n\n"
146            "<enscript highlight=scheme"
147            (if (and filename testgroup)
148              (format #f " filename='~A'"
149                      (stream->string
150                        (stream-remove (cut char=? <> #\')
151                                       (cdr filename))))
152              "")
153            ">"
154            (if (and filename testgroup (eq? output-format 'enscript))
155              (format #f "\n(test-group ~A" (stream->string (cdr testgroup)))
156              "")
157            (parse text)
158            (if (and filename testgroup (eq? output-format 'enscript))
159              ")\n"
160              "")
161            "</enscript>"))
162        stream-null))))
163
164(define (chicken-example env)
165  (let-from-environment env (text output-format parse)
166    (html-stream
167      (if (eq? output-format 'enscript)
168        "\n  (test"
169        "")
170      (parse text)
171      (if (eq? output-format 'enscript)
172        ")"
173        ""))))
174
175(define (chicken-expr env)
176  (let-from-environment env (text output-format)
177    (if (eq? output-format 'enscript)
178      (html-stream " " text)
179      (html-stream text "\n"))))
180
181(define (chicken-result include prefix env)
182  (let-from-environment env (text output-format)
183    (if (eq? output-format 'enscript)
184      (html-stream " " text)
185      (html-stream prefix " " text "\n"))))
186
187(define (chicken-result-cmp env)
188  (let-from-environment env (text output-format)
189    (if (eq? output-format 'enscript)
190      (html-stream " " text)
191      stream-null)))
192
193(define (update-notify-scheme env)
194  (let-from-environment env (path-in path)
195    (format (current-error-port) "Start scheme update: ~A~%" path)
196    (db-run env "DELETE FROM definitions WHERE page = ?;" path)
197    (stream-for-each
198      (lambda (data)
199        (db-run env "INSERT INTO definitions VALUES ( ?, ?, ? );" (cadr data) (car data) path))
200      (iterator->stream
201        (lambda (return stop)
202          (wiki-extension
203            'scheme-definitions
204            (wiki-open path-in path)
205            stream-null
206            path
207            (constantly stream-null)
208            (lambda (name tail) tail)
209            (make-hash-table)
210            (environment-capture env (return))))))))
211
212(define (redirect-scheme env)
213  (let-from-environment env (path return)
214    (unless (file-exists? (svnwiki-repository-path env))
215      (let ((targets (db-run env "SELECT page FROM definitions WHERE name = ?;" path)))
216        (unless (stream-null? targets)
217          (return
218            (format #f "~A#xsvnwiki-scheme-~A"
219                    (vector-ref (stream-car targets) 0)
220                    path)))))))
221
222(svnwiki-extension-define 'redirect 'scheme-definitions redirect-scheme)
223(svnwiki-extension-define 'update-notify-recursive 'scheme-definitions update-notify-scheme)
224
225(svnwiki-extension-define 'code-break 'chickenegg chicken-egg-html)
226
227(svnwiki-extension-define 'code-span 'procedure (cut chicken-def "procedure" <>))
228(svnwiki-extension-define 'code-span 'macro (cut chicken-def "macro" <>))
229(svnwiki-extension-define 'code-span 'read (cut chicken-def "read" <>))
230(svnwiki-extension-define 'code-span 'parameter (cut chicken-def "parameter" <>))
231(svnwiki-extension-define 'code-span 'record (cut chicken-def "record" <>))
232(svnwiki-extension-define 'code-span 'string (cut chicken-def "string" <>))
233(svnwiki-extension-define 'code-span 'class (cut chicken-def "class" <>))
234(svnwiki-extension-define 'code-span 'method (cut chicken-def "method" <>))
235(svnwiki-extension-define 'code-span 'integer (cut chicken-def "integer" <>))
236(svnwiki-extension-define 'code-span 'constant (cut chicken-def "constant" <>))
237(svnwiki-extension-define 'code-span 'examples chicken-examples)
238(svnwiki-extension-define 'code-span 'example chicken-example)
239; For the time being, we just ignore these:
240(svnwiki-extension-define 'code-span 'init (lambda (env) stream-null))
241(svnwiki-extension-define 'code-span 'expr chicken-expr)
242(svnwiki-extension-define 'code-span 'result (cut chicken-result #t "=>" <>))
243(svnwiki-extension-define 'code-span 'resultcmp chicken-result-cmp)
244(svnwiki-extension-define 'code-span 'input (cut chicken-result #f "[input]" <>))
245(svnwiki-extension-define 'code-span 'output (cut chicken-result #f "[output]" <>))
Note: See TracBrowser for help on using the repository browser.