Megatest

Check-in [b3697b5f12]
Login
Overview
Comment:Merged fork
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.60
Files: files | file ages | folders
SHA1: b3697b5f122d4d672a49716420b7181216841dd4
User & Date: mrwellan on 2016-01-26 16:06:14
Other Links: branch diff | manifest | tags
Context
2016-01-27
10:35
Merged fork check-in: ae9052fa69 user: mrwellan tags: v1.60
2016-01-26
16:06
Merged fork check-in: b3697b5f12 user: mrwellan tags: v1.60
15:51
Cleaned up sretrieve.scm, removed concept of iter and package check-in: 6ec9cabddc user: mrwellan tags: v1.60
2016-01-15
15:55
added tar cmd check-in: 3bf186fbfc user: pjhatwal tags: v1.60
Changes

Modified spublish.scm from [ed7c9f585a] to [d9dd46dab2].

163
164
165
166
167
168
169





















170
171
172
173
174
175
176
			     (flush-output)
			     (loop)))
			 "action is happening thread")))
      (thread-start! th1)
      (thread-start! th2)
      (thread-join! th1))
    (cons #t "Successfully saved data")))






















(define (spublish:validate target-dir targ-mk)
  (let* ((normal-path (normalize-pathname targ-mk))
        (targ-path (conc target-dir "/" normal-path)))
    (if (string-contains   normal-path "..")
    (begin
      (print "ERROR: Path  " targ-mk " resolved outside target area "  target-dir )







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
			     (flush-output)
			     (loop)))
			 "action is happening thread")))
      (thread-start! th1)
      (thread-start! th2)
      (thread-join! th1))
    (cons #t "Successfully saved data")))

;; copy directory to dest, validation is done BEFORE calling this
;;

(define (spublish:tar configdat submitter target-dir dest-dir comment)
  (let ((dest-dir-path (conc target-dir "/" dest-dir)))
       (if (not(file-exists? dest-dir-path))
	(begin
	  (print "ERROR: target directory " dest-dir-path " does not exists." )
	  (exit 1)))
    ;;(print dest-dir-path )
    (spublish:db-do
     configdat
     (lambda (db)
       (spublish:register-action db "tar" submitter dest-dir-path comment)))
       (change-directory dest-dir-path)
       (process-wait (process-run "/bin/tar" (list "xf" "-")))
       (print "Data copied to " dest-dir-path) 

        (cons #t "Successfully saved data")))


(define (spublish:validate target-dir targ-mk)
  (let* ((normal-path (normalize-pathname targ-mk))
        (targ-path (conc target-dir "/" normal-path)))
    (if (string-contains   normal-path "..")
    (begin
      (print "ERROR: Path  " targ-mk " resolved outside target area "  target-dir )
373
374
375
376
377
378
379
380
381
382
383
384










385
386
387
388
389
390
391
	      (targ-file   (pathname-strip-directory src-path)))
	 (if (not (file-read-access? src-path))
	     (begin
	       (print "ERROR: source file not readable: " src-path)
	       (exit 1)))
	 (if (directory? src-path)
	     (begin
	       (print "ERROR: source file is a directory, this is not supported yet.")
	       (exit 1)))
	 (print "publishing " src-path-in " to " target-dir)
         (spublish:validate     target-dir dest-dir)
	 (spublish:cp configdat user src-path target-dir targ-file dest-dir msg)))










      ((mkdir)
        (if (< (length args) 1)
          (begin 
	     (print "ERROR: Missing arguments; " (string-intersperse args ", "))
	     (exit 1)))
        (let* ((targ-mk (car args))
               (msg         (or (args:get-arg "-m") ""))) 







|

|
|
|
>
>
>
>
>
>
>
>
>
>







394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
	      (targ-file   (pathname-strip-directory src-path)))
	 (if (not (file-read-access? src-path))
	     (begin
	       (print "ERROR: source file not readable: " src-path)
	       (exit 1)))
	 (if (directory? src-path)
	     (begin
              (print "ERROR: source file is a directory, this is not supported yet.")
	       (exit 1)))
	     (print "publishing " src-path-in " to " target-dir)
             (spublish:validate     target-dir dest-dir)
	     (spublish:cp configdat user src-path target-dir targ-file dest-dir msg)))
      ((tar)
        (if (< (length args) 1)
          (begin 
	     (print "ERROR: Missing arguments; " (string-intersperse args ", "))
	     (exit 1)))
        (let* ((dst-dir (car args))
               (msg         (or (args:get-arg "-m") "")))
               (spublish:validate     target-dir  dst-dir)
               (spublish:tar configdat user target-dir dst-dir msg)))
 
      ((mkdir)
        (if (< (length args) 1)
          (begin 
	     (print "ERROR: Missing arguments; " (string-intersperse args ", "))
	     (exit 1)))
        (let* ((targ-mk (car args))
               (msg         (or (args:get-arg "-m") ""))) 
502
503
504
505
506
507
508
509
510
511
					    (sql db "SELECT * FROM actions")))))
	(else
	 (print "ERROR: Unrecognised command. Try \"spublish help\""))))
     ;; multi-word commands
     ((null? rema)(print spublish:help))
     ((>= (length rema) 2)
      (apply spublish:process-action configdat (car rema)(cdr rema)))
     (else (print "ERROR: Unrecognised command. Try \"spublish help\"")))))

(main)







|


533
534
535
536
537
538
539
540
541
542
					    (sql db "SELECT * FROM actions")))))
	(else
	 (print "ERROR: Unrecognised command. Try \"spublish help\""))))
     ;; multi-word commands
     ((null? rema)(print spublish:help))
     ((>= (length rema) 2)
      (apply spublish:process-action configdat (car rema)(cdr rema)))
     (else (print "ERROR: Unrecognised command2. Try \"spublish help\"")))))

(main)