source: project/release/4/phoghorn/phoghorn.scm @ 13088

Last change on this file since 13088 was 13088, checked in by sjamaan, 12 years ago

Switch to uri-common for phoghorn and sxml-fu

File size: 11.7 KB
Line 
1;;; phoghorn - Image gallery library
2;
3; Version 2.3
4;
5; Copyright (c) 2005-2008 Peter Bex (Peter.Bex@xs4all.nl)
6; All rights reserved.
7;
8; Redistribution and use in source and binary forms, with or without
9; modification, are permitted provided that the following conditions
10; are met:
11; 1. Redistributions of source code must retain the above copyright
12;    notice, this list of conditions and the following disclaimer.
13; 2. Redistributions in binary form must reproduce the above copyright
14;    notice, this list of conditions and the following disclaimer in the
15;    documentation and/or other materials provided with the distribution.
16; 3. Neither the name of Peter Bex nor the names of any contributors may
17;    be used to endorse or promote products derived from this software
18;    without specific prior written permission.
19;
20; THIS SOFTWARE IS PROVIDED BY PETER BEX AND CONTRIBUTORS ``AS IS'' AND ANY
21; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
22; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
23; DISCLAIMED.  IN NO EVENT SHALL THE FOUNDATION OR CONTRIBUTORS BE LIABLE
24; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
25; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
26; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
27; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
28; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
29; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
30; SUCH DAMAGE.
31
32(module phoghorn
33 (gallery-dir gallery-var entry-var root-gallery-name
34  max-thumb-dimensions thumb-dir gallery-url zoomed-url movie-image
35  current-gallery current-entry-filename gallery-contents
36  thumbnail thumbnail/epeg thumbnail/imlib2
37  galleries-up-to prev-entry next-entry phoghorn-rules)
38
39(import chicken scheme extras data-structures files posix)
40(require-extension srfi-1 srfi-13 spiffy intarweb uri-common
41                   sxml-transforms)
42
43(require-library epeg)
44(import (prefix epeg epeg:))
45(require-library imlib2)
46(import (prefix imlib2 imlib2:))
47
48;; Config
49(define gallery-dir (make-parameter "galleries"))
50(define gallery-var (make-parameter 'gallery))
51(define entry-var (make-parameter 'entry))
52(define root-gallery-name (make-parameter "Galleries"))
53(define max-thumb-dimensions (make-parameter 100))
54(define thumb-dir (make-parameter "thumbs"))
55(define gallery-url (make-parameter "index.ssp"))
56(define zoomed-url (make-parameter "zoomed.ssp"))
57;; #f if you want the filename displayed
58(define movie-image (make-parameter "/pics/movie.jpg"))
59
60(define epeg-extensions '("jpeg" "jpg"))
61
62;; This really is dependent on the loaders imlib2 has.  Mebbe make it
63;; a parameter as well?
64(define imlib-extensions '("gif" "bmp" "xpm" "png" "mng" "pbm" "tif" "tiff"
65                           "tga" "pic" "pcx" "dxf" "cgm" "cdr" "wmf" "eps"
66                           "emf" "pict" "yuv"))
67
68(define movie-extensions '("mpg" "mpeg" "avi" "ogg" "ogm" "vob" "asf" "wma"
69                           "wmv" "qt" "mov" "mp4" "vivo" "fli" "flc" "ani"
70                           "rm" "gl"))
71
72;; XXX: use extensions or file magic/mimetypes?
73(define (allowed-filetype? filename)
74  (any (cut string-ci=? (or (pathname-extension filename) "") <>)
75       (append epeg-extensions imlib-extensions movie-extensions)))
76
77;; Either the thumbs subdirectory is ok, or it can be created
78(define (thumbs-ok? dir)
79  (let ((thumbdir (make-pathname dir (thumb-dir))))
80    (if (not (directory? thumbdir))
81        (handle-exceptions exn #f (create-directory thumbdir) #t)
82        ((conjoin file-read-access? file-execute-access?) thumbdir))))
83
84(define (current-gallery)
85  (alist-ref (gallery-var) (or (uri-query (request-uri (current-request))) '())))
86
87(define (current-entry-filename)
88  (alist-ref (entry-var) (or (uri-query (request-uri (current-request))) '())))
89
90(define (link-to path attribs)
91  (uri->string (update-uri (uri-reference path) query: attribs)))
92
93(define (gallery-contents)
94  (let* ((dir (local-file (current-gallery) #f))
95         (contents (map (cut make-pathname dir <>) (directory dir))))
96    (unless (thumbs-ok? dir)
97      (error "Cannot create thumbnail directory!"))
98    (receive (dirs files)
99        (partition! directory? contents)
100      ;; Not much use displaying stuff we can't access.
101      ;; Also, we don't want "thumbs" to show up as a gallery.
102      (let ((galleries (filter!
103                        (conjoin file-read-access?
104                                 file-execute-access?
105                                 (compose (cut string-ci<> (thumb-dir) <>)
106                                          pathname-strip-directory))
107                        dirs))
108            (entries (filter! (conjoin file-read-access?
109                                       allowed-filetype?) files)))
110        (values galleries entries)))))
111
112(define (thumbnail gallery entry)
113  (let* ((ext (pathname-extension entry))
114         (match? (lambda (s) (string-ci=? ext s))))
115    (cond
116     ((any match? epeg-extensions)
117      (thumbnail/epeg gallery entry))
118     ((any match? imlib-extensions)
119      (thumbnail/imlib2 gallery entry))
120     ((any match? movie-extensions)
121      (movie-image)))))
122
123(define (thumb-width width height)
124  (if (>= width height)
125      (max-thumb-dimensions)
126      (inexact->exact
127        (round
128          (* width (/ (max-thumb-dimensions) height))))))
129
130;; The height of the thumb is the width when the pic is rotated by 90 degrees..
131(define (thumb-height width height)
132  (thumb-width height width))
133
134(define (remote-file gallery filename)
135  (make-pathname (list (gallery-dir) gallery) filename))
136
137;;
138;; Just throw an exception if we don't have access
139;;
140(define (need-access path)
141  (if  (string-contains path "..")
142       (abort (make-property-condition 'exn
143                                       'location
144                                       'need-access
145                                       'message
146                                       "access denied"
147                                       'arguments
148                                       (list path)))
149       path)) ;; Else just return path like nothing happened
150
151(define (local-file gallery filename)
152  (need-access
153   (if filename
154       (make-pathname (list (root-path)
155                            (pathname-directory (current-file))
156                            (gallery-dir)
157                            gallery)
158                      filename)
159       (make-pathname (list (root-path)
160                            (pathname-directory (current-file))
161                            (gallery-dir))
162                      gallery))))
163
164(define (gallery-thumbs gallery)
165  (make-pathname gallery (thumb-dir)))
166
167(define (thumbnail/epeg gallery entry)
168  (let ((target-file (local-file (gallery-thumbs gallery) entry)))
169    (unless (file-exists? target-file)
170      (let ((img (epeg:image-open (local-file gallery entry))))
171        (receive (width height)
172             (epeg:image-size img)
173          (epeg:image-size-set! img
174                                 (thumb-width width height)
175                                 (thumb-height width height))
176          (epeg:image-file-output-set! img target-file)
177          (epeg:image-encode img)))))
178  (remote-file (gallery-thumbs gallery) entry))
179
180;; Imlib doesn't have loaders to save every type it can read, so we have
181;; to pick some kind of standardised output format.  Png is probably the
182;; most suitable one because it is portable and supports alpha channels.
183;; (the only thing we don't support right now is animations, this could
184;; use the MNG format)
185(define (thumbnail/imlib2 gallery entry)
186  (let ((target-file (local-file (gallery-thumbs gallery)
187                                 (pathname-replace-extension entry "png"))))
188    (unless (file-exists? target-file)
189            (let* ((img    (imlib2:image-load (local-file gallery entry)))
190                   (width  (imlib2:image-width  img))
191                   (height (imlib2:image-height img))
192                   (thumb  (imlib2:image-scale img
193                                        (thumb-width width height)
194                                        (thumb-height width height))))
195              (imlib2:image-save thumb target-file))))
196  (remote-file (gallery-thumbs gallery)
197               (pathname-replace-extension entry "png")))
198
199;; All gallery names from the root gallery dir up to this one
200(define (galleries-up-to gallery)
201  (let ((current (pathname-strip-directory (or gallery ""))))
202    (if (string=? current "")
203        (list (root-gallery-name))
204        (let next ((gallery (pathname-directory gallery))
205                   (galleries (list current)))
206          (if (not gallery)
207              (cons '(gallery-link #f) galleries)
208              (next (pathname-directory gallery)
209                    (cons `(gallery-link ,gallery) galleries)))))))
210
211(define (prev-entry entry entries)
212  (let ((pos (list-index (cut string-ci=? entry <>) entries)))
213    (and (> pos 0) (list-ref entries (sub1 pos)))))
214
215(define (next-entry entry entries)
216  (let ((pos (list-index (cut string-ci=? entry <>) entries)))
217    (and (< pos (sub1 (length entries))) (list-ref entries (add1 pos)))))
218
219;; End of library, the following is just convenience :)
220(define phoghorn-rules
221  `((phoghorn-gallery *macro* .
222     ,(lambda (tag)
223        (receive (galleries entries)
224             (gallery-contents)
225          `(div (@ (class "phoghorn"))
226                (phoghorn-breadcrumbs ,(current-gallery))
227                (gallery-list ,galleries)
228                (gallery-entries ,entries)))))
229    (gallery-entries *macro* .
230      ,(lambda (tag entries)
231         ;; Note that we're not checking if there's anything to display on
232         ;; *this* page, but if there is anything to display *at all*.
233         ;; We trust the pagination code to always display a valid page
234         ;; of at least one item, if there are any items.
235         (if (null? entries)
236             ""  ;; Empty <ul>s are not allowed
237             `(paginate-list
238               (div (@ (class "photos"))
239                    (pagination-links)
240                    (ul (@ (class "entries"))
241                        (entries
242                         (li (entry))))
243                    (pagination-links))
244               ,(map (lambda (e)
245                       `(gallery-entry
246                         ,(current-gallery)
247                         ,(pathname-strip-directory e)))
248                     entries)))))
249    (gallery-list *macro* .
250      ,(lambda (tag galleries)
251         (if  (null? galleries)
252              "" ;; empty <ul>s are not allowed
253              `(ul (@ (class "galleries"))
254                   ,@(map (lambda (e)
255                            `(li (gallery-link
256                                  ,(make-pathname (current-gallery)
257                                                  (pathname-strip-directory e)))))
258                          galleries)))))
259    (gallery-link *macro* .
260      ,(lambda (tag gallery)
261         (if gallery
262             `(url ,(link-to (gallery-url)
263                             `((,(gallery-var) . ,gallery)))
264                   ,(pathname-strip-directory gallery))
265             `(url ,(gallery-url)
266                   ,(root-gallery-name)))))
267    (gallery-entry *macro* .
268      ,(lambda (tag gallery entry)
269         `(url (zoomed-url ,gallery ,entry)
270               (pic ,(thumbnail gallery entry)
271                    ,(pathname-file entry)))))
272    (zoomed-url *macro* .
273      ,(lambda (tag gallery entry)
274         (link-to (zoomed-url) `((,(gallery-var) . ,gallery)
275                                 (,(entry-var) . ,entry)))))
276    (phoghorn-breadcrumbs *macro* .
277     ,(lambda (tag gallery)
278        `(div (@ (class "breadcrumbs"))
279               ,(intersperse (galleries-up-to gallery) " > "))))
280    (phoghorn-zoomed-entry *macro* .
281     ,(lambda (tag)
282        (receive (_ full-entries)
283             (gallery-contents)
284          (let* ((entries (map pathname-strip-directory full-entries))
285                 (next (next-entry (current-entry-filename) entries))
286                 (prev (prev-entry (current-entry-filename) entries)))
287            `(div (@ (class "phoghorn"))
288                  (phoghorn-breadcrumbs
289                   ,(make-pathname (current-gallery)
290                                   (pathname-strip-extension (current-entry-filename))))
291                  (entry-navigation ,next ,prev)
292                  (zoomed-picture ,(current-gallery) ,(current-entry-filename))
293                  (entry-navigation ,next ,prev))))))
294    (entry-navigation *macro* .
295     ,(lambda (tag next prev)
296        `(div (@ (class "entry-navigation"))
297               (span (@ (class "prev"))
298                     ,(if prev
299                          `(url ,(link-to
300                                  (zoomed-url)
301                                  `((,(entry-var) . ,prev)
302                                    (,(gallery-var) . ,(current-gallery))))
303                                "prev")
304                          "prev"))
305               (span (@ (class "next"))
306                     ,(if next
307                          `(url ,(link-to
308                                  (zoomed-url)
309                                  `((,(entry-var) . ,next)
310                                    (,(gallery-var) . ,(current-gallery))))
311                                "next")
312                          "next")))))
313    (zoomed-picture *macro* .
314     ,(lambda (tag gallery entry)
315        (if (any (lambda (s)
316                   (string-ci=? (pathname-extension entry) s))
317                 movie-extensions)
318            `(movie ,(remote-file gallery entry) ,(pathname-file entry))
319            `(pic ,(remote-file gallery entry) ,(pathname-file entry)))))
320    (*text* . ,(lambda (tag str) str))
321    (*default* . ,(lambda x x))))
322)
Note: See TracBrowser for help on using the repository browser.