Megatest

Check-in [15bf67d66a]
Login
Overview
Comment:Needed to follow links by default in sretrieve
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.60
Files: files | file ages | folders
SHA1: 15bf67d66a300a721948f00ad08d016f8e1e573b
User & Date: mrwellan on 2015-12-17 14:31:18
Other Links: branch diff | manifest | tags
Context
2016-01-06
09:48
Some fixes to address issues created by the per-section config processing code check-in: 2316fa6bc4 user: mrwellan tags: v1.60
2015-12-17
14:31
Needed to follow links by default in sretrieve check-in: 15bf67d66a user: mrwellan tags: v1.60
2015-12-13
23:06
Completed sretrieve check-in: 07c1d52486 user: matt tags: v1.60
Changes

Modified rpctest/rpctest-continuous-client.scm from [9a7f357955] to [ea7c1d49cf].

15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
(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))

(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))







|







15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
(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))
45
46
47
48
49
50
51
52
53







54
55
56
57
58
59
60
  (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")
   'rpc:server))








(thread-start! rpc:server)

;;; Server side

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







|

>
>
>
>
>
>
>







45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
  (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") ;; 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!

Modified sretrieve.scm from [bdaa86239f] to [d298262aee].

151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
	  (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)
							     (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 "..")







|







151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
	  (exit 1)))
    
    (sretrieve:db-do
     configdat
     (lambda (db)
       (sretrieve:register-action db "get" retriever datadir comment)))
    (change-directory datadir)
    (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 "..")