((license "BSD")
 (category data)
 (needs matchable)
 (test-depends test)
 (author "Alaric Snell-Pym")
 (synopsis "A tool to generate manifests for Ugarit archival mode"))

((license "BSD")
 (category data)
 (needs matchable srfi-37 fnmatch)
 (test-depends test exif)
 (author "Alaric Snell-Pym")
 (synopsis "A tool to generate manifests for Ugarit archival mode"))

(use posix)
(use srfi-1)

(use ugarit-mime)
(use srfi-37)
(use miscmacros)
(use fnmatch)
(use exif)

(define *excludes* '())
(define *total-objects* 0)
(define *total-bytes* 0)

(define (path-size path)
  (if (directory? path)
      (fold
       +
       0
       (map
        (lambda (relpath)
          (path-size (make-pathname path relpath)))
        (directory path)))
      ;; Not a directory
      (file-size path)))

(define (included-file? path)
  (let ((name (pathname-strip-directory path)))
    (not (any
          (lambda (pattern)
            (fnmatch pattern name))
          *excludes*))))

(define (get-jpeg-metadata path)
  ;; FIXME http://www.cipa.jp/std/documents/e/DC-008-2012_E.pdf
  '((description . #f)
    (latitude . #f)
    (longitude . #f)
    (altitude . #f)
    (place-name . #f)
    (featuring . #f)
    (event-name . #f)
    (creator . #f)
    (creation-date . #f)
    (keyword . #f)))

(define debug (lambda x (void)))
#;(define debug printf)

(define (alist-update! alist key value)
  (let ((pair (assq key alist)))
    (if (and (pair? pair) (not (cdr pair)))
        (begin
          (set-cdr! pair value) ;; Exists but is #f, so overwrite
          alist)
        (cons (cons key value) alist))))

(define genres
  '((0 . "Blues")
    (1 . "Classic Rock")
    (2 . "Country")
    (3 . "Dance")
    (4 . "Disco")
    (5 . "Funk")
    (6 . "Grunge")
    (7 . "Hip-Hop")
    (8 . "Jazz")
    (9 . "Metal")
    (10 . "New Age")
    (11 . "Oldies")
    (12 . "Other")
    (13 . "Pop")
    (14 . "R&B")
    (15 . "Rap")
    (16 . "Reggae")
    (17 . "Rock")
    (18 . "Techno")
    (19 . "Industrial")
    (20 . "Alternative")
    (21 . "Ska")
    (22 . "Death Metal")
    (23 . "Pranks")
    (24 . "Soundtrack")
    (25 . "Euro-Techno")
    (26 . "Ambient")
    (27 . "Trip-Hop")
    (28 . "Vocal")
    (29 . "Jazz+Funk")
    (30 . "Fusion")
    (31 . "Trance")
    (32 . "Classical")
    (33 . "Instrumental")
    (34 . "Acid")
    (35 . "House")
    (36 . "Game")
    (37 . "Sound Clip")
    (38 . "Gospel")
    (39 . "Noise")
    (40 . "AlternRock")
    (41 . "Bass")
    (42 . "Soul")
    (43 . "Punk")
    (44 . "Space")
    (45 . "Meditative")
    (46 . "Instrumental Pop")
    (47 . "Instrumental Rock")
    (48 . "Ethnic")
    (49 . "Gothic")
    (50 . "Darkwave")
    (51 . "Techno-Industrial")
    (52 . "Electronic")
    (53 . "Pop-Folk")
    (54 . "Eurodance")
    (55 . "Dream")
    (56 . "Southern Rock")
    (57 . "Comedy")
    (58 . "Cult")
    (59 . "Gangsta")
    (60 . "Top 40")
    (61 . "Christian Rap")
    (62 . "Pop/Funk")
    (63 . "Jungle")
    (64 . "Native American")
    (65 . "Cabaret")
    (66 . "New Wave")
    (67 . "Psychadelic")
    (68 . "Rave")
    (69 . "Showtunes")
    (70 . "Trailer")
    (71 . "Lo-Fi")
    (72 . "Tribal")
    (73 . "Acid Punk")
    (74 . "Acid Jazz")
    (75 . "Polka")
    (76 . "Retro")
    (77 . "Musical")
    (78 . "Rock & Roll")
    (79 . "Hard Rock")
    (80 . "Folk")
    (81 . "Folk-Rock")
    (82 . "National Folk")
    (83 . "Swing")
    (84 . "Fast Fusion")
    (85 . "Bebob")
    (86 . "Latin")
    (87 . "Revival")
    (88 . "Celtic")
    (89 . "Bluegrass")
    (90 . "Avantgarde")
    (91 . "Gothic Rock")
    (92 . "Progressive Rock")
    (93 . "Psychedelic Rock")
    (94 . "Symphonic Rock")
    (95 . "Slow Rock")
    (96 . "Big Band")
    (97 . "Chorus")
    (98 . "Easy Listening")
    (99 . "Acoustic")
    (100 . "Humour")
    (101 . "Speech")
    (102 . "Chanson")
    (103 . "Opera")
    (104 . "Chamber Music")
    (105 . "Sonata")
    (106 . "Symphony")
    (107 . "Booty Bass")
    (108 . "Primus")
    (109 . "Porn Groove")
    (110 . "Satire")
    (111 . "Slow Jam")
    (112 . "Club")
    (113 . "Tango")
    (114 . "Samba")
    (115 . "Folklore")
    (116 . "Ballad")
    (117 . "Power Ballad")
    (118 . "Rhythmic Soul")
    (119 . "Freestyle")
    (120 . "Duet")
    (121 . "Punk Rock")
    (122 . "Drum Solo")
    (123 . "A capella")
    (124 . "Euro-House")
    (125 . "Dance Hall")))

(define (process-genre g)
  (if (and (char=? (string-ref g 0) #\()
           (char=? (string-ref g
                               (- (string-length g) 1)) #\)))
      (let* ((genre-number (string->number
                            (substring g 1 (- (string-length g) 1))))
             (genre-lookup (assoc genre-number genres)))
        (if genre-lookup
            (cdr genre-lookup)
            g))
      g))

(define (remove-trailing-term-if-present str)
  (if (zero? (string-length str))
      str
      (if (char=? (string-ref str
                              (- (string-length str) 1))
                  #\x00)
          (substring str 0 (- (string-length str) 1))
          str)))

(define (get-mp3-metadata path)
  ;; FIXME http://id3.org/id3v2-00 / http://id3.org/id3v2.3.0
  (with-input-from-file path
    (lambda ()
      (let/cc
       abort*
       (let* ((metadata
               '((creator . #f)
                 (creation-date . #f)
                 (featuring . #f)
                 (collection-name . #f)
                 (collection-volume . #f)
                 (collection-volumes . #f)
                 (volume-index . #f)
                 (volume-size . #f)))
              (abort
               (lambda ()
                 (abort* metadata)))
              (read-id3v22
               (lambda ()
                 (debug "Reading v2.2")
                 (let* ((flags (read-byte))
                        (unsync (not (zero? (bitwise-and flags 128))))
                        (compressed (not (zero? (bitwise-and flags 64))))
                        (size4 (read-byte))
                        (size3 (read-byte))
                        (size2 (read-byte))
                        (size1 (read-byte))
                        (size (+
                               size1
                               (* 128 size2)
                               (* 16384 size3)
                               (* 2097152 size4)))
                        (*bytes-left* size)
                        (rb ;; read-byte replacement
                         (if unsync
                             ;; Unsynchronised mode
                             (let ((last-byte #f))
                               (lambda ()
                                 (set! *bytes-left*
                                       (- *bytes-left* 1))
                                 (let ((b (read-byte)))
                                   (when (and
                                          (= last-byte #xff)
                                          (= b #x00))
                                         ;; Skip #x00 unsync byte
                                         (set! *bytes-left*
                                               (- *bytes-left* 1))
                                         (set! b (read-byte)))
                                   (set! last-byte b)
                                   b)))
                             ;; Normal mode
                             (lambda ()
                               (set! *bytes-left*
                                     (- *bytes-left* 1))
                               (read-byte)))))
                   (debug "Read header, size = ~S, unsync = ~S\n" size unsync)

                   (let loop ((md (alist-copy metadata)))
                     (debug "Bytes left: ~S\n" *bytes-left*)
                     (when (< *bytes-left* 10)
                           (abort* md))

                     (let* ((fid1 (rb))
                            (fid2 (rb))
                            (fid3 (rb))
                            (fid (list->string
                                  (list
                                   (integer->char fid1)
                                   (integer->char fid2)
                                   (integer->char fid3))))
                            (fsize3 (rb))
                            (fsize2 (rb))
                            (fsize1 (rb))
                            (fsize (+
                                    fsize1
                                    (* 256 fsize2)
                                    (* 65536 fsize3)))
                            (encoding (rb))
                            (data
                             (remove-trailing-term-if-present
                              (list->string
                               (reverse
                                (list-tabulate
                                 (- fsize 1) ;; Remove encoding byte
                                 (lambda (i) (integer->char (rb)))))))))
                       (debug "FID: ~S size: ~S [~S]\n" fid fsize data)
                       (cond
                        ((string=? fid "\x00\x00\x00")
                         (abort* md))
                        ((string=? fid "TT2")
                         (loop (alist-update! md 'name data)))
                        ((string=? fid "TP1")
                         (loop (alist-update! md 'creator data)))
                        ((string=? fid "TCM")
                         (loop (alist-update! md 'creator data)))
                        ((string=? fid "TYE")
                         (loop (alist-update! md 'creation-date data)))
                        ((string=? fid "TCO")
                         (loop (alist-update! md 'keyword (process-genre data))))
                        ((string=? fid "TAL")
                         (loop (alist-update! md 'collection-name data)))
                        ((string=? fid "TRK")
                         (and-let* ((parts (string-split data "/"))
                                    ((= (length parts) 2))
                                    (track (string->number (first parts)))
                                    (tracks (string->number (second parts))))
                                   (loop (alist-update!
                                          (alist-update! md 'volume-index track)
                                          'volume-size tracks)))
                         (loop md))
                        ((string=? fid "TPA")
                         (and-let* ((parts (string-split data "/"))
                                    ((= (length parts) 2))
                                    (volume (string->number (first parts)))
                                    (volumes (string->number (second parts))))
                                   (loop (alist-update!
                                          (alist-update! md 'collection-volume volume)
                                          'collection-volumes volumes)))
                         (loop md))
                        (else
                         (printf "   ;; Unknown ID3 tag ~S=~S\n"
                                 fid
                                 (string-append
                                  (make-string 1 (integer->char encoding))
                                  data))
                         (loop md))))))))
              (read-id3v23
               (lambda ()
                 (debug "Reading v2.3")
                 (let* ((flags (read-byte))
                        (unsync (not (zero? (bitwise-and flags 128))))
                        (extended (not (zero? (bitwise-and flags 64))))
                        (experimental (not (zero? (bitwise-and flags 32))))
                        (size4 (read-byte))
                        (size3 (read-byte))
                        (size2 (read-byte))
                        (size1 (read-byte))
                        (size (+
                               size1
                               (* 128 size2)
                               (* 16384 size3)
                               (* 2097152 size4)))
                        (*bytes-left* size)
                        (rb ;; read-byte replacement
                         (if unsync
                             ;; Unsynchronised mode
                             (let ((last-byte #f))
                               (lambda ()
                                 (set! *bytes-left*
                                       (- *bytes-left* 1))
                                 (let ((b (read-byte)))
                                   (when (and
                                          (= last-byte #xff)
                                          (= b #x00))
                                         ;; Skip #x00 unsync byte
                                         (set! *bytes-left*
                                               (- *bytes-left* 1))
                                         (set! b (read-byte)))
                                   (set! last-byte b)
                                   b)))
                             ;; Normal mode
                             (lambda ()
                               (set! *bytes-left*
                                     (- *bytes-left* 1))
                               (read-byte)))))
                   (debug "Read header, size = ~S, unsync = ~S\n" size unsync)
                   (when extended
                         (debug "Reading extended header\n")
                         (let* ((size4 (rb))
                                (size3 (rb))
                                (size2 (rb))
                                (size1 (rb))
                                (size (+
                                       size1
                                       (* 256 size2)
                                       (* 65536 size3)
                                       (* 16777216 size4)))
                                (eflags1 (rb))
                                (eflags2 (rb)))
                           (when (not (zero?
                                       (bitwise-and eflags1 128)))
                                 ;; Skip CRC
                                 (rb)
                                 (rb)
                                 (rb)
                                 (rb))))
                   (let loop ((md (alist-copy metadata)))
                     (debug "Bytes left: ~S\n" *bytes-left*)
                     (when (< *bytes-left* 10)
                           (abort* md))

                     (let* ((fid1 (rb))
                            (fid2 (rb))
                            (fid3 (rb))
                            (fid4 (rb))
                            (fid (list->string
                                  (list
                                   (integer->char fid1)
                                   (integer->char fid2)
                                   (integer->char fid3)
                                   (integer->char fid4))))
                            (fsize4 (rb))
                            (fsize3 (rb))
                            (fsize2 (rb))
                            (fsize1 (rb))
                            (fsize (+
                                    fsize1
                                    (* 256 fsize2)
                                    (* 65536 fsize3)
                                    (* 16777216 fsize4)))
                            (flags1 (rb))
                            (flags2 (rb))
                            (encoding (rb))
                            (data
                             (remove-trailing-term-if-present
                              (list->string
                               (reverse
                                (list-tabulate
                                 (- fsize 1) ;; Remove encoding byte
                                 (lambda (i) (integer->char (rb)))))))))
                       (debug "FID: ~S size: ~S [~S]\n" fid fsize data)
                       (cond
                        ((string=? fid "\x00\x00\x00\x00")
                         (abort* md))
                        ((string=? fid "TIT2")
                         (loop (alist-update! md 'name data)))
                        ((string=? fid "TPE1")
                         (loop (alist-update! md 'creator data)))
                        ((string=? fid "TCOM")
                         (loop (alist-update! md 'creator data)))
                        ((string=? fid "TPE2")
                         (loop (alist-update! md 'featuring data)))
                        ((string=? fid "TPE3")
                         (loop (alist-update! md 'featuring data)))
                        ((string=? fid "TPE4")
                         (loop (alist-update! md 'editor data)))
                        ((string=? fid "TPUB")
                         (loop (alist-update! md 'publisher data)))
                        ((string=? fid "TYER")
                         (loop (alist-update! md 'creation-date data)))
                        ((string=? fid "TCON")
                         (loop (alist-update! md 'keyword (process-genre data))))
                        ((string=? fid "TALB")
                         (loop (alist-update! md 'collection-name data)))
                        ((string=? fid "TRCK")
                         (and-let* ((parts (string-split data "/"))
                                    ((= (length parts) 2))
                                    (track (string->number (first parts)))
                                    (tracks (string->number (second parts))))
                                   (loop (alist-update!
                                          (alist-update! md 'volume-index track)
                                          'volume-size tracks)))
                         (loop md))
                        ((string=? fid "TPOS")
                         (and-let* ((parts (string-split data "/"))
                                    ((= (length parts) 2))
                                    (volume (string->number (first parts)))
                                    (volumes (string->number (second parts))))
                                   (loop (alist-update!
                                          (alist-update! md 'collection-volume volume)
                                          'collection-volumes volumes)))
                         (loop md))
                        (else
                         (printf "   ;; Unknown ID3 tag ~S=~S\n"
                                 fid
                                 (if (< (string-length data) 160)
                                     data
                                     (string-append
                                      (substring data 0 100)
                                      "...")))
                         (loop md)))))))))
        (when (not (= (read-byte) #x49))
              (abort))
        (when (not (= (read-byte) #x44))
              (abort))
        (when (not (= (read-byte) #x33))
              (abort))
        (let ((version1 (read-byte))
              (version2 (read-byte)))
          (case version1
            ((2) (read-id3v22))
            ((3) (read-id3v23))
            (else (abort)))))))))

(define (get-ogg-metadata path)
  ;; FIXME http://xiph.org/vorbis/doc/v-comment.html
  '((creator . #f)
    (creation-date . #f)
    (featuring . #f)
    (collection-name . #f)
    (collection-volume . #f)
    (collection-volumes . #f)
    (volume-index . #f)
    (volume-size . #f)))

(define (get-pdf-metadata path)
  '((creator . #f)
    (topic . #f)
    (creation-date . #f)
    (keyword . #f)))

(define (get-ps-metadata path)
  '((creator . #f)
    (topic . #f)
    (creation-date . #f)
    (keyword . #f)))

(define (generate-manifest path)
  (if (directory? path)
      ;; Recurse therein
      (for-each (lambda (relname)
                  (generate-manifest (make-pathname path relname)))
                (directory path))

      ;; Not a directory
      (when (included-file? path)
       (let* ((name (pathname-file path))
              (*got-name* #f)
              (print-item
               (lambda (item)
                 (if (and (eq? (car item) 'name)
                          (cdr item))
                     (set! *got-name* #f))
                 (if (cdr item)
                     (printf "  (~S = ~S)\n" (car item) (cdr item))
                     (printf "  #;(~S = \"\")\n" (car item)))))
              (mime-type (extension->mimetype (string-append "."
                                                             (or
                                                              (pathname-extension path)
                                                              "")))))
         (printf "(object ~S\n" path)
         (printf "  (filename = ~S)\n" path)
         (printf "  (mime-type = ~S)\n" mime-type)

         (newline)

         (cond
          ((string=? mime-type "image/jpeg")
           (for-each print-item
                     (get-jpeg-metadata path)))

          ((string=? mime-type "audio/mpeg")
           (for-each print-item
                     (get-mp3-metadata path)))

          ((string=? mime-type "audio/ogg")
           (for-each print-item
                     (get-ogg-metadata path)))

          ((string=? mime-type "application/pdf")
           (for-each print-item
                     (get-pdf-metadata path)))

          ((string=? mime-type "application/postscript")
           (for-each print-item
                     (get-ps-metadata path)))

          (else
           (unless *got-name*
                   (printf "  (name = ~S)\n" name))
           (printf "  #;(description = \"\")\n")))

         (newline)

         (let ((stat (file-stat path)))
           (printf "  (mtime = ~S)\n" (vector-ref stat 8))
           (printf "  (ctime = ~S)\n" (vector-ref stat 7)))

         (let ((size (path-size path)))
           (printf "  (size = ~S))\n" size)
           (set! *total-bytes*
                 (+ *total-bytes* size))
           (set! *total-objects*
                 (+ *total-objects* 1)))

         (newline)))))

(define (usage)
  (with-output-to-port (current-error-port)
    (lambda ()
      (printf "Usage: ugarit-manifest-maker [options...] [files...]\n")
      (printf "  -e <pattern>   Exclude files matching pattern\n")))
  (exit 1))

(define things-to-import
  (args-fold
   (command-line-arguments)
   (list
    (option
     '(#\h "help") #f #f
     (lambda _
       (usage)))
    (option
     '(#\e "exclude") #t #f
     (lambda (o n x vals)
       (push! x *excludes*)
       vals)))
   (lambda (o n x vals)
     (usage))
   cons
   '()))

(for-each generate-manifest
          things-to-import)

(define (format-bytes b)
  (cond
   ((<= (* 1024 1024 1024 1024) b)
    (sprintf "~ATiB" (inexact->exact (round (/ b 1024 1024 1024 1024)))))
   ((<= (* 1024 1024 1024) b)
    (sprintf "~AGiB" (inexact->exact (round (/ b 1024 1024 1024)))))
   ((<= (* 1024 1024) b)
    (sprintf "~AMiB" (inexact->exact (round (/ b 1024 1024)))))
   ((<= (* 1024) b)
    (sprintf "~AKiB" (inexact->exact (round (/ b 1024)))))
   (else
    (sprintf "~AB" b))))

(printf ";;; TOTAL: ~S objects / ~A\n"
        *total-objects*
        (format-bytes *total-bytes*))