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

Last change on this file since 14432 was 14432, checked in by sjamaan, 11 years ago

Fix dependencies

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 sxml-transforms)
41
42(require-library epeg)
43(import (prefix epeg epeg:))
44(require-library imlib2)
45(import (prefix imlib2 imlib2:))
46
47;; Config
48(define gallery-dir (make-parameter "galleries"))
49(define gallery-var (make-parameter 'gallery))
50(define entry-var (make-parameter 'entry))
51(define root-gallery-name (make-parameter "Galleries"))
52(define max-thumb-dimensions (make-parameter 100))
53(define thumb-dir (make-parameter "thumbs"))
54(define gallery-url (make-parameter "index.ssp"))
55(define zoomed-url (make-parameter "zoomed.ssp"))
56;; #f if you want the filename displayed
57(define movie-image (make-parameter "/pics/movie.jpg"))
58
59(define epeg-extensions '("jpeg" "jpg"))
60
61;; This really is dependent on the loaders imlib2 has.  Mebbe make it
62;; a parameter as well?
63(define imlib-extensions '("gif" "bmp" "xpm" "png" "mng" "pbm" "tif" "tiff"
64                           "tga" "pic" "pcx" "dxf" "cgm" "cdr" "wmf" "eps"
65                           "emf" "pict" "yuv"))
66
67(define movie-extensions '("mpg" "mpeg" "avi" "ogg" "ogm" "vob" "asf" "wma"
68                           "wmv" "qt" "mov" "mp4" "vivo" "fli" "flc" "ani"
69                           "rm" "gl"))
70
71;; XXX: use extensions or file magic/mimetypes?
72(define (allowed-filetype? filename)
73  (any (cut string-ci=? (or (pathname-extension filename) "") <>)
74       (append epeg-extensions imlib-extensions movie-extensions)))
75
76;; Either the thumbs subdirectory is ok, or it can be created
77(define (thumbs-ok? dir)
78  (let ((thumbdir (make-pathname dir (thumb-dir))))
79    (if (not (directory? thumbdir))
80        (handle-exceptions exn #f (create-directory thumbdir) #t)
81        ((conjoin file-read-access? file-execute-access?) thumbdir))))
82
83(define (current-gallery)
84  (alist-ref (gallery-var) (or (uri-query (request-uri (current-request))) '())))
85
86(define (current-entry-filename)
87  (alist-ref (entry-var) (or (uri-query (request-uri (current-request))) '())))
88
89(define (link-to path attribs)
90  (uri->string (update-uri (uri-reference path) query: attribs)))
91
92(define (gallery-contents)
93  (let* ((dir (local-file (current-gallery) #f))
94         (contents (map (cut make-pathname dir <>) (directory dir))))
95    (unless (thumbs-ok? dir)
96      (error "Cannot create thumbnail directory!"))
97    (receive (dirs files)
98        (partition! directory? contents)
99      ;; Not much use displaying stuff we can't access.
100      ;; Also, we don't want "thumbs" to show up as a gallery.
101      (let ((galleries (filter!
102                        (conjoin file-read-access?
103                                 file-execute-access?
104                                 (compose (cut string-ci<> (thumb-dir) <>)
105                                          pathname-strip-directory))
106                        dirs))
107            (entries (filter! (conjoin file-read-access?
108                                       allowed-filetype?) files)))
109        (values galleries entries)))))
110
111(define (thumbnail gallery entry)
112  (let* ((ext (pathname-extension entry))
113         (match? (lambda (s) (string-ci=? ext s))))
114    (cond
115     ((any match? epeg-extensions)
116      (thumbnail/epeg gallery entry))
117     ((any match? imlib-extensions)
118      (thumbnail/imlib2 gallery entry))
119     ((any match? movie-extensions)
120      (movie-image)))))
121
122(define (thumb-width width height)
123  (if (>= width height)
124      (max-thumb-dimensions)
125      (inexact->exact
126        (round
127          (* width (/ (max-thumb-dimensions) height))))))
128
129;; The height of the thumb is the width when the pic is rotated by 90 degrees..
130(define (thumb-height width height)
131  (thumb-width height width))
132
133(define (remote-file gallery filename)
134  (make-pathname (list (gallery-dir) gallery) filename))
135
136;;
137;; Just throw an exception if we don't have access
138;;
139(define (need-access path)
140  (if  (string-contains path "..")
141       (abort (make-property-condition 'exn
142                                       'location
143                                       'need-access
144                                       'message
145                                       "access denied"
146                                       'arguments
147                                       (list path)))
148       path)) ;; Else just return path like nothing happened
149
150(define (local-file gallery filename)
151  (need-access
152   (if filename
153       (make-pathname (list (root-path)
154                            (pathname-directory (current-file))
155                            (gallery-dir)
156                            gallery)
157                      filename)
158       (make-pathname (list (root-path)
159                            (pathname-directory (current-file))
160                            (gallery-dir))
161                      gallery))))
162
163(define (gallery-thumbs gallery)
164  (make-pathname gallery (thumb-dir)))
165
166(define (thumbnail/epeg gallery entry)
167  (let ((target-file (local-file (gallery-thumbs gallery) entry)))
168    (unless (file-exists? target-file)
169      (let ((img (epeg:image-open (local-file gallery entry))))
170        (receive (width height)
171             (epeg:image-size img)
172          (epeg:image-size-set! img
173                                 (thumb-width width height)
174                                 (thumb-height width height))
175          (epeg:image-file-output-set! img target-file)
176          (epeg:image-encode img)))))
177  (remote-file (gallery-thumbs gallery) entry))
178
179;; Imlib doesn't have loaders to save every type it can read, so we have
180;; to pick some kind of standardised output format.  Png is probably the
181;; most suitable one because it is portable and supports alpha channels.
182;; (the only thing we don't support right now is animations, this could
183;; use the MNG format)
184(define (thumbnail/imlib2 gallery entry)
185  (let ((target-file (local-file (gallery-thumbs gallery)
186                                 (pathname-replace-extension entry "png"))))
187    (unless (file-exists? target-file)
188            (let* ((img    (imlib2:image-load (local-file gallery entry)))
189                   (width  (imlib2:image-width  img))
190                   (height (imlib2:image-height img))
191                   (thumb  (imlib2:image-scale img
192                                        (thumb-width width height)
193                                        (thumb-height width height))))
194              (imlib2:image-save thumb target-file))))
195  (remote-file (gallery-thumbs gallery)
196               (pathname-replace-extension entry "png")))
197
198;; All gallery names from the root gallery dir up to this one
199(define (galleries-up-to gallery)
200  (let ((current (pathname-strip-directory (or gallery ""))))
201    (if (string=? current "")
202        (list (root-gallery-name))
203        (let next ((gallery (pathname-directory gallery))
204                   (galleries (list current)))
205          (if (not gallery)
206              (cons '(gallery-link #f) galleries)
207              (next (pathname-directory gallery)
208                    (cons `(gallery-link ,gallery) galleries)))))))
209
210(define (prev-entry entry entries)
211  (let ((pos (list-index (cut string-ci=? entry <>) entries)))
212    (and (> pos 0) (list-ref entries (sub1 pos)))))
213
214(define (next-entry entry entries)
215  (let ((pos (list-index (cut string-ci=? entry <>) entries)))
216    (and (< pos (sub1 (length entries))) (list-ref entries (add1 pos)))))
217
218;; End of library, the following is just convenience :)
219(define phoghorn-rules
220  `((phoghorn-gallery *macro* .
221     ,(lambda (tag)
222        (receive (galleries entries)
223             (gallery-contents)
224          `(div (@ (class "phoghorn"))
225                (phoghorn-breadcrumbs ,(current-gallery))
226                (gallery-list ,galleries)
227                (gallery-entries ,entries)))))
228    (gallery-entries *macro* .
229      ,(lambda (tag entries)
230         ;; Note that we're not checking if there's anything to display on
231         ;; *this* page, but if there is anything to display *at all*.
232         ;; We trust the pagination code to always display a valid page
233         ;; of at least one item, if there are any items.
234         (if (null? entries)
235             ""  ;; Empty <ul>s are not allowed
236             `(paginate-list
237               (div (@ (class "photos"))
238                    (pagination-links)
239                    (ul (@ (class "entries"))
240                        (entries
241                         (li (entry))))
242                    (pagination-links))
243               ,(map (lambda (e)
244                       `(gallery-entry
245                         ,(current-gallery)
246                         ,(pathname-strip-directory e)))
247                     entries)))))
248    (gallery-list *macro* .
249      ,(lambda (tag galleries)
250         (if  (null? galleries)
251              "" ;; empty <ul>s are not allowed
252              `(ul (@ (class "galleries"))
253                   ,@(map (lambda (e)
254                            `(li (gallery-link
255                                  ,(make-pathname (current-gallery)
256                                                  (pathname-strip-directory e)))))
257                          galleries)))))
258    (gallery-link *macro* .
259      ,(lambda (tag gallery)
260         (if gallery
261             `(url ,(link-to (gallery-url)
262                             `((,(gallery-var) . ,gallery)))
263                   ,(pathname-strip-directory gallery))
264             `(url ,(gallery-url)
265                   ,(root-gallery-name)))))
266    (gallery-entry *macro* .
267      ,(lambda (tag gallery entry)
268         `(url (zoomed-url ,gallery ,entry)
269               (pic ,(thumbnail gallery entry)
270                    ,(pathname-file entry)))))
271    (zoomed-url *macro* .
272      ,(lambda (tag gallery entry)
273         (link-to (zoomed-url) `((,(gallery-var) . ,gallery)
274                                 (,(entry-var) . ,entry)))))
275    (phoghorn-breadcrumbs *macro* .
276     ,(lambda (tag gallery)
277        `(div (@ (class "breadcrumbs"))
278               ,(intersperse (galleries-up-to gallery) " > "))))
279    (phoghorn-zoomed-entry *macro* .
280     ,(lambda (tag)
281        (receive (_ full-entries)
282             (gallery-contents)
283          (let* ((entries (map pathname-strip-directory full-entries))
284                 (next (next-entry (current-entry-filename) entries))
285                 (prev (prev-entry (current-entry-filename) entries)))
286            `(div (@ (class "phoghorn"))
287                  (phoghorn-breadcrumbs
288                   ,(make-pathname (current-gallery)
289                                   (pathname-strip-extension (current-entry-filename))))
290                  (entry-navigation ,next ,prev)
291                  (zoomed-picture ,(current-gallery) ,(current-entry-filename))
292                  (entry-navigation ,next ,prev))))))
293    (entry-navigation *macro* .
294     ,(lambda (tag next prev)
295        `(div (@ (class "entry-navigation"))
296               (span (@ (class "prev"))
297                     ,(if prev
298                          `(url ,(link-to
299                                  (zoomed-url)
300                                  `((,(entry-var) . ,prev)
301                                    (,(gallery-var) . ,(current-gallery))))
302                                "prev")
303                          "prev"))
304               (span (@ (class "next"))
305                     ,(if next
306                          `(url ,(link-to
307                                  (zoomed-url)
308                                  `((,(entry-var) . ,next)
309                                    (,(gallery-var) . ,(current-gallery))))
310                                "next")
311                          "next")))))
312    (zoomed-picture *macro* .
313     ,(lambda (tag gallery entry)
314        (if (any (lambda (s)
315                   (string-ci=? (pathname-extension entry) s))
316                 movie-extensions)
317            `(movie ,(remote-file gallery entry) ,(pathname-file entry))
318            `(pic ,(remote-file gallery entry) ,(pathname-file entry)))))
319    (*text* . ,(lambda (tag str) str))
320    (*default* . ,(lambda x x))))
321)
Note: See TracBrowser for help on using the repository browser.