#lang racket/base
;; Copyright Neil Van Dyke.  See file "info.rkt".

(require racket/cmdline
         racket/system
         (planet neil/sudo:1:1)
         (planet neil/parted:1:0))

;; TODO: !!!

;; TODO: Regarding installing from USB stick to local hard drive...  "mount"
;; command when booted from USB stick has a line starting something like:
;; "/dev/sdb1 on /live/image type vfat (ro,noatime,"...  That gives the raw
;; device from which to copy boot sector and first partition.  We copy the
;; first 512 bytes from the raw device ("sdb") and then all of "sdb1".  Maybe
;; check for image-path starting with "/dev/" and handle it by copying first
;; 512 bytes and then first partition.  Have image-path symbol "boot" mean to
;; do this.

;; TODO: Put something like system-command/ignored-output into a library.
(define (system-command/ignored-output
         #:error-name (error-name 'system-command/ignore-output)
         #:sudo?      (sudo? #f)
         #:command    command
         #:args       (args '()))
  (let ((stdout-ob (open-output-bytes))
        (stderr-ob (open-output-bytes))
        (stdin-ib  (open-input-bytes #"")))

    (let* ((exit-code    (parameterize ((current-output-port stdout-ob)
                                        (current-error-port  stderr-ob)
                                        (current-input-port  stdin-ib))
                           (apply (if sudo?
                                      system*/exit-code/sudo
                                      system*/exit-code)
                                  command
                                  args)))
           (stdout-bytes (get-output-bytes stdout-ob))
           (stderr-bytes (get-output-bytes stderr-ob)))
      (if (zero? exit-code)
          (void)
          (error error-name
                 "command ~S had non-zero exit code (exit-code ~S, stderr ~S, stdout ~S)"
                 (cons command args)
                 exit-code
                 stderr-bytes
                 stdout-bytes)))))

(define (install-rackout-live
         #:image-path             image-path
         #:disk-path              disk-path
         #:erase-disk?            (erase-disk?            #false)
         #:want-home?             (want-home?             #true)
         #:force-disk-path?       (force-disk-path?       #false)
         ;; #:force-partition-types? (force-partition-types? #false)
         )
  (let* ((image-path (cleanse-path image-path))
         (disk-path  (cleanse-path disk-path)))
    (or (regexp-match? #rx"\\.(?:img|iso)$" (path->string image-path))
        (error 'install-rackout-live
               "Image path ~S unacceptable; must end in \".img\" or \".iso\"."
               (path->string image-path)))
    (or force-disk-path?
        (regexp-match? #rx"^/dev/disk/by-id/usb-" (path->string disk-path))
        (error 'install-rackout-live
               "Disk path ~S unacceptable; must start with \"/dev/disk/by-id/usb-\", to reduce accidents."
               (path->string disk-path)))
    (log-debug (format "Getting initial partition info for disk ~S..."
                       (path->string disk-path)))
    (let* ((initial-disk       (get-parted-disk #:disk disk-path))
           (initial-partitions (parted-disk-partitions initial-disk))
           (initial-partitions-length (length initial-partitions)))
      (log-debug (format "Disk ~S has ~S partition(s)."
                         (path->string disk-path)
                         initial-partitions-length))
      ;; TODO: Find size of image file, so we can see what partitions it will
      ;; overwrite.
      (let-values (((partitions-to-restore create-home?)
                    (if (or erase-disk? (zero? initial-partitions-length))
                        ;; Either we are erasing the disk, or there are no
                        ;; existing partitions anyway.
                        (values '() want-home?)
                        ;; We are not erasing the disk, and there is at least
                        ;; one existing partition.
                        (let loop ((initial-partitions    initial-partitions)
                                   (live-partition        #f)
                                   (partitions-to-restore '()))
                          (if (null? initial-partitions)
                              ;; We are done processing the initial partitions.
                              (cond ((not live-partition)
                                     (error 'install-rackout-live
                                            "Could not find existing (likely) RackOut Live partition on disk ~S."
                                            ;; rackout-live-partition-label
                                            (path->string disk-path)))
                                    ;; TODO: Error if "want-home?" is true, but
                                    ;; no "home-rw" partition.  To do that, we
                                    ;; need partition label info.
                                    ;;
                                    ;; TODO: Maybe also check whether "home-rw"
                                    ;; partition is valid, such as uses a
                                    ;; filesystem that RackOut Live supports.
                                    (else (values (reverse partitions-to-restore) #f)))
                              ;; There is still at least one initial partition
                              ;; left to process.
                              (let ((partition (car initial-partitions)))
                                ;; TODO: !!! get partition label information,
                                ;; so that we can do a better job of detecting
                                ;; RackOut Live partition.  Note that currently
                                ;; the partition label is "DEBIAN_LIVE" and
                                ;; that we need to do some annoying work to
                                ;; make it something else.
                                (if (equal? 1 (parted-partition-number partition))
                                    ;; Partition is #1, so check whether it's
                                    ;; RackOut Live.
                                    (if (and (equal? "fat16" (parted-partition-filesystem partition))
                                             (<= 1e8 (parted-partition-size partition) 7e8))
                                        ;; Is the RackOut Live partition.
                                        (if live-partition
                                            (error 'install-rackout-live
                                                   "There are two partitions that appear to be RackOut Live: ~S ~S"
                                                   live-partition
                                                   partition)
                                            (loop (cdr initial-partitions)
                                                  partition
                                                  partitions-to-restore))
                                        ;; Is not the RackOut Live partition.
                                        (error 'install-rackout-live
                                               "Partition #1 does not appear to be RackOut Live: ~S"
                                               partition))
                                    ;; Partition is non-#1, so just remember to
                                    ;; restore it.  (We'll do checking later.)
                                    (loop (cdr initial-partitions)
                                          live-partition
                                          (cons partition partitions-to-restore)))))))))

        ;; TODO: !!! check that all partitions are "primary", since apparently
        ;; we can't make "logical" or "extended" partitions.  er, but how to we
        ;; check that?  is the partition number over 4?

        ;; TODO: !!! check that partitions-to-restore don't overlap with image size.

        ;; TODO: !!! maybe dump partition table to a file in case something goes wrong.

        (or (file-exists? image-path)
            (error 'install-rackout-live
                   "image file ~S does not exist"
                   (path->string image-path)))
        
        (log-debug (format "Copying image ~S to disk ~S..."
                           (path->string image-path)
                           (path->string disk-path)))
        (dynamic-wind
          void
          (lambda ()
            (system-command/ignored-output
             #:error-name 'install-rackout-live
             #:sudo?      #true
             #:command    "/bin/dd"
             #:args       (list (string-append "if=" (path->string image-path))
                                (string-append "of=" (path->string disk-path))))
            (and create-home?
                 (begin
                   (log-debug "Creating home partition...")
                   ;; TODO: !!! CREATE HOME PARTITION WITH "parted mkpart" and
                   ;; then "mke2fs".  We might have to refresh Linux's cache of
                   ;; partitions after we mkpart, like for LilDeb.  (Should
                   ;; make sure that all external programs exist before we
                   ;; start.)
                   (log-warning "Not actually creating home partition!!!")
                   )))
          (lambda ()
            ;; Whether or not the "dd" succeeded, restore the other partitions and "sync".
            (if (null? partitions-to-restore)
                (log-debug "No partitions to restore.")
                (begin
                  (log-debug "Restoring any partitions...")
                  (for-each (lambda (partition)
                              (log-debug (format "Restoring partition ~S..."
                                                 partition))
                              ;; TODO: If we get an error while restoring partitions,
                              ;; should we keep trying, or print out information that
                              ;; can be used to manually reconstruct (e.g., original
                              ;; "parted print" output)?
                              (with-handlers ((exn:fail? (lambda (e)
                                                           (log-warning (format "Exception while restoring partition ~S: ~A"
                                                                                partition
                                                                                (exn-message e))))))
                                (parted-mkpart/partition #:disk      disk-path
                                                         #:partition partition)))
                            partitions-to-restore)
                  (log-debug "Doing a \"sync\"...")
                  (with-handlers ((exn:fail? (lambda (e)
                                               (log-warning (format "Exception while sync-ing: ~A"
                                                                    (exn-message e))))))
                    (system-command/ignored-output
                     #:error-name 'install-rackout-live
                     #:command    "/bin/sync"))))))))))

(define (get-rackout-boot-device-path-string)
  (error 'get-rackout-boot-device-path-string
         "!!! UNIMPLEMENTED !!!"))

;; TODO: "raco-commands" doesn't seem to run the "main" submodule.
;;
;; (module* main #f
(let ((image-path-string #f)
      (disk-path-string  #f)
      (erase-disk?       #false)
      (want-home?        #true)
      (force-disk-path?  #false))

  (command-line
   #:program "rackout-live-install"
   #:once-each
   (("-i" "--image") file
    "!!!"
    (set! image-path-string file))
   (("--image-from-boot")
    "!!!"
    (set! image-path-string (get-rackout-boot-device-path-string)))
   #:once-each
   (("-d" "--disk") file
    "!!!"
    (set! disk-path-string file))
   ;; !!!
   #:once-any
   ("--erase-disk"    "!!!" (set! erase-disk? #true))
   ("--no-erase-disk" "!!!" (set! erase-disk? #false))
   #:once-any
   ("--want-home"          "!!!" (set! want-home? #true))
   ("--no-want-home"       "!!!" (set! want-home? #false))
   #:once-any
   ("--force-disk-path"    "!!!" (set! force-disk-path? #true))
   ("--no-force-disk-path" "!!!" (set! force-disk-path? #false))
   )

  (or image-path-string
      (error "Must specify \"--image\"."))

  (or disk-path-string
      (error "Must specify \"--disk\"."))

  (install-rackout-live #:image-path image-path-string
                        #:disk-path  disk-path-string))
;; )

;;EOF