#!/usr/bin/env scheme-script
#!r6rs

(import
  (rnrs)
  (fs fatfs)
  (fs fatfs port-device)
  (fs fatfs cli)
  (fs fatfs private compat))

(define (usage)
  (display "mcopy -i IMAGE [-s] SOURCE... DEST\n")
  (display "\n")
  (display "-i <image>  FAT image file\n")
  (display "-s          recursive copy of directories\n")
  (display "-h          print this help\n"))

(define (fxtest x y)
  (not (eqv? 0 (fxand x y))))

(define (entry-name info)
  (or (fatfs-file-info:long-filename info)
      (fatfs-file-info:filename info)))

(define (fat-directory? fs path)
  (cond
    ((null? path) #t)
    ((not (fatfs-file-exists? fs path)) #f)
    (else (fatfs-file-info-directory? (fatfs-file-info fs path)))))

(define (fat-directory-entries fs path)
  (let ((dir (fatfs-open-directory fs path)))
    (let lp ((out '()))
      (let ((info (fatfs-read-directory dir)))
        (cond
          ((eof-object? info)
           (fatfs-close-directory dir)
           (reverse out))
          ((or (member (fatfs-file-info:filename info) '("." ".."))
               (fxtest (fatfs-file-info:attr info) FATFS-VOLUME-ID))
           (lp out))
          (else
           (lp (cons info out))))))))

(define (ensure-host-directory path)
  (unless (file-directory? path)
    (let ((parent (path-dirname path)))
      (unless (or (string=? parent path)
                  (string=? parent ".")
                  (string=? parent ""))
        (ensure-host-directory parent)))
    (unless (file-exists? path)
      (create-directory path))))

(define (copy-host-file-to-fat fs host-path fat-path)
  (call-with-port (open-file-input-port host-path)
    (lambda (in)
      (call-with-port (fatfs-open-file fs fat-path
                                       (fxior fatfs-open/write
                                              fatfs-open/create
                                              fatfs-open/truncate))
        (lambda (out)
          (copy-port in out))))))

(define (copy-fat-file-to-host fs fat-path host-path)
  (call-with-port (fatfs-open-file fs fat-path fatfs-open/read)
    (lambda (in)
      (call-with-port (open-file-output-port host-path (file-options no-fail))
        (lambda (out)
          (copy-port in out))))))

(define (copy-fat-file-to-fat fs from-path to-path)
  (call-with-port (fatfs-open-file fs from-path fatfs-open/read)
    (lambda (in)
      (call-with-port (fatfs-open-file fs to-path
                                       (fxior fatfs-open/write
                                              fatfs-open/create
                                              fatfs-open/truncate))
        (lambda (out)
          (copy-port in out))))))

(define img-path #f)
(define recursive? #f)
(define paths '())

(let loop-args ((args (cdr (command-line))))
  (unless (null? args)
    (let ((arg (car args))
          (rest (cdr args)))
      (cond
        ((or (equal? arg "-h") (equal? arg "--help"))
         (usage)
         (exit 0))
        ((equal? arg "-i")
         (when (null? rest)
           (display "mcopy: -i argument missing a value\n")
           (exit 1))
         (set! img-path (car rest))
         (loop-args (cdr rest)))
        ((equal? arg "-s")
         (set! recursive? #t)
         (loop-args rest))
        (else
         (set! paths (append paths (list arg)))
         (loop-args rest))))))

(unless (and img-path (fx>=? (length paths) 2))
  (usage)
  (exit 1))

(define sources (reverse (cdr (reverse paths))))
(define dest (car (reverse paths)))
(define dest-fat? (fat-path-string? dest))
(define dest-path (if dest-fat? (string->fat-path dest) dest))
(define dest-trailing-dir? (trailing-separator? dest))

(define fs (open-fatfs (open-file-fatfs-device img-path #f)))

(define (copy-host-tree host-path fat-path)
  (cond
    ((file-directory? host-path)
     (unless recursive?
       (error 'mcopy "Cannot copy directory without -s" host-path))
     (unless (fatfs-file-exists? fs fat-path)
       (fatfs-create-directory fs fat-path))
     (for-each
       (lambda (name)
         (copy-host-tree (path-join host-path name)
                         (append fat-path (list name))))
       (directory-files host-path)))
    ((file-exists? host-path)
     (copy-host-file-to-fat fs host-path fat-path))
    (else
     (error 'mcopy "Source does not exist" host-path))))

(define (copy-fat-tree fat-path host-path)
  (cond
    ((fat-directory? fs fat-path)
     (unless recursive?
       (error 'mcopy "Cannot copy directory without -s" fat-path))
     (ensure-host-directory host-path)
     (for-each
       (lambda (info)
         (let ((name (entry-name info)))
           (copy-fat-tree (append fat-path (list name))
                          (path-join host-path name))))
       (fat-directory-entries fs fat-path)))
    ((fatfs-file-exists? fs fat-path)
     (let ((parent (path-dirname host-path)))
       (unless (or (string=? parent ".") (file-directory? parent))
         (ensure-host-directory parent)))
     (copy-fat-file-to-host fs fat-path host-path))
    (else
     (error 'mcopy "Source does not exist" fat-path))))

(define (copy-fat-tree-to-fat from-path to-path)
  (cond
    ((fat-directory? fs from-path)
     (unless recursive?
       (error 'mcopy "Cannot copy directory without -s" from-path))
     (unless (fatfs-file-exists? fs to-path)
       (fatfs-create-directory fs to-path))
     (for-each
       (lambda (info)
         (let ((name (entry-name info)))
           (copy-fat-tree-to-fat (append from-path (list name))
                                 (append to-path (list name)))))
       (fat-directory-entries fs from-path)))
    ((fatfs-file-exists? fs from-path)
     (copy-fat-file-to-fat fs from-path to-path))
    (else
     (error 'mcopy "Source does not exist" from-path))))

(define dest-is-dir?
  (or dest-trailing-dir?
      (null? dest-path)
      (fx>? (length sources) 1)
      (if dest-fat?
          (fat-directory? fs dest-path)
          (file-directory? dest-path))))

(when (and dest-is-dir? dest-trailing-dir?
           dest-fat?
           (not (null? dest-path))
           (not (fatfs-file-exists? fs dest-path)))
  (error 'mcopy "Destination directory does not exist" dest))

(when (and dest-is-dir? dest-trailing-dir?
           (not dest-fat?)
           (not (file-directory? dest-path)))
  (error 'mcopy "Destination directory does not exist" dest))

(for-each
  (lambda (src)
    (let* ((src-fat? (fat-path-string? src))
           (src-path (if src-fat? (string->fat-path src) src))
           (src-dir? (if src-fat?
                         (fat-directory? fs src-path)
                         (file-directory? src-path)))
           (name (if src-fat?
                     (if (null? src-path)
                         ""
                         (car (reverse src-path)))
                     (path-basename src)))
           (into-dir? (or dest-is-dir?
                          (and src-dir? recursive? dest-fat?
                               (fatfs-file-exists? fs dest-path)
                               (fat-directory? fs dest-path))
                          (and src-dir? recursive? (not dest-fat?)
                               (file-directory? dest-path))))
           (target (if into-dir?
                       (if dest-fat?
                           (if (string=? name "")
                               dest-path
                               (append dest-path (list name)))
                           (path-join dest-path name))
                       dest-path)))
      (when (and src-dir? (not recursive?))
        (error 'mcopy "Cannot copy directory without -s" src))
      (cond
        ((and src-fat? dest-fat?)
         (copy-fat-tree-to-fat src-path target))
        (src-fat?
         (copy-fat-tree src-path target))
        (dest-fat?
         (copy-host-tree src-path target))
        (else
         (error 'mcopy "At least one of source or destination must be a DOS path (::)"
                src dest)))))
  sources)

(close-fatfs fs)
