-
Notifications
You must be signed in to change notification settings - Fork 0
/
sig.scm
executable file
·847 lines (753 loc) · 32.7 KB
/
sig.scm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
#!/usr/bin/guile \
-e main -s
!#
;;; sig -- simple image gallery. Eike Kettner, 2015
;; sig is free software: you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; sig 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 General Public
;; License for more details.
;; You should have received a copy of the GNU General Public License
;; along with sig. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This script creates a directory containing a html file and a bunch
;; of javascript and css files. The html file shows a gallery of images
;; from a known directory.
;;
;; $ sig create mygallery
;; $ cd mygallery
;; $ sig make -i /folder/with/images
(use-modules
(ice-9 format)
(ice-9 futures)
(ice-9 getopt-long)
(ice-9 popen)
(ice-9 rdelim)
(ice-9 ftw))
;; configuration ------------------------------------------------------
;; javascript and css files
;;
;; These can be urls or path names. If a relative path name is
;; specified they are inserted verbatim into the html. If a absolute
;; path is given, it is symlinked into a local location. If this is a
;; recognized url it is downloaded using curl. "
(define *sig/resource-list*
'((#:js . ("http://code.jquery.com/jquery-2.1.3.min.js"
"https://blueimp.github.io/Gallery/js/jquery.blueimp-gallery.min.js"
"https://raw.githubusercontent.com/blueimp/Bootstrap-Image-Gallery/master/js/bootstrap-image-gallery.min.js"))
(#:css . ("http://netdna.bootstrapcdn.com/bootstrap/3.3.4/css/bootstrap.min.css"
"https://raw.githubusercontent.com/blueimp/Gallery/master/css/blueimp-gallery.min.css"
"https://raw.githubusercontent.com/blueimp/Bootstrap-Image-Gallery/master/css/bootstrap-image-gallery.min.css"))
(#:fonts . ("http://netdna.bootstrapcdn.com/bootstrap/3.3.4/fonts/glyphicons-halflings-regular.eot"
"http://netdna.bootstrapcdn.com/bootstrap/3.3.4/fonts/glyphicons-halflings-regular.svg"
"http://netdna.bootstrapcdn.com/bootstrap/3.3.4/fonts/glyphicons-halflings-regular.ttf"
"http://netdna.bootstrapcdn.com/bootstrap/3.3.4/fonts/glyphicons-halflings-regular.woff"
"http://netdna.bootstrapcdn.com/bootstrap/3.3.4/fonts/glyphicons-halflings-regular.woff2"))
(#:img . ("https://raw.githubusercontent.com/blueimp/Gallery/master/img/error.png"
"https://raw.githubusercontent.com/blueimp/Gallery/master/img/error.svg"
"https://raw.githubusercontent.com/blueimp/Gallery/master/img/play-pause.png"
"https://raw.githubusercontent.com/blueimp/Gallery/master/img/play-pause.svg"
"https://raw.githubusercontent.com/blueimp/Gallery/master/img/loading.gif"
"https://raw.githubusercontent.com/blueimp/Gallery/master/img/video-play.png"
"https://raw.githubusercontent.com/blueimp/Gallery/master/img/video-play.svg"))))
(define *sig/supported-images*
'("jpg" "png" "gif"))
(define *sig/supported-videos*
'("mp4" "ogv" "webm" "mov" "avi"))
(define *sig/supported-files*
(append *sig/supported-images* *sig/supported-videos*))
(define *sig/date-format* "%Y-%m-%d %H:%M")
(define *sig/curl* "curl")
(define *sig/convert* "convert")
(define *sig/composite* "composite")
(define *sig/jhead* "jhead")
(define *sig/ffmpeg* "ffmpeg")
(define (sig/resources key)
(assq-ref *sig/resource-list* key))
(define *sig/default-template-file* "index-template.html")
(define *sig/more-css* ".blueimp-gallery > .download {
position: absolute;
top: 15px;
right: 45px;
display: none;
}
.blueimp-gallery-controls > .download {
display: block;
}")
(define *sig/more-js* "
$('#blueimp-gallery').on('slide', function(event, index, slide) {
var ref = $(this).data('gallery').list[index].getAttribute('data-download'),
node = $(event.target).find('.download');
if (ref) {
node.attr('href', ref);
}
});
")
(define *sig/template* "<html>
<head>
<title>Gallery</title>
<meta charset=\"utf-8\">
<meta name=\"viewport\" content=\"width=device-width, initial-scale=1\" />
<!-- ${sig-head} -->
</head>
<body>
<!-- ${sig-box} -->
<div class=\"container\">
<h1>Gallery</h1>
<!-- ${sig-links} -->
</div>
<!-- ${sig-js} -->
</body>
</html> ")
(define (sig/template-lightbox download-links?)
(string-append
"<div id=\"blueimp-gallery\" class=\"blueimp-gallery\" data-use-bootstrap-modal=\"false\">
<!-- The container for the modal slides -->
<div class=\"slides\"></div>
<!-- Controls for the borderless lightbox -->
<h3 class=\"title\"></h3>
"
(if download-links?
" <a class=\"download btn btn-primary\" download>
<i class=\"glyphicon glyphicon-download\"></i>
Download
</a>" "")
"<a class=\"prev\">‹</a>
<a class=\"next\">›</a>
<a class=\"close\">×</a>
<a class=\"play-pause\"></a>
<ol class=\"indicator\"></ol>
<!-- The modal dialog, which will be used to wrap the lightbox content -->
<div class=\"modal fade\">
<div class=\"modal-dialog\">
<div class=\"modal-content\">
<div class=\"modal-header\">
<button type=\"button\" class=\"close\" aria-hidden=\"true\">×</button>
<h4 class=\"modal-title\"></h4>
</div>
<div class=\"modal-body next\"></div>
<div class=\"modal-footer\">
<button type=\"button\" class=\"btn btn-default pull-left prev\">
<i class=\"glyphicon glyphicon-chevron-left\"></i>
Previous
</button>
<button type=\"button\" class=\"btn btn-primary next\">
Next
<i class=\"glyphicon glyphicon-chevron-right\"></i>
</button>
</div>
</div>
</div>
</div>
</div>"))
(define (sig/version)
(display "sig 0.1.0a"))
(fluid-set! %default-port-encoding "UTF-8")
;; ------------ utilities
(define* (sig/errmsg formatstr . args)
(apply format (current-error-port) formatstr args))
(define (sig/absolute-path? name)
"Return true if NAME is an absolute path"
(absolute-file-name? name))
(define* (sig/path first . next)
"Combines the arguments to a file system path name."
(if (equal? first ".")
(apply sig/path next)
(if (or (not next) (null? next))
first
(apply sig/path
(string-append first
file-name-separator-string
(car next))
(cdr next)))))
(define (sig/mkdirs! . names)
"Creates a nested directory from the given list."
(if (and names (not (null? names)))
(let ((head (car names))
(tail (cdr names)))
(when (and head
(not (file-exists? head))
(not (equal? "." head)))
(mkdir head))
(if (not (null? tail))
(apply sig/mkdirs! (sig/path head (car tail)) (cdr tail))))))
(define (sig/url? name)
"Return true if NAME seems to be a remote url."
(let ((schemes '("http" "https" "ftp"))
(idx (string-contains name "://")))
(and idx (> idx 0)
(member (string-take name idx) schemes)
#t)))
(define (sig/dir? name)
(file-exists? (sig/path name ".")))
(define (sig/empty-dir? dir)
(let ((contents (scandir dir)))
(or (not contents)
(equal? 2 (length contents)))))
(define (sig/delete-existing-file! filename)
(when (file-exists? filename)
(delete-file filename)))
(define (sig/delete-rec! dir)
"Deletes DIR recursively. Return the number of files and directories
removed."
(define (enter? name . rest) #t)
(define (leaf name stat result)
(format #t "… delete file ~a ~%" name)
(delete-file name)
(+ result 1))
(define (none name stat result) result)
(define (up name stat result)
(format #t "… delete directory ~a ~%" name)
(rmdir name)
(+ result 1))
(define (error name stat errno result)
(sig/errmsg "Error: ~a: ~a~%" name (strerror errno))
result)
(format #t "Delete ~a recursively … ~%" dir)
(let ((n (file-system-fold enter? leaf none up none error 0 dir)))
(format #t "Removed ~d files." n)))
(define (sig/sig-directory? dir)
(and (file-exists? (sig/path dir "resources"))
(file-exists? (sig/path dir "thumbnails"))
(file-exists? (sig/path dir "images"))))
(define (sig/string->keyword str)
(define (space->dash s)
(string-map (lambda (c)
(if (equal? c #\space) #\- c))
s))
(symbol->keyword
(string-ci->symbol
(string-downcase
(space->dash (string-trim-both str))))))
(define (sig/select keys alist)
"Filter ALIST and keep only elements whose key is in the list
KEYS."
(filter (lambda (pair)
(member (car pair) keys))
alist))
(define (sig/as-future f)
"Return a function that returns a future applying its arguments to F."
(lambda (. args)
(future (apply f args))))
(define (sig/file-extension filename)
(if (or (equal? filename ".")
(equal? filename "..")
(sig/dir? filename)
(not (string-contains filename ".")))
#f
(string-downcase
(car (last-pair (string-split filename #\.))))))
(define (sig/basename-no-extension filename)
(let ((base (basename filename))
(ext (sig/file-extension filename)))
(string-drop-right base (1+ (string-length ext)))))
(define* (sig/supported-file? filename #:optional type)
(let ((known (cond ((eq? type 'video) *sig/supported-videos*)
((eq? type 'image) *sig/supported-images*)
(#t *sig/supported-files*))))
(member (sig/file-extension filename) known)))
;; ---------- sig functions
(define* ((sig/make-resource-path resourcedir ext) resource)
"Return the path where RESOURCE is stored."
(let* ((name (basename resource)))
(sig/path resourcedir ext name)))
(define* ((sig/get-resource! resourcedir ext) resource)
"Download or symlink a RESOURCE into RESOURCEDIR."
(let ((newpath ((sig/make-resource-path resourcedir ext) resource)))
(sig/mkdirs! resourcedir ext)
(cond ((sig/absolute-path? resource)
(begin
(format #t "Symlinking ~a → ~a~%" resource newpath)
(symlink resource newpath)
newpath))
((sig/url? resource)
(let ((cmd (format #f "~a -o ~a ~a" *sig/curl* newpath resource)))
(format #t "Downloading ~a to ~a~%" resource newpath)
(if (equal? (system cmd) 0)
newpath
(begin
(sig/errmsg "Failed to download ~a!~%" resource)
(throw 'download-failed)))))
(#t resource))))
(define (sig/remove-gallery-files! directory)
"Removes all gallery files."
(when (sig/sig-directory? directory)
(delete-file (sig/path directory "index.html"))
(sig/delete-rec! (sig/path directory "resources"))
(sig/delete-rec! (sig/path directory "thumbnails"))
(sig/delete-rec! (sig/path directory "images"))
#t))
(define (sig/create-gallery-dirs! directory)
(for-each
(lambda (name)
(display (format #f "Creating directory ~a ... ~%"
(sig/path directory name)))
(sig/mkdirs! directory name))
'("resources" "images" "thumbnails"))
#t)
(define (sig/exif-properties filename)
"Return properties of FILENAME found by the jhead program."
(define (split-line line)
(let ((parts (string-split line #\:)))
(cons (sig/string->keyword (car parts))
(string-trim-both (string-join (cdr parts) ":")))))
(define (parse data)
(let* ((lines (string-split data #\newline))
(props (map split-line
(filter (compose not string-null?) lines))))
props))
(define* ((change-keys keymap) pair)
(let* ((key (car pair))
(key2 (assq-ref keymap key)))
(if key2 (cons key2 (cdr pair)) pair)))
(let* ((keys '(#:camera-make #:camera-model #:date/time #:resolution))
(keymap '((#:date/time . #:image-timestamp)))
(cmd (format #f "LC_ALL=C ~a -q ~a" *sig/jhead* filename))
(data (if (sig/supported-file? filename 'image)
(let ((port (open-input-pipe cmd)))
(with-input-from-port port
(lambda () (parse (read-string port)))))
'())))
(map (change-keys keymap)
(filter (lambda (pair)
(or (not (string? (cdr pair)))
(not (string-null? (cdr pair)))))
(sig/select keys data)))))
(define (sig/make-basename dir filename)
"Constructs a base name for FILENAME. If FILENAME is a direct child
of DIR this is the same as `basename'. Strip DIR from FILENAME which
is expected to have DIR as prefix and prepend any subdirectory to the
filename."
(let* ((basename (basename filename))
(withdirs (substring filename (1+ (string-length dir)))))
(if (equal? basename withdirs)
basename
(string-join (string-split withdirs (string-ref file-name-separator-string 0)) "-"))))
(define* ((sig/image-properties original directory) filename)
"Return an alist of properties of the given file. ORIGINAL is the
directory containing original images, FILENAME is a child of that
directory. DIRECTORY is the root directory of the gallery."
(define (make-name ext)
(string-append (sig/basename-no-extension filename) "." ext))
(let* ((exif (sig/exif-properties filename))
(ext (sig/file-extension filename))
(media (cond ((member ext *sig/supported-images*) 'image)
((member ext *sig/supported-videos*) 'video)
(#t 'unkown)))
(video? (eq? media 'video))
(basename (sig/make-basename original filename))
(info (stat filename)))
(append `((#:file-name . ,filename)
(#:base-name . ,basename)
(#:directory . ,directory)
(#:image . ,(sig/path directory "images" (if video? (make-name "webm") basename)))
(#:thumbnail . ,(sig/path directory "thumbnails" (if video? (make-name "jpg") basename)))
(#:size . ,(stat:size info))
(#:mtime . ,(stat:mtime info))
(#:file-type . ,(stat:type info))
(#:media . ,media))
exif)))
(define* (sig/make-thumbnail! filename out #:optional (size 150))
"Create a square thumbnail from the given image file. Save it to out
path."
(let* ((resz (* size 2))
(cmd (format #f "~a ~a -thumbnail x~d -resize '~dx<'\
-resize 50% -gravity center -crop ~dx~d+0+0 +repage ~a"
*sig/convert* filename resz resz size size out)))
(when (not (equal? 0 (system cmd)))
(throw 'thumbnail-failed))
#t))
(define* (sig/resize-image! filename out #:optional (size 1200))
"Resize the give image and save it to out."
(let* ((resize (format #f "~a -resize ~d ~a ~a"
*sig/convert* size filename out))
(autorot (format #f "~a -q -autorot ~a" *sig/jhead* out))
(ext (sig/file-extension filename)))
(when (not (equal? 0 (system resize)))
(throw 'resize))
(when (equal? ext "jpg")
(when (not (equal? 0 (system autorot)))
(throw 'autorot)))
#t))
(define* (sig/convert-video! filename out #:optional (size "640x360"))
(let ((ffmpeg (format #f "~a -loglevel quiet -y -i ~a -c:a libvorbis \
-ac 2 -ar 44100 -q:a 5 -q:v 5 -s ~a ~a"
*sig/ffmpeg*
filename
size
out))
(ext (sig/file-extension filename)))
(when (not (equal? ext "webm"))
(system ffmpeg))))
(define* (sig/video-thumbnail! filename out #:optional (size 150) overlay)
(let ((ffmpeg (format #f "~a -loglevel quiet -y -i ~a -an -ss 4 -s ~dx~d ~a"
*sig/ffmpeg*
filename
size size
out))
(composite (format #f "~a -gravity center ~a ~a ~a"
*sig/composite* (or overlay "") out out)))
(system ffmpeg) ;; exits non-zero but file is there and looks good
(if (file-exists? out)
(when overlay
(if (file-exists? overlay)
(system composite)
(sig/errmsg "Overlay image does not exist: ~a~%" overlay)))
(sig/errmsg "Cannot create video thumbnail from ~a~%" filename))))
(define* ((sig/do-file! size thumbsize overwrite) props)
"Create a thumbnail and resized version of the given image."
(let* ((filename (assq-ref props #:file-name))
(basename (assq-ref props #:base-name))
(media (assq-ref props #:media))
(directory (assq-ref props #:directory))
(thumbpath (assq-ref props #:thumbnail))
(imgpath (assq-ref props #:image)))
(when overwrite
(sig/delete-existing-file! imgpath)
(sig/delete-existing-file! thumbpath))
(cond ((eq? media 'image)
(begin
(when (not (file-exists? imgpath))
(sig/resize-image! filename imgpath size))
(when (not (file-exists? thumbpath))
(sig/make-thumbnail! imgpath thumbpath thumbsize))))
((eq? media 'video)
(begin
(when (not (file-exists? imgpath))
(sig/convert-video! filename imgpath))
(when (not (file-exists? thumbpath))
(sig/video-thumbnail! imgpath thumbpath thumbsize
(sig/path directory "resources" "img" "video-play.png")))))
(#t (format #t "~a: Don't know what to do with file.~%" filename)))
(display ".")
props))
(define (sig/create! directory)
"Creates a new gallery outline. This creates several directories and
gets javascript and css resources."
(format #t "Creating new gallery in ~a~%" directory)
(sig/create-gallery-dirs! directory)
(let* ((resourcedir (sig/path directory "resources"))
(get-js (sig/get-resource! resourcedir "js"))
(get-css (sig/get-resource! resourcedir "css"))
(get-fonts (sig/get-resource! resourcedir "fonts"))
(get-img (sig/get-resource! resourcedir "img")))
(append (map get-js (sig/resources #:js))
(map get-img (sig/resources #:img))
(map get-fonts (sig/resources #:fonts))
(map get-css (sig/resources #:css)))))
(define* (sig/make-check! directory original #:optional (create-gallery? #t))
"Check directory if a make would make sense."
(when (sig/empty-dir? (sig/path directory original))
(sig/errmsg "ERROR: There is no folder '~a' containing images.~%" original)
(throw 'no-images))
(when (not (sig/sig-directory? directory))
(if create-gallery?
(begin
(format #t "The directory ~a does not seem to be a gallery directory." directory)
(format #t "Creating one via `sig create'.~%")
(sig/create! directory))
(throw 'not-a-gallery-dir))))
(define (sig/sort-properties props)
(define (props-less-by-time a b)
(let ((itime-a (assq-ref a #:image-timestamp))
(itime-b (assq-ref b #:image-timestamp))
(mtime-a (assq-ref a #:mtime))
(mtime-b (assq-ref b #:mtime)))
(if (and itime-a itime-b)
(string< itime-a itime-b)
(< mtime-a mtime-b))))
(sort-list props props-less-by-time))
(define* (sig/filesize-hr bytes #:optional (unit #:bytes) (factor 1024))
(define (roundsize n)
(/ (round (exact->inexact (* n 10))) 10))
(let* ((nunit (if (eq? unit #:bytes) #:kb #:mb))
(next (/ bytes factor)))
(if (or (eq? unit #:mb) (< next 1))
(cons (roundsize bytes) unit)
(sig/filesize-hr next nunit))))
(define* (sig/filesize-str bytes #:optional (unit #:bytes))
(let ((size (sig/filesize-hr bytes unit)))
(format #f "~s~a" (car size) (symbol->string (keyword->symbol (cdr size))))))
(define (sig/make-image-title props)
"Create a string used as title for an image."
(let ((name (assq-ref props #:base-name))
(itime (assq-ref props #:image-timestamp))
(mtime (assq-ref props #:mtime))
(res (assq-ref props #:resolution)))
(format #f "~a, ~a, ~a (~a)"
(or itime (strftime *sig/date-format* (localtime mtime)))
(sig/filesize-str (assq-ref props #:size))
(or res "n.a.")
name)))
(define* ((sig/make-html-snippet download-links?) props)
(if (eq? 'video (assq-ref props #:media))
(format #f "<a href=\"~a\" title=\"~a\" type=\"~a\" data-download=\"~a\" data-poster=\"~a\" data-gallery><img src=\"~a\"></a>"
(assq-ref props #:image)
(sig/make-image-title props)
"video/webm"
(if download-links? (assq-ref props #:file-name) "")
(assq-ref props #:thumbnail)
(assq-ref props #:thumbnail))
(format #f "<a href=\"~a\" title=\"~a\" data-download=\"~a\" data-gallery>\n<img src=\"~a\" alt=\"~a\">\n</a>"
(assq-ref props #:image)
(sig/make-image-title props)
(if download-links? (assq-ref props #:file-name) "")
(assq-ref props #:thumbnail)
(sig/make-image-title props))))
(define* ((sig/html-map-line! replacements) line)
(define (loop lst)
(if (null? lst)
line
(let ((head (car lst))
(tail (cdr lst)))
(if (string-contains line (car head))
(cdr head) (loop tail)))))
(loop replacements))
(define (sig/html-map-template! converter)
"Read the template from port and applies the line conversions. Write
the result to current-output-port."
(let ((line (car (%read-line (current-input-port)))))
(when (not (eof-object? line))
(display (converter line))
(newline)
(sig/html-map-template! converter))))
(define (sig/make-resource-links resourcedir type)
"Create a string containing <script/> or <link/> html snippets to
resources. TYPE may be either #:js or #:css."
(let ((make-js (lambda (p) (format #f "<script src=\"~a\"></script>" p)))
(make-css (lambda (p) (format #f "<link rel=\"stylesheet\" href=\"~a\"/>" p)))
(typename (symbol->string (keyword->symbol type))))
(string-join
(map (compose (if (eq? type #:js) make-js make-css)
(sig/make-resource-path resourcedir typename))
(sig/resources type))
"\n")))
(define (sig/find-template template)
"If TEMPLATE is null, return `*sig/default-tempalte-file*' if it
exists. Otherwise return *sig/template*. If TEMPLATE is not null,
return it."
(or template
(if (file-exists? *sig/default-template-file*)
*sig/default-template-file*
*sig/template*)))
(define (sig/make-css resourcedir)
(string-append (sig/make-resource-links resourcedir #:css)
"\n<style type=\"text/css\">"
*sig/more-css*
"</style>\n"))
(define (sig/make-js resourcedir)
(string-append (sig/make-resource-links resourcedir #:js)
"\n<script type=\"text/javascript\">"
*sig/more-js*
"</script>\n"))
(define* (sig/gen-html resourcedir props #:optional template download-links?)
"Generates the html file containing the image gallery. PROPS is a
list of property list each representing a image/video file. Optionally
a template html file can be specified. If TEMPLATE is not a file, it
is assumed to be the template string."
(let* ((templ (sig/find-template template))
(out (sig/path resourcedir ".." "index.html"))
(replacements
`(("${sig-js}" . ,(sig/make-js resourcedir))
("${sig-head}" . ,(sig/make-css resourcedir))
("${sig-box}" . ,(sig/template-lightbox download-links?))
("${sig-links}" . ,(string-join
(map (sig/make-html-snippet download-links?) (sig/sort-properties props)) "\n"))))
(convert-fn (lambda ()
(sig/html-map-template! (sig/html-map-line! replacements)))))
(format #t "~%Use template ~a " templ)
(with-output-to-string
(lambda()
(if (file-exists? templ)
(with-input-from-file templ convert-fn)
(with-input-from-string templ convert-fn))))))
(define (sig/write-file! name contents)
"Write a file with NAME containing CONTENTS."
(format #t "~%Writing file ~a~%" name)
(when (file-exists? name)
(delete-file name))
(with-output-to-file name
(lambda() (display contents) #t)))
(define* (sig/scandir directory #:optional recursive)
"Return all supported files in DIRECTORY. If RECURSIVE is #t,
traverse DIRECTORY recursively."
(define (skip path stat result) result)
(file-system-fold
(lambda (path stat result) (if recursive #t (equal? directory path))) ;; enter?
(lambda (path stat result) (if (sig/supported-file? path) (cons path result) result)) ;; leaf
skip ;; down
skip ;;up
skip ;;skip
(lambda (path stat errno result) ;; error
(sig/errmsg "Error: Skipping ~a: ~a (~d)~%" path (strerror errno) errno)
result)
'() ;; initial value
directory)) ;; file-name
(define* (sig/make-images! directory #:optional original (thumbsize 150) (imgsize 1200) (overwrite #f) (recursive #f) (parallel #f))
"Make the gallery by resizing images from directory ORIGINAL and
creating thumbnails. Return a list of image properties."
(sig/make-check! directory original)
(format #t "Creating gallery from images in ~a~%" original)
(let* ((orgdir (or original (sig/path directory "original")))
(dowork (compose (sig/do-file! imgsize thumbsize overwrite)
(sig/image-properties orgdir directory))))
(if parallel
(map touch (map (sig/as-future dowork) (sig/scandir orgdir recursive)))
(map dowork (sig/scandir orgdir recursive)))))
;; --- commands
;; makeing new commands: the doc string is displayed to the user via
;; the help command. the first sentence should be some short (~ 50
;; chars) summary. After that no limits…
(define *sig/commands*
'("help" "create" "make-all" "make-html" "version" "create-template"))
(define (sig/find-command name)
(if (member name *sig/commands*)
(module-symbol-binding
(current-module)
(string->symbol (string-append "main-" name)))
#f))
(define (sig/command-help cmd)
(cond ((procedure? cmd)
(procedure-documentation cmd))
((string? cmd)
(let ((proc (sig/find-command cmd)))
(and proc (procedure-documentation proc))))))
(define (main-create-template args)
"Create a minimal html template file.
Sig allows to take a custom html file and replace certain placeholders
with image gallery components:
${sig-js} javascript files
${sig-head} things that should go in html-head section (css
stylesheets)
${sig-box} html snippets for the modal dialog (this should be a
direct child of the html-body element)
${sig-links} the list of links to the images (this should be inside
bootstrap's content div)
By default a very basic html template is used. This command writes the
default template in a file '*sig/default-template-file for modifying it. Note
that sig replaces the whole line containing such a variable."
(sig/write-file! *sig/default-template-file*
*sig/template*))
(define (main-version args)
"Display the version and a list of commands."
(sig/version)
(newline)
(display "Commands: ")
(for-each (lambda (c) (format #t "~a " c)) *sig/commands*)
(newline))
(define (main-create args)
"Creates a new gallery outline.
Creates a new gallery outline in the directory specified by the first
argument. If omitted, the current directory is used. The folders
'images', 'thumbnails' and 'resources' are created. The 'resources'
folder is populated with javascript and css files.
The gallery can then be created using 'sig make-all'."
(let ((len (length args)))
(sig/create! (if (> len 1) (cadr args) "."))))
(define (main-make-all args)
"Creates the gallery by processing given images.
--html template (-h) a html template file to use
--thumbsize size (-t) the thumbnail size (default is 150)
--size size (-s) the image size (default is 1200)
--in dir (-i) the directory with image files (default is
'original')
--recursive (-r) traverse DIR recursiveley
--parallel (-p) resize images in parallel (using all cores)
--overwrite (-o) all existing files are overwritten, default
is to only write new files
--download-links (-d) Create download links to each original file
After image/video files have been processed, the html file is generated."
(define option-spec
'((thumbsize (single-char #\t) (value #t))
(imgsize (single-char #\s) (value #t))
(html (single-char #\h) (value #t))
(overwrite (single-char #\o) (value #f))
(recursive (single-char #\r) (value #f))
(parallel (single-char #\p) (value #f))
(download-links (single-char #\d) (value #f))
(in (single-char #\i) (value #t))))
(let* ((opts (getopt-long args option-spec))
(dir (option-ref opts 'in "original"))
(size (or (string->number (option-ref opts 'imgsize "1200"))
1200))
(thsz (or (string->number (option-ref opts 'thumbsize "150"))
150))
(rec (option-ref opts 'recursive #f))
(par (option-ref opts 'parallel #f))
(template (option-ref opts 'html #f))
(make-links (option-ref opts 'download-links #t))
(overwr (option-ref opts 'overwrite #f))
(props (sig/make-images! "." dir thsz size overwr rec par)))
(sig/write-file! "index.html"
(sig/gen-html "resources" props template make-links))
(display "Done.\n")))
(define (main-make-html args)
"Generates the html file only.
It assumes that image/video files have been processed already and exist
in 'images' and 'thumbnails', respectively.
--html template (-h) a html template file to use
--in dir (-i) the directory with image files (default is
'original')
--recursive (-r) traverse DIR recursiveley
--download-links (-d) Create download links to each original file
"
(define option-spec
'((in (single-char #\i) (value #t))
(recursive (single-char #\r) (value #f))
(download-links (single-char #\d) (value #f))
(html (single-char #\h) (value #t))))
(let* ((opts (getopt-long args option-spec))
(dir (option-ref opts 'in "original"))
(rec (option-ref opts 'recursive #f))
(make-links (option-ref opts 'download-links #f))
(template (option-ref opts 'html #f))
(props (map (sig/image-properties dir ".") (sig/scandir dir rec))))
(sig/write-file! "index.html"
(sig/gen-html (sig/path "resources") props template make-links))))
(define (sig/first-sentence str)
(let ((idx (and str (string-index str #\.))))
(if idx
(string-take str (1+ idx))
"Not documented.")))
(define (main-help args)
"Displays some help text."
(let* ((cmd (and (not (null? (cdr args)))
(sig/find-command (cadr args)))))
(if (null? (cdr args))
(begin
(sig/version)
(newline)
(newline)
(display "This script creates a html file containing an image gallery from\n")
(display "images of a given folder. Images are resized and thumbnails are\n")
(display "created. Video files are supported, too. They are converted into\n")
(display "webm files, which I think can be played with most browsers.\n")
(newline)
(display "The script expects a command which in turn may be configured with\n")
(display "options. These commands are:\n")
(newline)
(for-each (lambda (c)
(format #t "~a~c~c~a~%"
c #\tab
(if (< (string-length c) 8) #\tab #\nul)
(sig/first-sentence (sig/command-help c))))
*sig/commands*)
(newline)
(display "Please type `help <cmd>' for more help about each command.\n")
(newline))
(if cmd
(format #t "~a~%" (sig/command-help cmd))
(format #t "Unknown command: ~a~%" (cadr args))))))
(define (main args)
(let* ((len (length (cdr args)))
(action (if (> len 0) (cadr args) ""))
(cmd (sig/find-command action))
(helphelp (format #f "Try `~a help'." (car args))))
(if (equal? 0 len)
(sig/errmsg "No arguments given. ~a~%" helphelp)
(if cmd
(cmd (cdr args))
(sig/errmsg "Unknown action: ~a. ~a~%" action helphelp)))))