;;; phoghorn - Image gallery library ; ; Version 2.3 ; ; Copyright (c) 2005-2008 Peter Bex (Peter.Bex@xs4all.nl) ; All rights reserved. ; ; Redistribution and use in source and binary forms, with or without ; modification, are permitted provided that the following conditions ; are met: ; 1. Redistributions of source code must retain the above copyright ; notice, this list of conditions and the following disclaimer. ; 2. Redistributions in binary form must reproduce the above copyright ; notice, this list of conditions and the following disclaimer in the ; documentation and/or other materials provided with the distribution. ; 3. Neither the name of Peter Bex nor the names of any contributors may ; be used to endorse or promote products derived from this software ; without specific prior written permission. ; ; THIS SOFTWARE IS PROVIDED BY PETER BEX AND CONTRIBUTORS ``AS IS'' AND ANY ; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE ; DISCLAIMED. IN NO EVENT SHALL THE FOUNDATION OR CONTRIBUTORS BE LIABLE ; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY ; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF ; SUCH DAMAGE. (module phoghorn (gallery-dir gallery-var entry-var root-gallery-name max-thumb-dimensions thumb-dir gallery-url zoomed-url movie-image current-gallery current-entry-filename gallery-contents thumbnail thumbnail/epeg thumbnail/imlib2 galleries-up-to prev-entry next-entry phoghorn-rules) (import chicken scheme extras data-structures files posix) (require-extension srfi-1 srfi-13 spiffy intarweb uri-common sxml-transforms) (require-library epeg) (import (prefix epeg epeg:)) (require-library imlib2) (import (prefix imlib2 imlib2:)) ;; Config (define gallery-dir (make-parameter "galleries")) (define gallery-var (make-parameter 'gallery)) (define entry-var (make-parameter 'entry)) (define root-gallery-name (make-parameter "Galleries")) (define max-thumb-dimensions (make-parameter 100)) (define thumb-dir (make-parameter "thumbs")) (define gallery-url (make-parameter "index.ssp")) (define zoomed-url (make-parameter "zoomed.ssp")) ;; #f if you want the filename displayed (define movie-image (make-parameter "/pics/movie.jpg")) (define epeg-extensions '("jpeg" "jpg")) ;; This really is dependent on the loaders imlib2 has. Mebbe make it ;; a parameter as well? (define imlib-extensions '("gif" "bmp" "xpm" "png" "mng" "pbm" "tif" "tiff" "tga" "pic" "pcx" "dxf" "cgm" "cdr" "wmf" "eps" "emf" "pict" "yuv")) (define movie-extensions '("mpg" "mpeg" "avi" "ogg" "ogm" "vob" "asf" "wma" "wmv" "qt" "mov" "mp4" "vivo" "fli" "flc" "ani" "rm" "gl")) ;; XXX: use extensions or file magic/mimetypes? (define (allowed-filetype? filename) (any (cut string-ci=? (or (pathname-extension filename) "") <>) (append epeg-extensions imlib-extensions movie-extensions))) ;; Either the thumbs subdirectory is ok, or it can be created (define (thumbs-ok? dir) (let ((thumbdir (make-pathname dir (thumb-dir)))) (if (not (directory? thumbdir)) (handle-exceptions exn #f (create-directory thumbdir) #t) ((conjoin file-read-access? file-execute-access?) thumbdir)))) (define (current-gallery) (alist-ref (gallery-var) (or (uri-query (request-uri (current-request))) '()))) (define (current-entry-filename) (alist-ref (entry-var) (or (uri-query (request-uri (current-request))) '()))) (define (link-to path attribs) (uri->string (update-uri (uri-reference path) query: attribs))) (define (gallery-contents) (let* ((dir (local-file (current-gallery) #f)) (contents (map (cut make-pathname dir <>) (directory dir)))) (unless (thumbs-ok? dir) (error "Cannot create thumbnail directory!")) (receive (dirs files) (partition! directory? contents) ;; Not much use displaying stuff we can't access. ;; Also, we don't want "thumbs" to show up as a gallery. (let ((galleries (filter! (conjoin file-read-access? file-execute-access? (compose (cut string-ci<> (thumb-dir) <>) pathname-strip-directory)) dirs)) (entries (filter! (conjoin file-read-access? allowed-filetype?) files))) (values galleries entries))))) (define (thumbnail gallery entry) (let* ((ext (pathname-extension entry)) (match? (lambda (s) (string-ci=? ext s)))) (cond ((any match? epeg-extensions) (thumbnail/epeg gallery entry)) ((any match? imlib-extensions) (thumbnail/imlib2 gallery entry)) ((any match? movie-extensions) (movie-image))))) (define (thumb-width width height) (if (>= width height) (max-thumb-dimensions) (inexact->exact (round (* width (/ (max-thumb-dimensions) height)))))) ;; The height of the thumb is the width when the pic is rotated by 90 degrees.. (define (thumb-height width height) (thumb-width height width)) (define (remote-file gallery filename) (make-pathname (list (gallery-dir) gallery) filename)) ;; ;; Just throw an exception if we don't have access ;; (define (need-access path) (if (string-contains path "..") (abort (make-property-condition 'exn 'location 'need-access 'message "access denied" 'arguments (list path))) path)) ;; Else just return path like nothing happened (define (local-file gallery filename) (need-access (if filename (make-pathname (list (root-path) (pathname-directory (current-file)) (gallery-dir) gallery) filename) (make-pathname (list (root-path) (pathname-directory (current-file)) (gallery-dir)) gallery)))) (define (gallery-thumbs gallery) (make-pathname gallery (thumb-dir))) (define (thumbnail/epeg gallery entry) (let ((target-file (local-file (gallery-thumbs gallery) entry))) (unless (file-exists? target-file) (let ((img (epeg:image-open (local-file gallery entry)))) (receive (width height) (epeg:image-size img) (epeg:image-size-set! img (thumb-width width height) (thumb-height width height)) (epeg:image-file-output-set! img target-file) (epeg:image-encode img))))) (remote-file (gallery-thumbs gallery) entry)) ;; Imlib doesn't have loaders to save every type it can read, so we have ;; to pick some kind of standardised output format. Png is probably the ;; most suitable one because it is portable and supports alpha channels. ;; (the only thing we don't support right now is animations, this could ;; use the MNG format) (define (thumbnail/imlib2 gallery entry) (let ((target-file (local-file (gallery-thumbs gallery) (pathname-replace-extension entry "png")))) (unless (file-exists? target-file) (let* ((img (imlib2:image-load (local-file gallery entry))) (width (imlib2:image-width img)) (height (imlib2:image-height img)) (thumb (imlib2:image-scale img (thumb-width width height) (thumb-height width height)))) (imlib2:image-save thumb target-file)))) (remote-file (gallery-thumbs gallery) (pathname-replace-extension entry "png"))) ;; All gallery names from the root gallery dir up to this one (define (galleries-up-to gallery) (let ((current (pathname-strip-directory (or gallery "")))) (if (string=? current "") (list (root-gallery-name)) (let next ((gallery (pathname-directory gallery)) (galleries (list current))) (if (not gallery) (cons '(gallery-link #f) galleries) (next (pathname-directory gallery) (cons `(gallery-link ,gallery) galleries))))))) (define (prev-entry entry entries) (let ((pos (list-index (cut string-ci=? entry <>) entries))) (and (> pos 0) (list-ref entries (sub1 pos))))) (define (next-entry entry entries) (let ((pos (list-index (cut string-ci=? entry <>) entries))) (and (< pos (sub1 (length entries))) (list-ref entries (add1 pos))))) ;; End of library, the following is just convenience :) (define phoghorn-rules `((phoghorn-gallery *macro* . ,(lambda (tag) (receive (galleries entries) (gallery-contents) `(div (@ (class "phoghorn")) (phoghorn-breadcrumbs ,(current-gallery)) (gallery-list ,galleries) (gallery-entries ,entries))))) (gallery-entries *macro* . ,(lambda (tag entries) ;; Note that we're not checking if there's anything to display on ;; *this* page, but if there is anything to display *at all*. ;; We trust the pagination code to always display a valid page ;; of at least one item, if there are any items. (if (null? entries) "" ;; Empty