(import scheme)
(import (chicken base))
(import (chicken condition))
(import (chicken file))
(import (chicken file posix))
(import (chicken format))
(import (chicken io))
(import (chicken irregex))
(import (chicken pathname))
(import (chicken port))
(import (chicken process-context))
(import (chicken string))
(import getopt-long)
(import image-dimensions)
(import magic)
(import natural-sort)
(import scsh-process)

(define (string-downcase s)
  (list->string (map char-downcase (string->list s))))

(natural-sort-preprocessor string-downcase)

(define work-dir "/tmp/mcp")
(define unpack-dir "/tmp/mcp/unpack")
(define trash-dir "/tmp/mcp/trash")
(define flatten-dir "/tmp/mcp/flatten")

(define-syntax run!
  (syntax-rules ()
    ((_ epf)
     (receive (status out err)
         (run/collecting (1 2) epf (> "/dev/null"))
       (close-input-port out)
       (when (not (zero? status))
         (display (read-string #f err)))
       (close-input-port err)))))

(define (check-leftover-files!)
  (when (directory-exists? work-dir)
    (printf "Existing working directory detected, delete files? [y/N] ~!")
    (let ((input (read-line)))
      (if (and (> (string-length input) 0)
               (memv (string-ref input 0) '(#\y #\Y)))
          (delete-directory work-dir 'recursive)
          (exit 1)))))

(define (files-in directory)
  (find-files directory test: (lambda (path) (not (directory? path)))))

(define (string-starts-with? needle haystack)
  (let ((index (substring-index needle haystack)))
    (and index (zero? index))))

(define (image? path)
  (string-starts-with? "image/" (identify path 'mime-type)))

(define (archive-type path)
  (let ((mime-type (identify path 'mime-type)))
    (cond
     ((equal? mime-type "application/zip") "zip")
     ((equal? mime-type "application/x-rar") "rar")
     (else #f))))

(define (extract! path #!optional dir)
  (let ((type (archive-type path)))
    (when (not type)
      (error "not an archive" path))
    (if dir
        (run! (aunpack -F ,type -X ,dir ,path))
        (run! (aunpack -F ,type ,path)))))

(define (dynamic-wind+ before thunk after)
  (handle-exceptions exn
    (signal exn)
    (dynamic-wind
        before
        thunk
        after)))

(define (with-current-directory path thunk)
  (let ((old (current-directory)))
    (dynamic-wind+
        (lambda () (change-directory path))
        thunk
        (lambda () (change-directory old)))))

(define (trash-file! path)
  (when (directory? path)
    (error "Trying to trash a directory"))
  (let ((to (make-pathname trash-dir (pathname-strip-directory path))))
    (move-file path to 'clobber)))

(define (unnest-inner-archives!)
  (for-each (lambda (path)
              (when (archive-type path)
                (print "Archive detected!")
                (with-current-directory (pathname-directory path)
                  (lambda ()
                    (extract! path)
                    (trash-file! path)))))
            (files-in unpack-dir)))

(define (purge-non-image-files!)
  (for-each (lambda (path)
              (when (not (image? path))
                (trash-file! path)))
            (files-in unpack-dir)))

(define (pad-width size)
  (string-length (number->string size)))

(define (left-pad s len char)
  (let ((cur-len (string-length s)))
    (if (< cur-len len)
        (string-append (make-string (- len cur-len) char) s)
        s)))

(define (flatten-image-paths!)
  (let* ((paths (natural-sort (files-in unpack-dir)))
         (digits (pad-width (length paths))))
    (let loop ((paths paths)
               (i 0))
      (when (pair? paths)
        (let* ((path (car paths))
               (index (left-pad (number->string i) digits #\0))
               (old-name (pathname-strip-directory path))
               (new-name (format "~a_~a" index old-name)))
          (move-file path (make-pathname flatten-dir new-name) 'clobber))
        (loop (cdr paths) (add1 i))))))

(define (ensure-portrait-direction!)
  (for-each (lambda (path)
              (let* ((dimensions (call-with-input-file path image-dimensions))
                     (width (car dimensions))
                     (height (cadr dimensions)))
                (when (> width height)
                  (run! (mogrify -rotate 270 ,path)))))
            (files-in flatten-dir)))

(define kobo-width 1080)
(define kobo-height 1440)

(define (optimize-images!)
  (let ((geometry (format "~ax~a>" kobo-width kobo-height)))
    (for-each
     (lambda (path)
       (let* ((dimensions (call-with-input-file path image-dimensions))
              (width (car dimensions))
              (height (cadr dimensions))
              (large? (and (< kobo-width width) (< kobo-height height)
                           (< (/ kobo-width width) 0.8)
                           (< (/ kobo-height height) 0.8)))
              (color? #f) ; TODO: test whether color
              (deep? #f) ; TODO: test whether high depth (16/24 bit)
              (options '())
              (options (if large? (append `(-resize ,geometry) options) options))
              (options (if color? (append '(-type GrayScale) options) options))
              (options (if deep? (append '(-depth 8) options) options)))
         (when (or large? color? deep?)
           (run! (mogrify ,@options ,path)))))
     (files-in flatten-dir))))

(define (create-archive!)
  (with-current-directory flatten-dir
    (lambda ()
      (run! (apack "../output.zip" ".")))))

(define (rename-archive! directory file digit title)
  (let* ((from (make-pathname work-dir "output.zip"))
         (new-name (if title
                       (make-pathname title (format "~a #~a.cbz" title digit))
                       (format "~a #~a.cbz" (pathname-file file) digit)))
         (to (make-pathname directory new-name)))
    (create-directory (pathname-directory to) 'parents)
    (move-file from to 'clobber)))

(define (process! directory file digit title optimize?)
  (create-directory unpack-dir 'parents)
  (create-directory trash-dir 'parents)
  (create-directory flatten-dir 'parents)
  (print "Extracting files...")
  (extract! file unpack-dir)
  (print "Unnesting inner archives...")
  (unnest-inner-archives!)
  (print "Purging non-image files...")
  (purge-non-image-files!)
  (print "Flattening image paths...")
  (flatten-image-paths!)
  (print "Ensuring portrait direction...")
  (ensure-portrait-direction!)
  (when optimize?
    (print "Optimizing images...")
    (optimize-images!))
  (print "Creating archive...")
  (create-archive!)
  (print "Renaming archive...")
  (rename-archive! directory file digit title)
  (print "Cleaning up...")
  (delete-directory work-dir 'recursive))

(define usage-hint "Usage: mcp [options] [file ...]\n")

(define options
  `((directory
     "Change output directory"
     (required #f)
     (value #t)
     (single-char #\C))
    (title
     "Title of the manga"
     (required #f)
     (value #t)
     (single-char #\t))
    (start
     "Start counting from i"
     (required #f)
     (value (required "i")
            (predicate ,string->number)
            (transformer ,string->number))
     (single-char #\s))
    (optimize
     "Optimize images"
     (required #f)
     (value #f)
     (single-char #\O))
    (help
     "Prints this help"
     (required #f)
     (value #f)
     (single-char #\h))))

(define (print-error . args)
  (with-output-to-port (current-error-port)
    (lambda () (apply print args))))

(define (main)
  (let* ((opts
          (condition-case
           (getopt-long (command-line-arguments) options)
           (e (exn)
              (print-error
               (format "Error: ~a: ~a\n"
                       ((condition-property-accessor 'exn 'message) e)
                       ((condition-property-accessor 'exn 'arguments) e))
               usage-hint (usage options)))))
         (help? (alist-ref 'help opts))
         (directory (or (alist-ref 'directory opts) "."))
         (title (alist-ref 'title opts))
         (start (or (alist-ref 'start opts) 1))
         (optimize? (alist-ref 'optimize opts))
         (files (alist-ref '@ opts)))
    (when help?
      (print usage-hint (usage options))
      (exit 0))
    (when (null? files)
      (print-error "No input file(s) specified\n" usage-hint)
      (exit 1))
    (check-leftover-files!)
    (let* ((file-count (sub1 (+ (length files) start)))
           (width (pad-width file-count)))
      (let loop ((files files)
                 (i 0))
        (when (pair? files)
          (let ((file (car files))
                (digit (left-pad (number->string (+ i start)) width #\0)))
            (printf "Processing file #~a (~a/~a): ~a\n"
                    digit (+ i start) file-count file)
            (process! directory file digit title optimize?)
            (loop (cdr files) (add1 i))))))))

(main)