exhib/exhib.rkt

#!/usr/bin/env racket
#lang racket

;   A static web gallery generator, done right!
;   Copyright (C) 2017  Pelle Hjek
;
;   This program is free software: you can redistribute it and/or modify
;   it under the terms of the GNU Affero General Public License as published by
;   the Free Software Foundation, either version 3 of the License, or
;   (at your option) any later version.
;
;   This program is distributed in the hope that it will be useful,
;   but WITHOUT ANY WARRANTY; without even the implied warranty of
;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;   GNU Affero General Public License for more details.
;
;   You should have received a copy of the GNU Affero General Public License
;   along with this program.  If not, see <https://www.gnu.org/licenses/>.

(require xml)

(define usage
"Usage: exhibition FOLDER"
)

(define (basename path)
  (let
    ((base
        (call-with-values
          (lambda () (split-path (simplify-path path)))
          (lambda (path relative root?) relative))))
  ;need to ask this because split-path may output 'same
  (path->string (if (eq? base 'same) path base))))

(define (directory? path)
  (and
    (directory-exists? path)
    (not (regexp-match #px".git" path))))

(define (image? path)
  (and
    (file-exists? path)
    ;only find image files
    (regexp-match #px".+\\.(?i:jpg|png|gif|bmp|tiff)$" path)))

(define (text-file? path)
  (and
    (file-exists? path)
    ;only find image files
    (regexp-match #px".+\\.(?i:txt)$" path)))

(define (thumb? path)
    (regexp-match #px"thumb.png$" path))

(define (montage? path)
    (regexp-match #px"montage.png$" path))

(define (dir-filter-list fn dir)
  (filter
    fn
    (map
      (lambda (content) (build-path dir content))
           (directory-list dir))))

(define (discard what images)
  (filter
    (lambda (image) (not (what image))) images))

(define (thumb! path)
  ;make a thumb of an image
; a) create a thumb (as a side-effect)
; b) return the thumbnail s-expr with link to the original
  (let
    ((thumb (string-append (path->string path) ".thumb.png")))
    ;don't redo the thumb if it's already there
    (if (not (file-exists? thumb))
      (system*
                (find-executable-path "convert")
;                "-thumbnail" "x200"
                "-gravity" "center"
                "-resize" "200^>x200^>"
                "-crop" "200x200+0+0"
    ;imagemagick needs the FULL path
                (path->string path)
                thumb)
      #f)
    ;the link in the HTML should just be RELATIVE to the current folder
    `(span
        (a ((href ,(basename path)))
        (img
          ((src ,(basename thumb))
           (title ,(basename path))
           (alt ,(basename path))
           (class "image")))))))

(define (montage! path)
  ;do a 4x4 montage of a directory
  ;it's alright to redo the montages every time
  (let
    (
;the thumb should not be IN the folder it is of but OUTSIDE to enable recursive montages
     (montage (string-append (path->string path) ".montage.png"))
     (these-images (discard thumb? (dir-filter-list image? path)))
     )
    (apply system*
      (flatten
        `(,(find-executable-path "montage")
          ;these images may include montages, to make montage of thumbs
          ;but not thumbs because then the images go in there twice
         ,(take
            (map path->string these-images)
            (min 4 (length these-images)))
         "-background" "transparent"
         "-gravity" "Center"
;         "-resize" "100x100"
         "-resize" "100^>x100^>"
         "-crop" "100x100+0+0"
         "-geometry" "100x100"
         "-tile" "2x2"
;         "-title" ,(basename path)
         ,montage)))
    `(span (a ((href ,(string-append (basename path) "/index.html"))
               (style "display:inline-block;"))
        (img
          ((src ,(basename montage))
           (title ,(basename path))
           (alt ,(basename path))
           (class "folder")
           ))
           (div ((style "font-size: smaller; height: 3em; width: 200; word-wrap: break-word; overflow: scroll;")) ,(basename path))))
  ))


(define (index! path)
  (map index! (dir-filter-list directory? path))
  (display-to-file
    (xexpr->string
      `(html
         (head (title ,(basename path))
	       (link ((rel "stylesheet") (type "text/css") (href "http://lizdorton.tk/liz.css"))))
         (style "img {filter:brightness(0.7);transition-duration:0.5s}")
         (style "img:hover {filter:brightness(1.1);transition-duration:0s;border:1px solid white;}")
         (style ".image {border:1px solid gray;margin:2px;}")
         (style ".folder {border:1px solid red;margin:2px;}")
         (style "body {margin:0;margin-top:8em;text-align:center;}")
         (body
          (div
            ((style "background:white;color:black;position:fixed;top:0;z-index:10;width:100vw;"))
            (h1 
              (a ((href "../index.html")) "..") " "
              ,(basename path)))
          ,(cons 'div 
             (map (lambda (s) (list 'div s)) (map file->string
                (dir-filter-list text-file? path))))
          ,(cons 'div (map montage! (dir-filter-list directory? path)))
          ;do not make thumbs of thumbnails here
          ,(cons 'div (map thumb! (discard montage? (discard thumb? (dir-filter-list image? path)))))
          )))
    (string-append (path->string path) "/index.html") #:exists 'replace))

(define (main)
  (if (< 0 (vector-length (current-command-line-arguments)))
    ;run it if there's a folder given
      (time (vector-map index!
        (vector-map string->path
          (current-command-line-arguments)))
      "Done!")
    ;otherwise display usage
    usage))

;(discard montage? (images "/home/pelle/example/stuff"))
(main)