;;; gumm.scm -- initial attempt at a Gumm interface
;;; 
;;; Authors:    Alex Shinn <foof@synthcode.com>
;;; Version:    1.0
;;; Created:    "01/12/24 21:58:35 foof"
;;; Time-stamp: "01/12/25 11:42:10 foof"
;;; Keywords:   gumm, module, lookup
;;; License:    GPL
;;;
;;; Copyright (C) 2001 Alex Shinn

(define-module (gumm gumm)
  :use-module (ice-9 format)
  :use-module (ice-9 optargs)
  :use-module (ice-9 rdelim)
  :use-module (ice-9 regex)
  :use-module (net http)
  :use-module (srfi srfi-1)
  :use-module (srfi srfi-2)
  :use-module (srfi srfi-13))

;; just the basics
(export gumm-configure gumm-search gumm-install gumm-remove)

(read-set! keywords 'prefix)

;; gumm config variables (blatantly stolen from CPAN)

;; config dirs
(define gumm-home #f)
(define gumm-config-file #f)
(define gumm-package-file #f)
(define gumm-build-dir #f)
(define gumm-source-dir #f)
;; gumm options
(define gumm-inhibit-startup-message #f)
(define gumm-prerequisites-policy 'ask)
(define gumm-scan-cache 'atstart)
(define gumm-term-charset "ISO-8859-1")
(define gumm-configure-args "")
(define gumm-make-args "")
(define gumm-make-install-args "")
(define gumm-server-list '())
;; program locations
(define gumm-programs
  '(;(ftp      . #f)  ; "/usr/bin/ftp"
    (gzip     . #f)  ; "/bin/gzip"
    ;(bzip2    . #f)  ; "/bin/bzip2"
    ;(lynx     . #f)  ; "/usr/bin/lynx"
    (make     . #f)  ; "/usr/bin/make"
    ;(ncftpget . #f)  ; "/usr/bin/ncftpget"
    ;(pager    . #f)  ; "/usr/bin/less"
    (tar      . #f)  ; "/bin/tar"
    ;(unzip    . #f)  ; "/usr/bin/unzip"
    ;(wget     . #f)  ; "/usr/bin/wget"
    ))

(define gumm-config-vars
  '(gumm-build-dir gumm-source-dir
    gumm-inhibit-startup-message gumm-prerequisites-policy
    gumm-scan-cache gumm-term-charset gumm-make-args
    gumm-make-install-args gumm-server-list gumm-programs))

;; should be fetched dynamically
(define gumm-known-servers '("http://synthcode.com/gumm"))

;; available packages
(define gumm-packages '())

;; Should probably put command-style utilities in a separate module.
;; I'm sure someone's got more complete code for this somewhere.  But I
;; can't find it easily, which is why this needs to be written :)

;; read in a string.  if default is given, use that on empty input,
;; otherwise re-prompt on empty input.
(define* (read-string prompt :optional default)
  (cond (default
          (format #t "~A [~A]: " prompt default)
          (let ((input (read-line)))
            (if (string=? input "") default input)))
        (else
         (format #t "~A: " prompt)
         (let ((input (read-line)))
           (if (string=? input "") (read-string prompt) input)))))

;; same as above but require the input to match a predicate.  if given,
;; the default need not match the pred.
;; maybe merge into the above w/ extra or keyword args?
(define* (read-string-predicate prompt pred :optional default)
  (cond (default
          (format #t "~A [~A]: " prompt default)
          (let ((input (read-line)))
            (if (string=? input "")
              default
              (if (pred input)
                input
                (read-string-predicate prompt pred default)))))
        (else
         (format #t "~A: " prompt)
         (let ((input (read-line)))
           (if (pred input) input (read-string-predicate prompt pred))))))

(define yes-rx (make-regexp "Y(ES)?"))
(define no-rx (make-regexp "NO?"))

(define (yes-or-no->char string)
  (cond ((not (string? string))
         #f)
        ((string-match "y(es)?" (string-downcase string))
         #\Y)
        ((string-match "no?" (string-downcase string))
         #\N)
        (else
         #f)))

(define (yes-or-no? prompt . args)
  ;; normalize
  (let ((default (and (pair? args) (yes-or-no->char (car args)))))
    (if default
      (format #t "~A [~A]: " prompt
              (if (char=? default #\Y) "Y/n" "y/N"))
      (format #t "~A [y/n]: " prompt))
    (let ((response (yes-or-no->char (read-line))))
      (cond ((char? response)
             (char=? response #\Y))
            ((char? default)
             (char=? default #\Y))
            (else
             (display "Please enter yes or no.\n")
             (yes-or-no? prompt))))))

;; quote expr if not self-quoting
(define (quote-maybe expr)
  (if (or (string? expr) (number? expr))
    expr
    `(quote ,expr)))

;; find a program in exec-path
(define (find-in-path prog)
  (let ((exec-path (string-tokenize (getenv "PATH") #\:)))
    (letrec ((F (lambda (l)
                  (if (null? l)
                    #f
                    (let ((file (string-append (car l) "/" prog)))
                      (if (access? file X_OK) file (F (cdr l))))))))
      (F exec-path))))

;; verify write permision in a directory and optionally the existence of
;; files within that dir.
(define (verify-dir dir . files)
  (and (access? dir (logior W_OK X_OK))
       (eq? (stat:type (stat dir)) 'directory)
       (every (lambda (f) (access? (string-append dir "/" f) R_OK)) files)
       dir))

;; verify write permission in a directory or create it if not found.
;; returns #f if the directory does not existence or you don't have
;; sufficient permision to access/create it.
(define (verify-or-create-dir dir)
  (or (verify-dir dir)
      (and (verify-or-create-dir (dirname dir)) ; recurse to get parents
           (mkdir dir)
           dir)))

;; load/save the config file
(define (gumm-load-config)
  (let ((data (call-with-input-file gumm-config-file read)))
    (map
     (lambda (var) (eval `(set! ,var ,(or (quote-maybe (assq-ref data var)) var))
                         (current-module)))
     gumm-config-vars)))

(define (gumm-save-config)
  (call-with-output-file gumm-config-file
    (lambda (p)
      (display ";;; auto-generated by gumm\n" p)
      (write
       (map (lambda (var) (cons var (eval var (current-module))))
            gumm-config-vars)
       p))))

;; setup the gumm env (called before install/remove/update when no
;; explicit configure was requested)
(define (gumm-setup-env)
  (let ((base (string-append (or (getenv "GUMM_HOME") (getenv "HOME") "")
                             "/.gumm")))
    (cond ((verify-dir base "config.scm")
           (set! gumm-home base)
           (set! gumm-config-file (string-append base "/config.scm"))
           (gumm-load-config))
          (else
           (gumm-configure)))
    (set! gumm-package-file (string-append base "/packages.scm"))
    (set! gumm-build-dir (string-append base "/build"))
    (set! gumm-source-dir (string-append base "/source"))))

;; should ask for (and use) more options
;; tab completion would be nice
(define (gumm-setup-gumm-options)
  (set! gumm-prerequisites-policy
        (string->symbol
         (read-string-predicate
          "How to handle dependencies? [ask/follow/ignore]"
          (lambda (s) (member s '("ask" "follow" "ignore")))
          "ask")))
  (set! gumm-make-args (read-string "Arguments to pass to make?" ""))
  (set! gumm-make-install-args (read-string "make install arguments?" "")))

(define (gumm-setup-gumm-servers)
  (set! gumm-server-list (append gumm-server-list gumm-known-servers)))

(define (gumm-setup-gumm-programs)
  (for-each
   (lambda (pair)
     (let* ((var (car pair))
            (name (symbol->string var))
            (value (read-string-predicate
                    (string-append "Where is " name "?")
                    (lambda (f) (access? f X_OK))
                    (find-in-path name))))
       (assq-set! gumm-programs var value)))
   gumm-programs))

(define (gumm-prompt-config)
  (gumm-setup-gumm-options)
  (gumm-setup-gumm-servers)
  (gumm-setup-gumm-programs)
  (if (yes-or-no? "Save configuration?" "Y")
    (gumm-save-config)))

;; [re]configure gumm
(define (gumm-configure)
  (let ((base (string-append (or (getenv "GUMM_HOME") (getenv "HOME") "")
                             "/.gumm")))
    (set! gumm-home
          (read-string-predicate
           "What is your gumm base dir?"
           (lambda (d) (access? (dirname d) W_OK))
           base))
    (verify-or-create-dir gumm-home)
    (set! gumm-config-file (string-append base "/config.scm"))
    (gumm-prompt-config)))

;; update the package listing
(define (gumm-update-packages)
  (gumm-setup-env)
  (chdir gumm-home)
  (let ((packages
         (with-output-to-string
           (lambda ()
             (http-get (string-append (car gumm-server-list)
                                      "/packages.scm"))))))
    ;; save the output
    (with-output-to-file gumm-package-file
      (lambda () (display packages)))
    ;; read it
    (set! gumm-packages (with-input-from-string packages read))
    (display "packages:\n")
    (write gumm-packages)
    (newline)
    ))

;; search for packages matching keywords (err... names)
;; should be split between utility and visual interfaces
(define (gumm-search keywords)
  (gumm-update-packages)
  (let ((rx (make-regexp keywords)))
    (for-each
     (lambda (x)
       (let* ((pinfo (cadr x))
              (name (assq-ref pinfo 'name)))
         (if (and (string? name) (regexp-exec rx name))
           (format #t "~A: ~A\n" name (assq-ref pinfo 'short-desc)))))
     gumm-packages)))

;; find the path to a package.  follows a P/PREFIX/ convetion.  modify
;; this for other conventions.
(define (gumm-path-to-package pinfo)
  (display "pinfo:\n")
  (write pinfo)
  (newline)
  (let* ((filename (assq-ref pinfo 'filename))
         (prefix (or (assq-ref pinfo 'prefix)
                     (car (string-tokenize filename #\-))))
         (prechar (string-ref prefix 0)))
    (string-append "/packages/" (make-string 1 prechar) "/"
                   prefix "/" filename)))

;; unpack a file in one of any number of formats (where right now any
;; means tarball). return #t on success, #f on failure.
(define (gumm-unpack file)
  (= 0 (system (string-append (assq-ref gumm-programs 'tar) " xzf " file))))

;; install a package
(define (gumm-install package)
  (gumm-update-packages)
  (and-let* ((p (assoc-ref gumm-packages package))
             (pinfo (car p)))
    ;; XXXX dependency checks might be nice ^_^
    (chdir (verify-or-create-dir gumm-source-dir))
    (let ((remote-path (gumm-path-to-package pinfo))
          (file (assq-ref pinfo 'filename)))
      ;; download the file
      (with-output-to-file file
        (lambda ()
          (http-get (string-append (car gumm-server-list) remote-path))))
      ;; unpack the file
      (and (gumm-unpack file) (delete-file file))
      ;; cd into the source dir (should this be by convention or in the
      ;; package info?).  hack it for now.
      (chdir (basename file ".tar.gz"))
      ;; ye old ./configure && make && make install
      (or (and ;(= 0 (system (string-append "./configure "
               ;                            gumm-configure-args)))
               (= 0 (system (string-append (assq-ref gumm-programs 'make)
                                           " " gumm-make-args)))
               (= 0 (system (string-append (assq-ref gumm-programs 'make)
                                           " " gumm-make-install-args
                                           " install"))))
          (error "Failed to install " package)))))

;; remove a package
(define (gumm-remove package)
  (error "I'm sorry, I can't do that Dave.\n"))

;; Samples

;(gumm-search ".*-pers-.*")
(gumm-install "ams-pers-scheme")