;;;;
;;;; add.stk			-- Adding a file to local server
;;;;
;;;; Copyright © 2007-2008 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@essi.fr]
;;;;    Creation date: 18-Jan-2007 16:59 (eg)
;;;; Last file update:  9-May-2008 11:31 (eg)
;;;;


;; ----------------------------------------------------------------------
;; 	local-description-add! ...
;; ----------------------------------------------------------------------
(define (local-description-add! pkgball :optional show-only)
  (receive (package tuning version)
	   (parse-pkgball-name pkgball)
     ;; Control name validity
     (unless package
       (die (format "Incorrect pkgball name ~S" pkgball)))
     (when (negative? (version-number->integer version #f))
       (die (format "Bad version number for pkgball ~S" pkgball)))

     (let ((dirname  (temporary-file-name)))
       ;; Untar the given pkgball
       (make-directory dirname)
       (untar pkgball dirname)

       ;; Adding a package or a tuning?
       (if tuning
	   (local-description-add-tuning!  pkgball package version tuning dirname
					   show-only)
	   (local-description-add-package! pkgball package version dirname
					   show-only))
       ;; Remove the temporary directory
       (rm-rf dirname))))

;; ----------------------------------------------------------------------
;; 	local-description-add-package! ...
;; ----------------------------------------------------------------------
(define (local-description-add-package! pkgball package version directory show-only)
  (when (> (stklos-pkg-verbosity) 0)
    (eprintf "Adding  package ~S (~a) to local repository\n" package version))

  (let* ((src   (make-path directory package (format "~a.spi" package)))
	 (inf   (make-path directory package "etc" "meta"))
	 (infos (append (get-package-interface src)
			(get-package-info inf))))
    (let ((descr (build-package-description pkgball package version infos)))
      (if show-only
	  (show-public-description descr)
	  (begin
	    (add-description-to-local-repository! descr)
	    (copy-file pkgball (make-path (stklos-pkg-cache-directory)
					  (basename pkgball))))))))


;; ----------------------------------------------------------------------
;; 	local-description-add-tuning! ...
;; ----------------------------------------------------------------------
(define (local-description-add-tuning! pkgball package version tuning directory
				       show-only)
  (unless (equal? tuning "stklos")
    (die "Cannot manage non STklos tunings"))
  (when (> (stklos-pkg-verbosity) 0)
    (eprintf "Adding tuning for package ~S (~a) to local repository\n"
	     package version))

  (let* ((cache-name (make-path (stklos-pkg-cache-directory) (basename pkgball)))
	 (descr     `(tuning ,(format "~a" package)
			     :version ,version
			     :host "stklos"
			     :url #f
			     :path ,cache-name
			     :md5 ,(md5sum-file pkgball))))
    (if show-only
	(show-public-description descr)
	(begin
	  (copy-file pkgball cache-name)
	  (add-description-to-local-repository! descr show-only)))))


;; ----------------------------------------------------------------------
;; 	build-package-description ...
;; ----------------------------------------------------------------------
(define (build-package-description pkgball package version lst)

  (define (get-value key default)
    (let ((val (assoc key lst)))
      (if val
	(cdr val)
	(list default))))

  (define (build-dependencies)
    (let ((val (assoc 'import lst)))
      (if val
	(map (lambda (x) (list (symbol->string x) "*"))
	     (cdr val))
	'())))

  (let ((lang   (get-value 'language 'r5rs))
	(cat    (get-value 'category "misc"))
	(descr  (get-value 'description "N/A"))
	(author (get-value 'author "none"))
	(doc    (get-value 'stklos-doc '())))
    `(interface ,(format "~a" package)
       :version ,version
       :language ,(if (pair? lang) lang (list lang))
       :category ,@cat
       :url #f
       :path ,(make-path (stklos-pkg-cache-directory) (basename pkgball))
       :md5 ,(md5sum-file pkgball)
       :description ,@descr
       :author ,@author
;;;;   :failures ()
;;;;   :provides ()
       :stklos-doc  ,@doc
       :dependencies ,(build-dependencies))))

;; ----------------------------------------------------------------------
;; 	build-user-sync-file ...
;; ----------------------------------------------------------------------
(define (build-user-sync-file dir)
  (let ((pkgs (glob (make-path dir
			       (string-append "*" (pkgball-suffix))))))
    (printf ";; -*- Scheme -*- file build automatically\n(\n")
    (for-each (lambda (x)
		(local-description-add! x #t))
	      pkgs)
    (printf ")\n;; EOF\n")))


;; ----------------------------------------------------------------------
;; 	display-description ...
;; ----------------------------------------------------------------------
(define (show-public-description descr)
  (let ((url     (stklos-pkg-default-url))
	(keylist (cddr descr)))
    ;; Desc is a local description (i.e. in a file located in the cache)
    ;; Transform it with an URL
    (key-set! keylist :url (make-path url (basename (key-get keylist :path))))
    (key-set! keylist :path #f))
  (pp descr :port #t))