;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Fetch, install, and manage multiple versions of CHICKEN Scheme.
;;;
;;; Copyright (c) 2019, Evan Hanson
;;;
;;; See LICENSE for details.
;;;

(declare (module (dust)))

(import (chicken condition)
        (chicken errno)
        (chicken file)
        (chicken file posix)
        (chicken foreign)
        (chicken io)
        (chicken irregex)
        (chicken memory)
        (chicken pathname)
        (chicken platform)
        (chicken port)
        (chicken process)
        (chicken process signal)
        (chicken string)
        (chicken sort)
        (chicken process-context)
        (chicken process-context posix)
        (openssl) ; NOTE this must precede http-client
        (http-client)
        (intarweb)
        (memory-mapped-files)
        (posix-groups))

(import-syntax (begin-syntax)
               (matchable))

(import-for-syntax (chicken io)
                   (chicken process))

(define-syntax ensure
  (syntax-rules ()
    ((_ test . args)
     (unless test (error . args)))))

(define DUST_VERSION
  (begin-syntax
    (let ((x (with-input-from-pipe "git describe --tags 2>/dev/null" read-line)))
      (if (string? x) x "(egg)"))))

(define DUST_ARCH
  (begin-syntax (with-input-from-pipe "uname -m" read-line)))

;; TODO better libc detection
(define DUST_FLAVOUR
  (or (include "libc-detect.scm")
      (begin-syntax
        (or (include "libc-detect.scm")
            (syntax-error "Unable to determine libc version")))))

(define DUST
  (program-name))

