source: project/stream-wiki/trunk/extensions/image.scm @ 6551

Last change on this file since 6551 was 6551, checked in by azul, 12 years ago

Close the pipe or we'll run into too-many-open-files errors, silly.

File size: 10.5 KB
Line 
1(require-extension syntax-case svn-post-commit-hooks orders format-modular html-stream)
2
3(define-syntax environment
4  (syntax-rules ()
5    ((environment original ((name expr) ...))
6     (lambda (op)
7       (case op
8         ((name) expr)
9         ...
10         (else (original op)))))
11    ((environment ((name expr) ...))
12     (environment (lambda (op)
13                    (warning "unbound variable (dynamic environment)" op)
14                    (if #f #f))
15                  ((name expr) ...)))))
16
17(define-syntax environment-get
18  (syntax-rules ()
19    ((environment-get env sym) (env 'sym))))
20
21(define-syntax let-from-environment
22  (syntax-rules ()
23    ((let-from-environment env (sym ...) body ...)
24     (let ((sym (environment-get env sym)) ...) body ...))))
25
26(define-syntax environment-capture
27  (syntax-rules ()
28    ((environment-capture env (sym ...))
29     (environment env ((sym sym) ...)))
30    ((environment-capture (sym ...))
31     (environment ((sym sym) ...)))))
32
33(define *image-javascript*
34#<<EOF
35if (typeof(svnwikiImage) != "object") {
36
37var svnwikiImage = new Object();
38
39svnwikiImage.cleanContent = function (element)
40{
41  while (element.hasChildNodes())
42    element.removeChild(element.firstChild);
43}
44
45svnwikiImage.makeLink = function ( target, content )
46{
47  var link = svnwikiImage.makeElement('A', content);
48  link.setAttribute('href', target);
49  return link;
50}
51
52svnwikiImage.makeElement = function ( type, content )
53{
54  var elem = document.createElement(type);
55  if (content)
56    elem.appendChild(content);
57  return elem;
58}
59
60svnwikiImage.pickSize = function (imgName, prefix, width, height)
61{
62  var sizesDiv = document.getElementById('svnwikiImageSizes' + imgName);
63  svnwikiImage.cleanContent(sizesDiv);
64  sizesDiv.appendChild(svnwikiImage.makeElement('p', document.createTextNode('Please wait, loading image...')));
65
66  var img = document.getElementById('svnwikiImage' + imgName);
67  img.width = width;
68  img.height = height;
69  img.src = prefix + '-' + Math.max(width, height);
70  img.onload = function () { svnwikiImage.cleanContent(sizesDiv); };
71}
72
73svnwikiImage.showSizes = function (imgName, sizes, prefix)
74{
75  var sizesDiv = document.getElementById('svnwikiImageSizes' + imgName);
76  var img = document.getElementById('svnwikiImage' + imgName);
77
78  if (sizesDiv.firstChild) {
79    svnwikiImage.cleanContent(sizesDiv);
80    return;
81  }
82
83  var ul = document.createElement('ul');
84  for (var j = 0; j < sizes.length; j ++) {
85    var target = "javascript:svnwikiImage.pickSize('" + imgName + "','" + prefix + "'," + sizes[j][0] + "," + sizes[j][1] + ");";
86    var text = document.createTextNode(sizes[j][0] + "x" + sizes[j][1]);
87    ul.appendChild(svnwikiImage.makeElement('li', svnwikiImage.makeLink(target, text)));
88  }
89  sizesDiv.appendChild(ul)
90}
91
92}
93EOF
94)
95
96(define (svnwiki-image-create-helper env)
97  (let-from-environment env (path-out program)
98    (when (and path-out (string=? program "post-commit"))
99      (assert (and 'svnwiki-image-create-helper (string? path-out)))
100      (unless (directory? (svnwiki-make-pathname path-out "xsvnwiki-helper"))
101        (create-directory (svnwiki-make-pathname path-out "xsvnwiki-helper")))
102      (unless (directory? (svnwiki-make-pathname (list path-out "xsvnwiki-helper") "image"))
103        (create-directory (svnwiki-make-pathname (list path-out "xsvnwiki-helper") "image")))
104      (write-file-with-tmp
105        (svnwiki-make-pathname (list "xsvnwiki-helper" "image") "image")
106        "text/javascript"
107        path-out
108        (string->stream
109          *image-javascript*)))))
110
111(define (svnwiki-image-show-sizes-link env random-id)
112  (let-from-environment env (path)
113    (format #f "javascript:svnwikiImage.showSizes('~A', [~{[~{~A~^, ~}]~^, ~}], '~A');"
114            random-id
115            (svnwiki-image-sizes-env env)
116            (last (string-split path "/")))))
117
118(define (svnwiki-image-default-size env)
119  (svnwiki-image-size-pick-closest (svnwiki-image-sizes-env env)
120                                   *svnwiki-image-sizes-default*))
121
122(define (svnwiki-image-size-pick-closest sizes spec)
123  (fold (lambda (c best)
124          (if (< (abs (- (apply max c) spec))
125                 (abs (- (apply max best) spec)))
126            c
127            best))
128        (car sizes)
129        (cdr sizes)))
130
131(define (svnwiki-image-handler-render env)
132  (let-from-environment env (initial-header-depth path-in path static-url)
133    (svnwiki-report-progress env "Image generate HTML: ~A~%" path)
134    (svnwiki-image-create-helper env)
135    (let ((random-id (random 100000)))
136      (html-stream
137        (format #f "<h~A>" initial-header-depth)
138        (svnwiki-get-title-html env)
139        (format #f "</h~A>" initial-header-depth)
140        ((ul class "svnwiki-image-links")
141         (li ((a href (svnwiki-image-show-sizes-link env random-id)) "All sizes")))
142        ((div id (format #f "svnwikiImageSizes~A" random-id)))
143        ((script type "text/javascript" src (format #f "~A/xsvnwiki-helper/image/image" static-url)))
144        ((img src (format #f "~A-~A" (last (string-split path "/")) (apply max (svnwiki-image-default-size env)))
145              id (format #f "svnwikiImage~A" random-id)
146              ; TODO: Use svnwiki:title as the alt parameter.
147              alt (last (string-split path "/"))))
148        (let ((author (get-props-parents-first "svnwiki:image:author" path-in path #f))
149              (author-url (get-props-parents-first "svnwiki:image:author-url" path-in path #f)))
150          (cond
151            ((and author author-url)
152              (html-stream
153                (p (b "Author:")
154                   "\n"
155                   ((a href author-url) author))))
156            (author
157              (html-stream
158                (p (b "Author:") "\n" author)))
159            (else
160              stream-null)))
161        (let ((source (get-props-parents-first "svnwiki:image:source" path-in path #f)))
162          (if source
163            (html-stream
164              (p (b "Source:") "\n" ((a href source) source)))
165            stream-null))
166        (get-props-parents-first "svnwiki:image:description" path-in path stream-null)
167        (svnwiki-render-file-contents-tail env)))))
168
169(define (svnwiki-image-get-size env)
170  (let-from-environment env (path-in path)
171    (let* ((input (open-input-pipe
172                    (format #f "anytopnm ~A | head -2" (svnwiki-path-escape (svnwiki-make-pathname path-in path)))))
173           ; Skip image type (eg "P4"):
174           (type (read input))
175           (x (read input))
176           (y (read input)))
177      (close-input-port input)
178      (values x y))))
179
180(define *svnwiki-image-sizes-default* 500)
181
182(define *svnwiki-image-sizes-list*
183  (list 100 240 *svnwiki-image-sizes-default* 1024))
184
185(define (svnwiki-image-sizes x y)
186  (append
187    (map
188      (lambda (size)
189        (list (inexact->exact (round (* size (min 1.0 (/ x y)))))
190              (inexact->exact (round (* size (min 1.0 (/ y x)))))))
191      (filter (lambda (size)
192                (<= size (* 0.9 (max x y))))
193              *svnwiki-image-sizes-list*))
194    `((,x ,y))))
195
196(define svnwiki-image-sizes-env
197  (compose svnwiki-image-sizes svnwiki-image-get-size))
198
199; Supported image types: The first will be the default format to generate.
200
201(define *svnwiki-image-types*
202  '("png"
203    "jpeg"))
204
205(define (svnwiki-image-update env)
206  (let-from-environment env (path-in path path-out)
207    (svnwiki-report-progress env "Image update start: ~A~%" path)
208    (let* ((type-input (svnwiki-repository-property-get
209                         "svn:mime-type"
210                         (svnwiki-make-pathname path-in path)
211                         #f))
212           (type (if (member type-input *svnwiki-image-types*) type-input (car *svnwiki-image-types*))))
213      (receive (size-x size-y)
214               (svnwiki-image-get-size env)
215        (for-each
216          (lambda (size)
217            (svnwiki-report-progress env "Image render generate: ~A: ~A by ~A pixels~%" path (car size) (cadr size))
218            (system
219              (format #f "anytopnm ~A | pnmscale -xysize ~A ~A | pnmto~A >~A"
220                      (svnwiki-path-escape (svnwiki-make-pathname path-in path))
221                      (car size)
222                      (cadr size)
223                      type
224                      (svnwiki-path-escape
225                        (svnwiki-make-pathname
226                          path-out
227                          (format #f "~A-~A" path (max (car size) (cadr size)))
228                          type)))))
229          (svnwiki-image-sizes size-x size-y))))))
230
231(define (svnwiki-image-code-break env)
232  (let-from-environment env (params path-in path output-format path-out-real)
233    (let* ((src (assoc 'src params))
234           (file (and src
235                      (svnwiki-path-canonical
236                        (stream->string
237                          (link-canonical
238                            (string->stream path)
239                            (cdr src)))))))
240      (cond
241        ((not (eq? output-format 'html))
242          (warning "<image> tag does not support output format" output-format)
243          stream-null)
244        ((not src)
245          (html-stream
246            (p "Invalid &lt;image&gt; tag: Must specify src")))
247        ((not (file-exists? (svnwiki-make-pathname path-in file)))
248          (html-stream
249            (p "Invalid &lt;image&gt; tag: src (" (i (cdr src)) ") does not exist in the repository.")))
250        (else
251          (let* ((class (cdr (or (assoc 'class params) (cons #f "image"))))
252                 (title
253                   (cdr
254                     (or (assoc 'caption params)
255                         (cons #f (svnwiki-repository-property-get
256                                    "svnwiki:title"
257                                    (svnwiki-make-pathname path-in file)
258                                    (string->stream (last (string-split file "/"))))))))
259                 (link (make-link-url path-out-real file #f))
260                 (size-spec (stream->number (cdr (or (assoc 'size params) (cons #f (number->stream *svnwiki-image-sizes-default*))))))
261                 (size (svnwiki-image-size-pick-closest
262                         (svnwiki-image-sizes-env (environment env ((path file))))
263                         size-spec)))
264            (html-stream
265              ((div class class)
266               ((a href link title title)
267                ((img src (format #f "~A-~A" link (apply max size))
268                      class class
269                      width  (car size)
270                      height (cadr size))))
271               ((p class class
272                   style (format #f "max-width: ~Apx;" (car size)))
273                ((a href link title title) title))))))))))
274
275(define *extensions*
276  `((image (render-file-contents ,svnwiki-image-handler-render)
277           (update ,svnwiki-image-update)
278           (code-break ,svnwiki-image-code-break))))
Note: See TracBrowser for help on using the repository browser.