;;;;
;;;; repository.stk		-- Local repository management
;;;;
;;;; Copyright © 2006-2010 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: 26-Dec-2006 18:20 (eg)
;;;; Last file update: 20-Aug-2010 09:59 (eg)
;;;;


(define *all-packages* 		'())
(define *non-stklos-tunings*    '())


;; ----------------------------------------------------------------------
;;	ensure-repository-hierarchy ...
;; ----------------------------------------------------------------------
(define (ensure-repository-hierarchy)
  ;; Create the servers directory (eventually)
  (unless (file-exists? (stklos-pkg-servers-directory))
    (make-directories (stklos-pkg-servers-directory))
    (for-each (lambda (x)
		(let* ((name (make-path (stklos-pkg-servers-directory) x))
		       (out  (open-file name "w")))
		  (unless out
		    (error-pkg "cannot create server file ~a" name))
		  (fprintf out ";; Generated file. DO NOT EDIT\n~a\n" '())
		  (close-port out)))
	      (server-names)))
  ;; Create the cache directory (eventually)
  (unless (file-exists? (stklos-pkg-cache-directory))
    (make-directories (stklos-pkg-cache-directory))))

;; ----------------------------------------------------------------------
;;	load-repository-descriptions ...
;; ----------------------------------------------------------------------
(define (load-repository-descriptions)

  (define stklos-tunings '())  ; tuning only packages are added at the end

  (define (add-package name options)
    (let ((new (new-package name
			    :version      (key-get options :version "0.0.0")
			    :release      (key-get options :release #f)
			    :language     (key-get options :language '(r5rs))
			    :category     (key-get options :category #f)
			    :path         (key-get options :path #f)
			    :url          (key-get options :url #f)
			    :md5          (key-get options :md5 "")
			    :description  (key-get options :description "")
			    :author       (key-get options :authors "")
			    :failures     (key-get options :failures '())
			    :dependencies (key-get options :dependencies '())
			    :provides     (key-get options :provides '()))))
      ;; Store new package in list
      (set! *all-packages* (cons new *all-packages*))))

  (define (add-tuning name options)
    (let ((new (new-tuning name
			   :host    (key-get options :host)
			   :version (key-get options :version "0.0.0")
			   :release (key-get options :release #f)
			   :path    (key-get options :path "")
			   :url     (key-get options :url "")
			   :md5     (key-get options :md5 ""))))
      (if (equal? (key-get options :host) "stklos")
	(set! stklos-tunings       (cons new stklos-tunings))
	(set! *non-stklos-tunings* (cons new *non-stklos-tunings*)))))


  (define (add-description descr)
    (match-case descr
       ((interface ?name . ?options)
	(add-package name options))
       ((tuning ?name . ?options)
	(add-tuning name options))
       (else
	(error-pkg "bad package/tuning description ~S" descr))))

  (define (add-descriptions src)
    (let ((in (open-file src "r")))
      (if (not in)
	  (begin
	    (eprintf "Warning: cannot load package descriptions. File ~s created.\n"
		     src)
	    ;; create file to avoir this warning next time
	    (with-output-to-file src (lambda () (write '()))))
	  (let ((lst (read in)))
	    (close-port in)
	    (unless (eof-object? lst)
	      (for-each add-description lst))))))

  (define (add-tuning-to-package tuning)

    (define (release>? a b)
      (cond
	((not a) #t) ; a is unnumbered (it is a local file)
	((not b) #f) ; b is unnumbered (it is a local file)
	(else (> a b))))

    ;; This is only called for STklos tunings
    (let* ((name    (tuning-name tuning))
	   (version (tuning-version tuning))
	   (release (tuning-release tuning))
	   (items   (filter (lambda (x) (and (equal? (package-name x) name)
					     (equal? (package-version x) version)))
			    *all-packages*)))
      (if (null? items)
	  (eprintf "Warning: no package for tuning ~a-~a" name version)
	  (let ((old-tuning (package-tuning (car items))))
	    (if (or (not old-tuning)
		    (release>? release (tuning-release old-tuning)))
		;; This is the first tuning we see or its release number is greater
		;; than the one we have already stored in our db
		(set! (package-tuning (car items)) tuning))))))
  ;;;
  ;;; load-repository-descriptions starts here
  ;;;
  (let ((all (map (lambda (x) (make-path (stklos-pkg-servers-directory) x))
		  (server-names))))
    (for-each add-descriptions all)
    ;; Patch our database with all STklos tunings
    (for-each add-tuning-to-package stklos-tunings)))

;; ----------------------------------------------------------------------
;; 	synchronize-servers ...
;; ----------------------------------------------------------------------
(define (synchronize-servers)

  (define (sync server-name url)
    (eprintf "Synchronizing server ~S\n   ~S ... " server-name url)
    (flush-output-port (current-error-port))

    (let ((out (open-output-string)))
      (http-download url out)
      (let ((pkgs (read-from-string (get-output-string out))))
	;; Save the informations of this server
	(let* ((name (make-path (stklos-pkg-servers-directory) server-name))
	       (out  (open-file name "w")))
          (when (> (stklos-pkg-verbosity) 1)
            (eprintf "\n   [sync file: ~S] ... " name))
	  (unless out
	    (error-pkg "cannot save server descriptions of ~s" server-name))
	  (fprintf out ";; -*- Scheme -*-    Generated file DO NOT EDIT\n")
	  (fprintf out ";; Synchronization of ~a at ~s\n" server-name url)
	  (fprintf out ";; State saved ~a\n" (date))
	  (pp pkgs :port out)
	  (newline out)
	  (close-port out))))
    (eprintf "done\n"))
  ;;
  ;; synchronize-servers starts here
  ;;
  (for-each (lambda (x) (sync (car x) (cadr x)))
	    (stklos-pkg-sync-urls)))

;; ----------------------------------------------------------------------
;; 	list-repository-packages ...
;; ----------------------------------------------------------------------
(define (list-repository-packages)

  (define (display-package pkg)
    (printf "~a-~a" (package-name pkg) (package-version pkg))
    (if (> (stklos-pkg-verbosity) 0)
	(begin
	  (newline)
	  (printf "   Description: ~a\n" (package-description pkg))
	  (printf "   Category: ~a\n" (package-category pkg))
	  (printf "   STklos tuning: ~a\n" (if (package-tuning pkg) "yes" "no")))
	(printf "~a\n" (if (package-tuning pkg) " (tuning)" ""))))

  (for-each display-package
	    (sort *all-packages* package<?)))

;; ----------------------------------------------------------------------
;; 	find-package ...
;; ----------------------------------------------------------------------
(define (find-package pkg)

  (define (parse-name name)
    (let ((res (regexp-match-positions "(.+)-([0-9]+.[0-9]+.[0-9]+)" name)))
      (if res
	;; We had a version
	(values (apply substring name (cadr res))
		(apply substring name (caddr res)))
	;; No version seen
	(values name #f))))

  (receive (name version)
	   (parse-name pkg)
     (let ((candidates (filter (lambda (x) (equal? (package-name x) name))
			       *all-packages*)))
       (cond
	 ((null? candidates)	;; no package found
	  #f)
	 (version		;; a version was specified filter the list
	  (let ((res (filter (lambda (x) (equal? (package-version x) version))
			     candidates)))
	    (and (not (null? res))
		 (car res))))
	 (else 			;; return the most recent package
	  (car (last-pair (sort candidates package<?))))))))

;; ----------------------------------------------------------------------
;; 	download-package ...
;; ----------------------------------------------------------------------
(define (download-package package)
   (let ((pkg (find-package package)))
    (unless pkg
      (die (format "cannot find package ~s in repository" package)))
    ;; Try to find the package in the cache
    (let ((path (package-path pkg)))
      (cache-package-tarball package path (package-url pkg) (package-md5 pkg) #f))

    ;; See if a STklos tuning exits for this package.
    (let ((tuning (package-tuning pkg)))
      (if tuning
	(let ((path (tuning-path tuning)))
	  (cache-package-tarball package path (tuning-url tuning)
				 (tuning-md5 tuning) "stklos"))))
    pkg))

;; ----------------------------------------------------------------------
;; 	download-package-only ...
;; ----------------------------------------------------------------------
(define (download-package-only package)

  (define (cp from dir)
    (when (> (stklos-pkg-verbosity) 0)
      (eprintf "Copying ~S in directory ~S\n" (basename from) dir))
    (copy-file from (make-path dir (basename from))))

  (let* ((pkg    (download-package package))
	 (dir    (stklos-pkg-extract-dir))
	 (tuning (package-tuning pkg)))
    ;; Copy main tarball
    (cp (package-path pkg) dir)
    ;; Copy (eventually) tuning
    (when tuning
      (cp (tuning-path tuning) dir))))

;; ----------------------------------------------------------------------
;; 	cache-package-tarball ...
;; ----------------------------------------------------------------------
(define (cache-package-tarball package path url md5 host-tuning)
  (unless (file-exists? path)
    (when (> (stklos-pkg-verbosity) 0)
      (eprintf "Downloading ~a ~s ... "
	       (if host-tuning (format "~a tuning for" host-tuning) "package")
	       package))

    ;; Download file
    (http-download url path)

    ;; Verify file integrity
    (let ((lmd5 (md5sum-file path)))
      (unless (equal? lmd5 md5)
	(remove-file path)
	(error-pkg "package ~S corrupted. Cache file has been deleted" package)))

    ;; We have finished
    (when (> (stklos-pkg-verbosity) 0)
      (eprintf "done\n"))))


;; ----------------------------------------------------------------------
;; 	fill-cache ...
;; ----------------------------------------------------------------------
(define (fill-cache)
  ;; download all the packages
  (for-each (lambda (x)
	      (let ((name (format "~a-~a" (package-name x) (package-version x))))
		(download-package name)))
	    *all-packages*)
  ;; download all  the non STklos tunings
  (for-each (lambda (x)
	      (cache-package-tarball
	          (string-append (tuning-name x) "-" (tuning-version x))
		  (tuning-path x) (tuning-url x) (tuning-md5 x)
		  (tuning-host x)))
	    *non-stklos-tunings*))

;; ----------------------------------------------------------------------
;; 	clear-cache ...
;; ----------------------------------------------------------------------
(define (clear-cache)
  (let ((files (glob (make-path (stklos-pkg-cache-directory) "*.tar.gz"))))
    (for-each (lambda (x)
		(when (> (stklos-pkg-verbosity) 0)
		  (eprintf "removing ~S from cache\n" x))
		(remove-file x))
	      files)))

;; ----------------------------------------------------------------------
;; 	add-description-to-local-repository! ...
;; ----------------------------------------------------------------------
(define (add-description-to-local-repository! descr)

  (define (insert-descr lst type name version descr)
    (let Loop ((lst lst)
	       (res '()))
      (if (null? lst)
	(cons descr res)
	(let ((item (car lst)))
	  (cond
	    ((and (equal? (car item) type)
		  (equal? (cadr item) name)
		  (equal? (key-get (cddr item) :version "0.0.0") version))
	     (cons descr
		   (append res (cdr lst))))
	    (else
	     (Loop (cdr lst)
		   (cons (car lst) res))))))))

    (let* ((repo (make-path (stklos-pkg-servers-directory) "local"))
	   (old  (with-input-from-file repo read))
	   (type (car descr))
	   (name (cadr descr))
	   (vers (key-get (cddr descr) :version "0.0.0"))
	   (new  (insert-descr old type name vers descr)))
      ;; save the new version
      (with-output-to-file repo
	(lambda ()
	  (display ";; Generated -*- scheme -*- file. *DO NOT EDIT*\n\n")
	  (pp new :port #t)))))