;; $Id: deb.scm,v 1.2 2004/06/17 14:11:18 hip Exp $
;; gauche version of rep version of deb
(use srfi-1)
(use file.util)
(load "./time")

(define status-file "/var/lib/dpkg/status")
(define cache "deb.cache")
;; pool structure:
;; ((package-name (version "1.2") (depends (x y z)))
;;  (package-name (version "1.2") (depends (x y z))))
(define pool '(packages))
(define p-total 0)
(define p-installed 0)

(define (pool-size)
  (length (cdr pool)))

(define (pool-reset)
  (set! pool '(packages))
  (set! p-total 0)
  (set! p-installed 0))

;;----------------------------------------------------------------------
;; pool test
;;(define pool
;;  '((sawfish (version "1.1") (depends (a b c)))
;;    (librep (version "2.3") (section libs))))

(define (package-add package)
  (set! pool (cons package pool)))

(define (package-record package)
  (assoc package pool))

(define (package-attr package attribute)
  (second (assoc attribute (cdr (package-record package)))))

(define (package-dependencies package)
  (let ((deps (assoc 'depends (cdr (package-record package)))))
    (if deps
        (second deps)
        ())))

(define (package-add-attr package attribute value)
  (nconc (package-record package) (list (list attribute value))))

(define (package-info package)
  "Display a nicely formatted view of the package's information"
  (if (package-record package)
      (begin
        (format #t "package: ~a\n" package)
        (for-each (lambda (entry)
                    (format #t "~a: ~s\n" (first entry) (second entry)))
                  (cdr (package-record package))))
      (format #t "Package '~a' not installed.\n" package)))

;;(puts (package-record 'sawfish))
;;(puts (package-attr 'sawfish 'version))
;;(package-add-attr 'sawfish 'test "42")
;;(puts (package-record 'sawfish))
;;(puts (package-attr 'sawfish 'test))
;;(package-add 'foo)
;;(package-add-attr 'foo 'test 32)
;;(puts pool)
;;----------------------------------------------------------------------

;; TODO move these into stdlib
(define (peek . form)
  (format #t ";;; ~s\n" form)
  (last form))

(define (split-depends txt)
  ;; FIXME handle more intricate cases:
  ;; simple types:
  ;; 1. named      : libc6
  ;; 2. versioned  : libc6 (>= 2.3.1)
  ;; combined types (each element is a simple type)
  ;; 3. alternative: libc6 | libc5
  ;; 4. multiple   : libc6, xlibs, libgmp3
  ;;
  ;; first split on possible commas, then on possible pipes, then see
  ;; if it's just a named or a versioned dependency
  (let ((deps (string-split txt #/,\s*/)))
    (list
     (map (lambda (dep)
            (rxmatch-if (#/(.*?) \((.*?) (.*?)\)/ dep) (#f name op ver)
              (list (sym name) (sym op) ver)
              (sym dep))) ;; or (list (sym dep) (sym "=") "*") ??
          deps))))

;; (load "unit-test-fn")
;; (unit-test (split-depends "") => '())
;; (unit-test (split-depends "a") => '((a)))
;; (unit-test (split-depends "a, b") => '((a b)))
;; (unit-test (split-depends "a (> 1), b") => '(((a > "1") b)))

(define (sym name)
  (string->symbol name))

(define (parse-package record)
  (let ((result '()))
    (define (add field)
      (set! result (append (list field) result)))
    (dolist (line record)
      (rxmatch-if (#/^(\w+): (.*)$/ line) (#f attr value)
        (case (sym attr)
          ((Package) (set! result (list (sym value))))
          ((Status) (add `(status ,value)))
          ;;((Status) (add `(status ,@(string-split value " "))))
          ((Priority) (add `(priority ,(sym value))))
          ;; FIXME split on possible /'s
          ((Section) (add `(section ,(sym value))))
          ((Installed-Size) 'ok) ;(add `(installed-size ,value)))
          ((Maintainer) 'ok) ;(add `(maintainer ,value)))
          ((Source) 'ok) ;(add `(source ,value)))
          ((Version) (add `(version ,value)))
          ((Provides) (add `(provides ,@(split-depends value))))
          ((Recommends) (add `(recommends ,@(split-depends value))))
          ((Suggests) (add `(suggests ,@(split-depends value))))
          ((Conflicts) (add `(conflicts ,@(split-depends value))))
          ((Essential) (add `(essential ,value)))
          ((Conffiles) 'ok) ;(add `(conffiles ,value)))
          ((Replaces) (add `(replaces ,@(split-depends value))))
          ((Depends) (add `(depends ,@(split-depends value))))
          ((Description) (add `(description ,value)))
          ((Architecture) 'ok) ;(add `(architecture ,value)))
          ((Filename) 'ok) ;(add `(filename ,value)))
          ((Size) 'ok) ;(add `(size ,value)))
          ((MD5sum) 'ok) ;(add `(md5sum ,value)))
          (else (add `(UNKNOWN ,value))))
        #f))
    (reverse result)))

(define (add-to-pool record)
  (when (string=? (cadr (assoc 'status record)) "install ok installed")
    (inc! p-installed)
    (set! pool (append pool (list record)))))

(define (string-empty? s)
  (= 0 (string-length s)))

;; FIXME this code smells bad
(define (transform los)
  "transform ('a' 'b' '' 'c' 'd' '') into (('a' 'b') ('c' 'd'))"
  (let ((index los)
        (result '()))
    (define (collect-sequence los)
      (cond ((or (null? los)
                 (string-empty? (car los)))
             (set! index (if (null? los)
                             '()
                             (cdr los)))
             '())
            (else (cons (car los)
                        (collect-sequence (cdr los))))))
    (while (not (null? index))
      (set! result (cons (collect-sequence index) result)))
    result))

(define (parse-status-file records)
  (for-each (lambda (item)
              (inc! p-total)
              (add-to-pool (parse-package item)))
            (transform records)))

(define (read-pool)
  (pool-reset)
  (if (cache-valid?)
      (begin
        (print "reading cache...")
        (time (read-pool-from-disk)))
      (begin
        (print "reading status file...")
        ;;(let ((content (time (file->string status-file))))
        (let ((content (time (file->string-list status-file))))
          (print "parsing status file...")
          (time (parse-status-file content))
          (format #t "~d packages, ~d installed\n" p-total p-installed)
          ;;(time (write-pool-to-disk/gdbm))
          (time (write-pool-to-disk))))))

(define (read-pool-from-disk)
  (with-input-from-file cache
    (lambda ()
      (set! pool (read))))
  #t)

(define (cache-valid?)
  (and (file-exists? cache)
       (file-mtime>? cache status-file)))

(define (write-pool-to-disk)
  (print "writing pool to disk")
  (with-output-to-file cache
    (lambda ()
      (format #t "~s\n" pool)))
  #t)

(use dbm.gdbm)
(define dbname "deb.db")
(define (write-pool-to-disk/gdbm)
  (print "writing pool to disk using gdbm")
  (when (file-exists? dbname)
    (sys-remove dbname))
  (let ((db (gdbm-open dbname 0 |GDBM_WRCREAT| |GDBM_FAST|)))
    (for-each (lambda (item)
                (let ((name (symbol->string (car item)))
                      (content (format "~s" (cdr item))))
                  (gdbm-store db name content)))
              (cdr pool))
    (gdbm-close db)))

;; (use dbm.gdbm)
;; (let ((db (dbm-open <gdbm> :path "/tmp/gauche.db" :rw-mode :create)))
;;   (do ((n 0 (+ n 1)))
;;       ((= n 10))
;;     (dbm-put! db
;;               (string-append "key-" (number->string n))
;;               (string-append "value-" (number->string n))))
;;   (print (dbm-map db (lambda (k v) (cons k v))))
;;   (dbm-close db))

;; (define (write-pool-to-gdbm)
;;   (require 'rep.io.db.gdbm)
;;   (let ((db (gdbm-open "deb.db" 'write)))
;;     (dolist (rec (cdr pool))
;;       ;; FIXME convert rec into read syntax
;;       (gdbm-store db (symbol-name (first rec)) (format nil "%s" rec)))
;;     (gdbm-close db)))

(define (dependency-names-of name)
  (map (lambda (dep)
         (if (symbol? dep)
             dep
             (car dep)))
       (package-dependencies name)))

(define (package-names)
  (map car (cdr pool)))

(define (package-has-dependency? name dep)
  (let ((deps (dependency-names-of name)))
    (and deps
         (memq dep deps)
         #t)))

(define (reverse-dependencies name)
  (filter (lambda (candidate)
            (package-has-dependency? candidate name))
          (package-names)))

;; (require 'compiler)
;; (compile-function read-pool)
;;(read-pool)
;;(puts pool)
;;(format #t "record for gauche:\n~s\n" (package-record 'gauche))
;;(format #t "reverse deps for libgmp3:\n~s\n" (reverse-dependencies 'libgmp3))

(define (print-info name)
  (print "----------------")
  (if (assoc name pool)
      (begin
        (package-info name)
        ;;(format #t "-- record for '~a':\n~s\n"
        ;;        name (package-record name))
        (format #t "\ndependencies: ~s\n"
                (dependency-names-of name))
        (format #t "\nreverse dependencies: ~s\n"
                (reverse-dependencies name)))
      (format #t "package '~a' is not installed\n" name)))

(define (main args)
  (print ";; deb/gauche 0.1")
  (read-pool)
  (for-each print-info (map sym (cdr args))))

;;(read-eval-print-loop)