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

(declare (module (dust)))

(import (begin-syntax)
        (chicken condition)
        (chicken file)
        (chicken file posix)
        (chicken io)
        (chicken irregex)
        (chicken memory)
        (chicken pathname)
        (chicken platform)
        (chicken port)
        (chicken string)
        (chicken process)
        (chicken process-context)
        (chicken process-context posix)
        (openssl) ; NOTE this must precede http-client
        (http-client)
        (matchable)
        (memory-mapped-files)
        (posix-groups))

(import-for-syntax (chicken process))

(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 (installed-versions)
  (condition-case (directory (dust-user-home "version"))
    ((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 (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)
    ((exn i/o file) #f)))

(define (delete-directory* path)
  (condition-case (delete-directory path #t)
    ((exn i/o file) #f)))

(define (binary-version name)
  (define (fail)
    (signal (condition '(exn message "Could not detect binary version"))))
  (match (directory (dust-user-home "version" name "lib/chicken"))
    ((n) (or (string->number n) (fail)))
    (else (fail))))

(define (patch-text path name)
  (let* ((str  (with-input-from-file path read-string))
         (str* (irregex-replace/all DUST_PREFIX_FILLER str (dust-user-home "version" name))))
    (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 name)
  (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 ((s (string-append (dust-user-home "version" name)
                                          (irregex-match-substring m 2)))
                        (n (- (string-length (irregex-match-substring m 1))
                              (string-length (dust-user-home "version" name)))))
                    (unless (positive? n)
                      (signal
                       (condition
                        `(exn message "Install path is too long"
                              arguments (,(dust-user-home "version" name))))))
                    (string-append s (make-string n #\null)))))))
    (move-memory! str* (memory-mapped-file-pointer mem) size)
    (unmap-file-from-memory mem)
    (file-close file)))

(define (patch name)
  (let ((v (binary-version name)))
    (for-each (lambda (f) (patch-binary f name))
              (glob (dust-user-home "version" name "bin/c*")
                    (dust-user-home "version" name "lib/*.a")
                    (dust-user-home "version" name "lib/*.so")
                    (dust-user-home "version" name "lib/chicken" v "*.so")))
    (for-each (lambda (f) (patch-text f name))
              (glob (dust-user-home "version" name "bin/f*")
                    (dust-user-home "version" name "include/chicken/*")))))

(define (activate name)
  (unless (version-exists? name)
    (signal (condition `(exn message "No such version" arguments (,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)
       (signal (condition `(exn message "Could not activate version" arguments (,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))
  (unless group-info (signal (condition `(exn message "No such group" arguments (,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-user-id))
  (set-file-group! (dust-user-home "version") (current-user-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)))

(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)))))

;; TODO error handling
;; TODO snapshot versions
;; TODO checksums
;; TODO caching
;; TODO extract in-process
;; TODO sanity check archive contents
(define (run-install options name version)
  (let* ((target-directory (dust-user-home "version" name))
         (source-directory (conc "chicken-" version "-" DUST_ARCH "-" DUST_PLATFORM "-" DUST_FLAVOUR))
         (source-tarball   (conc source-directory ".tar.gz")))
    (define (fetch)
      (call-with-input-request
       (conc "https://foldling.org/dust/" source-tarball)
       #f
       (lambda (response)
         (call-with-output-file source-tarball
          (lambda (file)
            (copy-port response file))))))
    (define (extract)
      (delete-directory* source-directory)
      (system* (conc "tar -xzpf " source-tarball))
      (delete-directory* target-directory)
      (rename-file source-directory target-directory))
    (let* ((d (current-directory))
           (n (current-process-id))
           (t (create-directory (dust-user-home "cache" n) #t)))
      (dynamic-wind
       (lambda ()
         (change-directory t))
       (lambda ()
         (fetch)
         (extract)
         (patch name)
         (unless (active-version)
           (activate name)))
       (lambda ()
         (change-directory d)
         (delete-directory* t))))))

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

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

(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 "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 " <command> ...")
     (print)
     (print "  status")
     (print "  init <group>")
     (print "  install [<name>] <version>")
     (print "  switch <name>")
     (print "  uninstall <name>")
     (print))))

(define (run options arguments)
  (match arguments
    (("init" group)
     (run-init options group))
    (("env")
     (initialise-dust-user-home)
     (run-env options))
    (("status")
     (initialise-dust-user-home)
     (run-status options)
     (unless (dust-in-path?)
       (print-path-instructions)
       (exit 1)))
    (("install" version)
     (initialise-dust-user-home)
     (run-install options version version))
    (("install" name version)
     (initialise-dust-user-home)
     (run-install options name version))
    (("switch" name)
     (initialise-dust-user-home)
     (run-switch options name))
    (("uninstall" name)
     (initialise-dust-user-home)
     (run-uninstall options name))
    (("version")
     (print-version))
    ((or () ("help"))
     (print-usage arguments))
    (else
     (print-usage arguments)
     (exit 1))))

(define (main)
  (let ((opts '())
        (args '()))
    ((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))
         ((irregex-search '(: bos #\-) arg)
          (set! opts (cons arg opts)))
         (else
          (set! args (cons arg args))))))
    (unless (null? opts)
      (print-usage args)
      (exit 1))
    (handle-exceptions
        e (begin
            (when (member "--debug" opts) (signal e))
            (print "Error: " ((condition-property-accessor 'exn 'message) e)
                         " " ((condition-property-accessor 'exn 'arguments "") e))
            (exit 1))
      (run (reverse opts) (reverse args)))))

(cond-expand
  (compiling (main))
  (else))