Megatest

(define operation (string->symbol (car (command-line-arguments))))
(define param (cadr (command-line-arguments)))
(print "Operation: " operation ", param: " param)

;; have a pool of db's to pick from
(define *dbpool* '())
(define *pool-mutex* (make-mutex))

1
(define (get-db)
  (mutex-lock! *pool-mutex*)
  (if (null? *dbpool*)
      (begin
	(mutex-unlock! *pool-mutex*)
	(let ((db (open-database param)))
	  (set-busy-handler! db (busy-timeout 10000))

  (if (eq? operation 'server)
      (tcp-listen (rpc:default-server-port))
      (tcp-listen 0)))

;; Start server thread
(define rpc:server
  (make-thread
   (cute (rpc:make-server rpc:listener) "rpc:server")
   (cute (rpc:make-server rpc:listener) "rpc:server") ;; NOTE: see equivalent code below
   'rpc:server))

;; This is what the code would look like without cute
;; (define rpc:server
;;   (make-thread
;;    (lambda ()
;;      ((rpc:make-server rpc:listener) "rpc:server"))
;;    'rpc:server))

(thread-start! rpc:server)

;;; Server side

(define (server)
  (rpc:publish-procedure!

	  (exit 1)))
    
    (sretrieve:db-do
     configdat
     (lambda (db)
       (sretrieve:register-action db "get" retriever datadir comment)))
    (change-directory datadir)
    (process-execute "tar" (append (list "cfv" "-")(filter (lambda (x)
    (process-execute "tar" (append (list "chfv" "-")(filter (lambda (x)
							     (not (member x '("." ".."))))
							   (glob "*" ".*"))))))

(define (sretrieve:validate target-dir targ-mk)
  (let* ((normal-path (normalize-pathname targ-mk))
        (targ-path (conc target-dir "/" normal-path)))
    (if (string-contains   normal-path "..")