(define DUST_PLATFORM
  (case (software-version)
    ((freebsd openbsd) 'bsd)
    (else => values)))

;; TODO use regex instead of string
(define DUST_PREFIX_FILLER
  (make-string 255 #\x))

(define DUST_HOME
  (or (get-environment-variable "DUST_HOME") "/opt/dust"))

(define (dust-home . args)
  (string-chomp (make-pathname (cons DUST_HOME (map conc args)) #f) "/"))

(define (dust-user-home . args)
  (apply dust-home "user" (current-user-name) args))

(define (dust-in-path?)
  (member (dust-user-home "active/bin") (normalized-path)))

(define (active-version)
  (condition-case (pathname-strip-directory (read-symbolic-link (dust-user-home "active")))
    ((exn i/o file) #f)))

(define (add-exit-handler! handler)
  (let ((original-handler (exit-handler)))
    (exit-handler
     (lambda (#!optional (status 0))
       (handler status)
       (original-handler status)))))

(define (terminal-width port)
  (nth-value 1 (terminal-size port)))

(define mkdtemp
  (foreign-lambda c-string mkdtemp c-string))

(define strerror
  (define-foreign-variable strerror c-string "strerror(errno)"))

(define (create-download-directory prefix)
  (let ((path (make-absolute-pathname* prefix "..")))
    (create-directory path #t)
    (or (mkdtemp (make-pathname path ".dust-XXXXXX"))
        (error (conc "cannot create temporary directory - " strerror) prefix))))

(define (pathname? x)
  (or (irregex-search #\/ x)
      (string=? x ".")
      (string=? x "..")))

(define (valid-name? x)
  (and (not (pathname? x))
       (not (irregex-search '(: bos #\.) x))))

(define (valid-version? x)
  (valid-name? x))

(define (make-absolute-pathname* dir #!optional file ext)
  (let ((path (string-chomp (make-pathname dir file ext) "/")))
    (normalize-pathname
     (if (absolute-pathname? path)
         path
         (make-pathname (current-directory) path)))))

(define (installed-versions)
  (condition-case (sort (directory (dust-user-home "version")) string<?)
    ((exn i/o file) '())))

(define (version-exists? name)
  (directory-exists? (dust-user-home "version" name)))

(define (path-expression)
  (conc "PATH=" (qs (dust-user-home "active/bin")) ":$PATH"))

(define (manpath-expression)
  (conc "MANPATH=" (qs (dust-user-home "active/share/man")) ":$MANPATH"))

(define (print-path-instructions)
  (parameterize ((current-output-port (current-error-port)))
    (print)
    (print  "To use the active version you must run the following:")
    (print)
    (print "    eval " #\" "$(" DUST " env)" #\")
    (print)
    (print  "To make it persistent, add this command to ~/.profile")
    (print)))

(define (normalized-path)
  (map (lambda (x) (string-chomp (normalize-pathname x) "/"))
       (string-split (get-environment-variable "PATH") ":")))

(define (delete-symbolic-link* path)
  (condition-case (delete-file path)
    (e (exn i/o file)
       (unless (equal? (errno) errno/noent)
         (signal e)))))

(define (delete-directory* path)
  (condition-case (delete-directory path #t)
    (e (exn i/o file)
       (unless (equal? (errno) errno/noent)
         (signal e)))))

(define (binary-version prefix)
  (define (fail)
    (error "Could not detect binary version" prefix))
  (match (directory (make-pathname prefix "lib/chicken"))
    ((n) (or (string->number n) (fail)))
    (else (fail))))

(define (patch-text path prefix)
  (let* ((str  (with-input-from-file path read-string))
         (str* (irregex-replace/all DUST_PREFIX_FILLER str prefix)))
    (with-output-to-file path
     (lambda ()
       (write-string str*)))))

;; TODO search within buffer
;; TODO modify buffer in-place to avoid copying
(define (patch-binary path prefix)
  (let* ((file (file-open path (+ open/rdwr open/nonblock)))
         (size (file-size file))
         (mem  (map-file-to-memory #f size (+ prot/read prot/write) map/shared file))
         (str  (make-string size))
         (_    (move-memory! (memory-mapped-file-pointer mem) str size))
         (str* (irregex-replace/all
                `(: ($ ,DUST_PREFIX_FILLER) ($ (* (~ #\null))))
                str
                (lambda (m)
                  (let* ((fill (irregex-match-substring m 1))
                         (path (irregex-match-substring m 2))
                         (null (- (string-length fill)
                                  (string-length prefix))))
                    (ensure (positive? null) "Install path is too long" prefix)
                    (string-append (string-append prefix path)
                                   (make-string null #\null)))))))
    (move-memory! str* (memory-mapped-file-pointer mem) size)
    (unmap-file-from-memory mem)
    (file-close file)))

(define (patch path prefix)
  (let ((v (binary-version path)))
    (for-each (lambda (f) (patch-binary f prefix))
              (glob (conc path "/bin/c*")
                    (conc path "/lib/*.a")
                    (conc path "/lib/*.so")
                    (conc path "/lib/chicken/" (number->string v) "/*.so")))
    (for-each (lambda (f) (patch-text f prefix))
              (glob (conc path "/bin/f*")
                    (conc path "/include/chicken/*")))))

;; TODO error handling
;; TODO snapshot versions
;; TODO checksums
;; TODO caching
;; TODO extract in-process
;; TODO sanity check archive contents
(define (install version prefix)
  (let* ((source-directory (conc "chicken-" version "-" DUST_ARCH "-" DUST_PLATFORM "-" DUST_FLAVOUR))
         (source-tarball   (conc source-directory ".tar.gz")))
    (define (fetch)
      (notice "Downloading " source-tarball " from foldling.org...")
      (call-with-input-request*
       (conc "https://foldling.org/dust/" source-tarball)
       #f
       (lambda (input response)
         (call-with-output-file source-tarball
          (lambda (output)
            (let ((content-length (header-value 'content-length (response-headers response) 0)))
              (copy-port
               input
               output
               read-char
               (let ((bytes 0) (percent 0))
                 (lambda (c p)
                   (set! bytes (add1 bytes))
                   (let ((percent* (round (* (/ bytes content-length) 100))))
                     (unless (= percent* percent)
                       (notice "Downloading " source-tarball " from foldling.org (" percent "%)..."))
                     (set! percent percent*)
                     (write-char c p)))))))))))
    (define (extract)
      (notice "Extracting " source-tarball "...")
      (delete-directory* source-directory)
      (system* (conc "tar -xzpf " source-tarball))
      (patch source-directory prefix))
    (define (rename)
      (notice "Installing " source-tarball "...")
      (delete-directory* prefix)
      (rename-file source-directory prefix))
    (let ((d (current-directory))
          (t (create-download-directory prefix)))
      (add-exit-handler!
       (lambda (_)
         (delete-directory* t)))
      (dynamic-wind
       (lambda ()
         (change-directory t))
       (lambda ()
         (fetch)
         (extract)
         (rename)
         (notice "Installed CHICKEN " version " at " prefix #\newline))
       (lambda ()
         (change-directory d))))))

(define (deactivate)
  (delete-symbolic-link* (dust-user-home "active")))

(define (activate name)
  (ensure (version-exists? name) "No such version" name)
  (delete-symbolic-link* (dust-user-home "active"))
  (condition-case (create-symbolic-link (make-pathname "version" name)
                                        (dust-user-home "active"))
    (e (exn i/o file)
       (error "Could not activate version" name)
       (exit 1))))

(define (check-dust-root)
  (unless (and (directory-exists? (dust-home "user"))
               (= (file-owner (dust-home "user")) 0)
               (= (file-permissions (dust-home "user")) #o1775))
    (signal
     (condition
      `(exn message ,(conc "You must set DUST_HOME or run `" DUST " init <group>` as root"))))))

(define (initialise-dust-root group)
  (define group-info (group-information group))
  (ensure group-info "No such group" group)
  (create-directory (dust-home "user") #t)
  (set-file-owner! (dust-home "user") (current-user-id))
  (set-file-group! (dust-home "user") (caddr group-info))
  (set-file-permissions! (dust-home "user") #o1775))

(define (initialise-dust-user-home)
  (unless (get-environment-variable "DUST_HOME") (check-dust-root))
  (create-directory (dust-user-home "version") #t)
  (set-file-owner! (dust-user-home) (current-user-id))
  (set-file-owner! (dust-user-home "version") (current-user-id))
  (set-file-group! (dust-user-home) (current-group-id))
  (set-file-group! (dust-user-home "version") (current-group-id))
  (set-file-permissions! (dust-user-home) #o0755)
  (set-file-permissions! (dust-user-home "version") #o0755)
  (unless (file-exists? (dust-user-home "active"))
    (delete-symbolic-link* (dust-user-home "active"))))

(define (run-init options group)
  (initialise-dust-root group))

(define (run-env options)
  (print (path-expression))
  (print (manpath-expression)))

(define (run-status options)
  (let ((active    (active-version))
        (installed (installed-versions)))
    (print "Active:    "
           (if (not active) "(none)" active)
           (if (or (not active) (dust-in-path?)) "" " (not in PATH)"))
    (print "Installed: "
           (if (null? installed) "(none)" (string-intersperse installed))))
  (unless (dust-in-path?)
    (print-path-instructions)
    (exit 1)))

(define (run-install options name version)
  (ensure (valid-name? name) "Invalid version name" name)
  (ensure (valid-version? version) "Invalid version" version)
  (install version (dust-user-home "version" name))
  (unless (active-version) (activate name)))

(define (run-disable)
  (deactivate))

(define (run-switch options name)
  (ensure (valid-name? name) "Invalid version name" name)
  (unless (version-exists? name)
    (condition-case (run-install options name name)
      ((http client-error) (void))))
  (activate name))

(define (run-uninstall options name)
  (ensure (valid-name? name) "Invalid version name" name)
  (delete-directory* (dust-user-home "version" name))
  (when (equal? (active-version) name)
    (delete-symbolic-link* (dust-user-home "active"))))

(define (run-fetch options version destination)
  (ensure (valid-version? version) "Invalid version" version)
  (ensure (pathname? destination) "Invalid install location" destination)
  (define prefix (make-absolute-pathname* destination))
  (ensure (not (file-exists? prefix)) "File exists" destination)
  (install version prefix))

(define (print-version)
  (print "dust " DUST_VERSION " " DUST_ARCH "-" DUST_PLATFORM "-" DUST_FLAVOUR))

(define (print-usage arguments)
  (match arguments
    (("init" . _)
     (print "Usage: " DUST " init <group>"))
    (((and (or "disable" "status" "env") command) . _)
     (print "Usage: " DUST " " command))
    (((and (or "switch" "uninstall") command) . _)
     (print "Usage: " DUST " " command " <name>"))
    (("install" . _)
     (print "Usage: " DUST " install [<name>] <version>"))
    (else
     (print "Usage: " DUST " [--verbose] <command> ...")
     (print)
     (print "  status")
     (print "  init <group>")
     (print "  install [<name>] <version>")
     (print "  switch <name>")
     (print "  uninstall <name>")
     (print "  disable")
     (print))))

(define (run options arguments)
  (match arguments
    (("version")
     (print-version))
    (("init" group)
     (run-init options group))
    (("env")
     (initialise-dust-user-home)
     (run-env options))
    (("status")
     (initialise-dust-user-home)
     (run-status options))
    (("install" version (? pathname? destination))
     ;; NOTE this form does not sanity check dust-user-home
     (run-fetch options version destination))
    (("install" version)
     (initialise-dust-user-home)
     (run-install options version version))
    (("install" name version)
     (initialise-dust-user-home)
     (run-install options name version))
    (((or "disable" "off"))
     (initialise-dust-user-home)
     (run-disable))
    (("switch" name)
     (initialise-dust-user-home)
     (run-switch options name))
    (("uninstall" name)
     (initialise-dust-user-home)
     (run-uninstall options name))
    ((or () ("help"))
     (print-usage arguments))
    (else
     (print-usage arguments)
     (exit 1))))

(define (main)
  (let ((opts '())
        (args '())
        (debug #f)
        (verbose #f))
    ((flip for-each)
     (command-line-arguments)
     (lambda (arg)
       (cond
         ((member arg '("-h" "--help"))
          (print-usage '())
          (exit 0))
         ((member arg '("-v" "--version"))
          (print-version)
          (exit 0))
         ((string=? arg "--debug")
          (set! debug #t))
         ((string=? arg "--verbose")
          (set! verbose #t))
         ((irregex-search '(: bos #\-) arg)
          (print-usage args)
          (exit 1))
         (else
          (set! args (cons arg args))))))
    (handle-exceptions
        e (begin
            (when debug (signal e))
            (print #\return "Error:"
                   #\space ((condition-property-accessor 'exn 'message) e)
                   #\space ((condition-property-accessor 'exn 'arguments "") e))
            (exit 1))
      (fluid-let ((notice (let ((p (current-error-port)))
                            (if (and (terminal-port? p) verbose)
                                (lambda args
                                  (display #\return p)
                                  (display (make-string (min (terminal-width p) 80) #\space) p)
                                  (display #\return p)
                                  (for-each (lambda (x) (display x p)) args))
                                void))))
        (run (reverse opts) (reverse args))
        (exit 0)))))

(cond-expand
  (compiling
   (set-signal-handler! signal/int (lambda (_) (exit 1)))
   (main))
  (else))