Commit c2b0e00f authored by Erick Gallesio's avatar Erick Gallesio

ScmPkg tuning rewriting

parent 7a0bc3b6
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 11-Dec-2006 14:39 (eg)
;;;; Last file update: 8-Mar-2007 16:49 (eg)
;;;; Last file update: 10-Mar-2007 10:06 (eg)
;;;;
......@@ -59,7 +59,7 @@
(define *ignored-interface-clauses*
'(maintainer author description keyword license homepage snow))
'(maintainer author description keywords license homepage snow))
;; ======================================================================
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 7-Feb-2007 13:39 (eg)
;;;; Last file update: 28-Feb-2007 22:04 (eg)
;;;; Last file update: 11-Mar-2007 23:49 (eg)
;;;;
(define *scmpkg-languages*
......@@ -34,7 +34,9 @@
(snow :suffix "scm")
;; R5RS (the default)
(r5rs :suffix "scm")))
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 14-Jun-2000 17:24 (eg)
;;;; Last file update: 22-Jan-2007 23:53 (eg)
;;;; Last file update: 8-Mar-2007 20:25 (eg)
;;;;
;;
......@@ -981,12 +981,14 @@ doc>
* These procedures are specialized version of |,(ref :mark "format" "format")|.
* In these procedures, |fmt| is a string using the |format| conventions.
* |printf| outputs go on the current output port.
* |eprintf| outputs go on the current error port.
* |fprintf| outputs go on the specified |port|.
* |eprintf| outputs go on the current error port (note that eprintf always
* flushes the characters printed).
doc>
|#
(define (eprintf fmt . args)
(apply format (current-error-port) fmt args))
(apply format (current-error-port) fmt args)
(flush-output-port (current-error-port)))
(define (printf fmt . args)
(apply format #t fmt args))
......
......@@ -21,21 +21,22 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 22-Dec-2006 11:32 (eg)
;;;; Last file update: 5-Mar-2007 22:11 (eg)
;;;; Last file update: 8-Mar-2007 20:03 (eg)
;;;;
(require "getopt")
(require "match")
(include "http.stk")
(include "types.stk")
(include "params.stk")
(include "http.stk")
(include "repository.stk")
(include "pkgball.stk")
(include "add.stk")
(include "tune.stk")
(include "repository.stk")
(include "extract.stk")
(include "pkgball.stk")
(include "misc.stk")
......@@ -91,37 +92,53 @@
(if (null? actions)
'(list)
(reverse actions))))
;; ----------------------------------------------------------------------
;; global-handler ...
;; ----------------------------------------------------------------------
(define (global-handler c)
(if (and (condition? c) (condition-has-type? c &error-message))
(let ((who (condition-ref c 'location))
(msg (condition-ref c 'message)))
(format (current-error-port)
"**** ERROR: ~a~a\n"
msg
(if who (format " (in procedure ~a)" who) "")))
(format (current-error-port) "UNKNOWN error!!!\n"))
(exit 70))
;; ----------------------------------------------------------------------
;; main ...
;; ----------------------------------------------------------------------
(define (main argv)
;; Ensure that files are correctly set
(ensure-repository-hierarchy)
;; load the servers informations
(load-repository-descriptions)
;; Parse the program arguments
(let loop ((actions (stklos-pkg-arguments argv)))
(unless (null? actions)
(case ((if (pair? (car actions)) caar car) actions)
((list)
(list-repository-packages))
((sync)
(synchronize-servers))
((delete-repo)
(rm-rf (stklos-pkg-cache-directory))
(rm-rf (stklos-pkg-servers-directory))
(exit 0))
((fill-cache)
(fill-cache))
((clear-cache)
(clear-cache))
((extract)
(find-and-extract-package (cadar actions)
(stklos-pkg-extract-dir)))
((package-deps)
(for-each (lambda (x) (printf "~a\n" x))
(package-deps* (cadar actions))))
(else (die (format "bad command ~S" (car actions)))))
(loop (cdr actions))))
(exit 0))
(with-handler global-handler
;; Ensure that files are correctly set
(ensure-repository-hierarchy)
;; load the servers informations
(load-repository-descriptions)
;; Parse the program arguments
(let loop ((actions (stklos-pkg-arguments argv)))
(unless (null? actions)
(case ((if (pair? (car actions)) caar car) actions)
((list)
(list-repository-packages))
((sync)
(synchronize-servers))
((delete-repo)
(rm-rf (stklos-pkg-cache-directory))
(rm-rf (stklos-pkg-servers-directory))
(exit 0))
((fill-cache)
(fill-cache))
((clear-cache)
(clear-cache))
((extract)
(find-and-extract-package (cadar actions)
(stklos-pkg-extract-dir)))
((package-deps)
(for-each (lambda (x) (printf "~a\n" x))
(package-deps* (cadar actions))))
(else (error "bad command ~S" (car actions))))
(loop (cdr actions))))))
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 26-Dec-2006 16:23 (eg)
;;;; Last file update: 12-Feb-2007 13:30 (eg)
;;;; Last file update: 8-Mar-2007 19:40 (eg)
;;;;
......@@ -49,7 +49,3 @@
; ("stklos" "http://www.stklos.org/Snow/sync")
)))
;; ----------------------------------------------------------------------
(define *stklos-packages* '())
......@@ -21,10 +21,13 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 26-Dec-2006 18:20 (eg)
;;;; Last file update: 4-Mar-2007 13:52 (eg)
;;;; Last file update: 8-Mar-2007 22:16 (eg)
;;;;
(define interesting-tuning "stklos") ; The tuning we want to keep in our base
(define *all-packages* '())
(define *non-stklos-tunings* '())
;; ----------------------------------------------------------------------
;; ensure-repository-hierarchy ...
......@@ -37,12 +40,13 @@
(let* ((name (make-path (stklos-pkg-servers-directory) x))
(out (open-file name "w")))
(unless out
(die (format "Cannot create server file ~a" name)))
(error "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))))
;; ----------------------------------------------------------------------
......@@ -50,7 +54,7 @@
;; ----------------------------------------------------------------------
(define (load-repository-descriptions)
(define tunings '()) ; tuning only packages are added at the end
(define stklos-tunings '()) ; tuning only packages are added at the end
(define (add-package name options)
(let ((new (new-package name
......@@ -66,17 +70,19 @@
:dependencies (key-get options :dependencies '())
:provides (key-get options :provides '()))))
;; Store new package in list
(set! *stklos-packages* (cons new *stklos-packages*))))
(set! *all-packages* (cons new *all-packages*))))
(define (add-tuning name options)
(when (equal? (key-get options :host) "stklos")
(let ((new (new-tuning name
:host "stklos"
:version (key-get options :version "0.0.0")
:path (key-get options :path "")
:url (key-get options :url "")
:md5 (key-get options :md5 ""))))
(set! tunings (cons new tunings)))))
(let ((new (new-tuning name
:host (key-get options :host)
:version (key-get options :version "0.0.0")
: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
......@@ -90,17 +96,18 @@
(define (add-descriptions src)
(let ((in (open-file src "r")))
(unless in
(die (format "Cannot load description in file ~s" src)))
(error "cannot load description in file ~s" src))
(let ((lst (read in)))
(close-port in)
(for-each add-description lst))))
(define (add-tuning-to-package tuning)
;; This is only called for STklos tunings
(let* ((name (tuning-name tuning))
(version (tuning-version tuning))
(items (filter (lambda (x) (and (equal? (package-name x) name)
(equal? (package-version x) version)))
*stklos-packages*)))
*all-packages*)))
(if (null? items)
(eprintf "Warning: no package for tuning ~a-~a" name version)
(set! (package-tuning (car items)) tuning))))
......@@ -110,8 +117,8 @@
(let ((all (map (lambda (x) (make-path (stklos-pkg-servers-directory) x))
(server-names))))
(for-each add-descriptions all)
;; Patch our database with tuning-only packages
(for-each add-tuning-to-package tunings)))
;; Patch our database with all STklos tunings
(for-each add-tuning-to-package stklos-tunings)))
;; ----------------------------------------------------------------------
;; synchronize-servers ...
......@@ -129,7 +136,7 @@
(let* ((name (make-path (stklos-pkg-servers-directory) server-name))
(out (open-file name "w")))
(unless out
(die (format "cannot save server descriptions of ~s" server-name)))
(error "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))
......@@ -159,7 +166,7 @@
(printf "~a\n" (if (package-tuning pkg) " (tuning)" ""))))
(for-each display-package
(sort *stklos-packages* package<?)))
(sort *all-packages* package<?)))
;; ----------------------------------------------------------------------
;; find-package ...
......@@ -178,7 +185,7 @@
(receive (name version)
(parse-name pkg)
(let ((candidates (filter (lambda (x) (equal? (package-name x) name))
*stklos-packages*)))
*all-packages*)))
(cond
((null? candidates) ;; no package found
#f)
......@@ -194,26 +201,7 @@
;; download-package ...
;; ----------------------------------------------------------------------
(define (download-package package)
(define (download-pkgball path url md5 tuning?)
(when (> (stklos-pkg-verbosity) 0)
(eprintf "Downloading ~a ~s ... " (if tuning? "tuning for" "package") package)
(flush-output-port (current-error-port)))
(let ((out (open-file path "w")))
(unless out
(die (format "cannot open file ~s when downloading ~s" path package)))
(http-get url out)
(close-port out))
;; Verify file integrity
(let ((lmd5 (md5sum-file path)))
(unless (equal? lmd5 md5)
(remove-file path)
(die (format "Package ~S corrupted. Cache file has been deleted" package))))
;; We have finished
(when (> (stklos-pkg-verbosity) 0)
(eprintf "done\n")))
(let ((pkg (find-package package)))
(let ((pkg (find-package package)))
(unless pkg
(die (format "cannot find package ~s in repository" package)))
;; Download dependencies
......@@ -228,27 +216,60 @@
dep)))
;; Try to find the package in the cache
(let ((path (package-path pkg)))
(unless (file-exists? path)
;; Pkgball absent. download it
(download-pkgball path (package-url pkg) (package-md5 pkg) #f)))
;; See if a tuning exits for this package.
(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)))
(unless (file-exists? path)
;; Tuning absent. download it
(download-pkgball path (tuning-url tuning) (tuning-md5 tuning) #t)))))
(let ((path (tuning-path tuning)))
(cache-package-tarball package path (tuning-url tuning)
(tuning-md5 tuning) "stklos"))))
pkg))
;; ----------------------------------------------------------------------
;; 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
(let ((out (open-file path "w")))
(unless out
(error "cannot open file ~s when downloading ~s" path package))
(http-get url out)
(close-port out))
;; Verify file integrity
(let ((lmd5 (md5sum-file path)))
(unless (equal? lmd5 md5)
(remove-file path)
(error "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)
(for-each (lambda (x)
;; download all the packages
(for-each (lambda (x)
(let ((name (format "~a-~a" (package-name x) (package-version x))))
(download-package name)))
*stklos-packages*))
*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 ...
......@@ -267,22 +288,21 @@
(define (add-description-to-local-repository! descr)
(define (insert-descr lst type name version descr)
(let ((descr-tuning-only (key-get (cddr descr) :tuning-only #f)))
(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))
(Loop (cdr lst)
(cons item res)))
(else
(Loop (cdr lst)
(cons (car lst) res)))))))))
(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))
(Loop (cdr lst)
(cons item res)))
(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))
......
This diff is collapsed.
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 13-Jan-2007 23:24 (eg)
;;;; Last file update: 14-Feb-2007 14:52 (eg)
;;;; Last file update: 12-Mar-2007 00:05 (eg)
;;;;
;; ----------------------------------------------------------------------
......@@ -40,10 +40,11 @@
failures
dependencies
provides
tuning)
tuning
suffix)
(define (new-package name :key version language category path url md5 description
author failures dependencies provides tuning)
author failures dependencies provides tuning suffix)
(unless path
;; Build a path in the cache for this package
(set! path (make-path (stklos-pkg-cache-directory)
......@@ -51,8 +52,13 @@
(when (string? language)
(set! language (string->symbol language)))
(unless suffix
(set! suffix (case language
((stklos ".stk"))
(else ".scm"))))
(make-package name version language category path url md5 description
author failures dependencies provides tuning))
author failures dependencies provides tuning suffix))
;; ----------------------------------------------------------------------
;; structure tuning ...
......@@ -69,5 +75,5 @@
(unless path
;; Build a path in the cache for this tuning
(set! path (make-path (stklos-pkg-cache-directory)
(format "~a-stklos~a.tar.gz" name version))))
(make-tuning name version host path url md5))
(format "~a_~a-~a.tar.gz" name host version))))
(make-tuning name version host path url md5))
This diff is collapsed.
This source diff could not be displayed because it is too large. You can view the blob instead.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment