Megatest

Diff
Login

Differences From Artifact [aff106f1a7]:

To Artifact [b0df4daba9]:


26
27
28
29
30
31
32


33
34
35
36
37
38
39
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41







+
+







(import (prefix ini-file ini:))

(use canvas-draw)
(import canvas-draw-iup)

(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))
(include "/nfs/site/disks/icf_fdk_cw_gwa002/srehman/fossil/dbi/dbi.scm")
(import (prefix dbi dbi:))

(declare (uses configf))
(declare (uses tree))
(declare (uses margs))
;; (declare (uses dcommon))
;; (declare (uses launch))
;; (declare (uses gutils))
112
113
114
115
116
117
118
119

120
121
122
123
124
125
126
114
115
116
117
118
119
120

121
122
123
124
125
126
127
128







-
+







;;======================================================================
;; DB
;;======================================================================

(define (datashare:initialize-db db)
  (for-each
   (lambda (qry)
     (sqlite3:execute db qry))
     (dbi:exec db qry))
   (list 
    "CREATE TABLE pkgs 
         (id           INTEGER PRIMARY KEY,
          area         TEXT,
          version_name TEXT,
          store_type   TEXT DEFAULT 'copy',
          copied       INTEGER DEFAULT 0,
140
141
142
143
144
145
146
147

148
149

150
151
152


153
154

155
156
157

158
159

160
161
162

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
142
143
144
145
146
147
148

149
150

151
152
153

154
155
156

157
158
159

160
161

162
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







-
+

-
+


-
+
+

-
+


-
+

-
+


-
+




-
+

-
+






-
+


-
+



-
-
-
+
+
+







          destlink  TEXT);"
    "CREATE TABLE disks
         (id         INTEGER PRIMARY KEY,
          storegrp   TEXT,
          path       TEXT);")))

(define (datashare:register-data db area version-name store-type submitter quality source-path comment)
  (let ((iter-qry       (sqlite3:prepare db "SELECT max(iteration) FROM pkgs WHERE area=? AND version_name=?;"))
  (let ((iter-qry       (dbi:prepare db "SELECT max(iteration) FROM pkgs WHERE area=? AND version_name=?;"))
	(next-iteration 0))
    (sqlite3:with-transaction
    (dbi:with-transaction
     db
     (lambda ()
       (sqlite3:for-each-row
       (dbi:for-each-row
        (lambda (output)
	(lambda (iteration)
	  (if (and (number? iteration)
	  (if (and (number? (vector-refiteration)
		   (>= iteration next-iteration))
	      (set! next-iteration (+ iteration 1))))
	iter-qry area version-name)
	iter-qry area version-name))
       ;; now store the data
       (sqlite3:execute db "INSERT INTO pkgs (area,version_name,iteration,store_type,submitter,source_path,quality,comment) 
       (dbi:exec db "INSERT INTO pkgs (area,version_name,iteration,store_type,submitter,source_path,quality,comment) 
                                 VALUES (?,?,?,?,?,?,?,?);"
			area version-name next-iteration (conc store-type) submitter source-path quality comment)))
    (sqlite3:finalize! iter-qry)
    (dbi:close iter-qry)
    next-iteration))

(define (datashare:get-id db area version-name iteration)
  (let ((res #f))
    (sqlite3:for-each-row
    (dbi:for-each-row
     (lambda (id)
       (set! res id))
       (set! res (vector-ref id 0)))
     db
     "SELECT id FROM pkgs WHERE area=? AND version_name=? AND iteration=?;"
     area version-name iteration)
    res))

(define (datashare:set-stored-path db id path)
  (sqlite3:execute db "UPDATE pkgs SET stored_path=? WHERE id=?;" path id))
  (dbi:exec db "UPDATE pkgs SET stored_path=? WHERE id=?;" path id))

(define (datashare:set-copied db id value)
  (sqlite3:execute db "UPDATE pkgs SET copied=? WHERE id=?;" value id))
  (dbi:exec db "UPDATE pkgs SET copied=? WHERE id=?;" value id))
  
(define (datashare:get-pkg-record db area version-name iteration)
  (let ((res #f))
    (sqlite3:for-each-row
     (lambda (a . b)
       (set! res (apply vector a b)))
    (dbi:for-each-row
     (lambda (output)
       (set! res output))
     db 
     "SELECT * FROM pkgs WHERE area=? AND version_name=? AND iteration=?;"
     area 
     version-name
     iteration)
    res))

204
205
206
207
208
209
210
211

212
213
214
215

216
217

218
219
220
221
222
223
224
207
208
209
210
211
212
213

214
215
216
217

218
219

220
221
222
223
224
225
226
227







-
+



-
+

-
+







;; is put. 
;;
;; if there is nothing at that location then the record can be removed
;; if there are no refs for a particular pkg-id then that pkg-id is a 
;; candidate for removal
;;
(define (datashare:record-pkg-ref db pkg-id dest-link)
  (sqlite3:execute db "INSERT INTO refs (pkg_id,destlink) VALUES (?,?);" pkg-id dest-link))
  (dbi:exec db "INSERT INTO refs (pkg_id,destlink) VALUES (?,?);" pkg-id dest-link))
  
(define (datashare:count-refs db pkg-id)
  (let ((res 0))
    (sqlite3:for-each-row
    (dbi:for-each-row
     (lambda (count)
       (set! res count))
       (set! res (vector-ref count 0))
     db
     "SELECT count(id) FROM refs WHERE pkg_id=?;"
     pkg-id)
    res))

;; Create the sqlite db
(define (datashare:open-db configdat) 
232
233
234
235
236
237
238
239
240


241
242
243
244
245
246
247
235
236
237
238
239
240
241


242
243
244
245
246
247
248
249
250







-
-
+
+







	       (handler   (make-busy-timeout 136000)))
	  (handle-exceptions
	   exn
	   (begin
	     (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath
			  ((condition-property-accessor 'exn 'message) exn))
	     (exit))
	   (set! db (sqlite3:open-database dbpath)))
	  (if *db-write-access* (sqlite3:set-busy-handler! db handler))
	   (set! db (dbi:open 'sqlite3 (cons (cons ('dbname dbpath) '()))))
	  ;;(if *db-write-access* (sqlite3:set-busy-handler! db handler))
	  (if (not dbexists)
	      (begin
		(datashare:initialize-db db)))
	  db)
	(print "ERROR: invalid path for storing database: " path))))

(define (open-run-close-exception-handling proc idb . params)
262
263
264
265
266
267
268
269

270
271
272
273
274
275

276
277
278
279
280
281
282
283
284
285



286
287
288
289
290
291
292
293
294
295
296
297



298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318


319
320
321

322
323
324
325
326
327
328
265
266
267
268
269
270
271

272
273
274
275
276
277

278
279
280
281
282
283
284
285



286
287
288
289
290
291
292
293
294
295
296
297



298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320

321
322
323
324

325
326
327
328
329
330
331
332







-
+





-
+







-
-
-
+
+
+









-
-
-
+
+
+




















-
+
+


-
+







        (print "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
     (apply open-run-close-exception-handling proc idb params))
   (apply open-run-close-no-exception-handling proc idb params)))

(define (open-run-close-no-exception-handling  proc idb . params)
  ;; (print "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
  (let* ((db (cond
	      ((sqlite3:database? idb)     idb)
	      ((dbi:database? idb)     idb)
	      ((not idb)                   (print "ERROR: cannot open-run-close with #f anymore"))
	      ((procedure? idb)            (idb))
	      (else                        (print "ERROR: cannot open-run-close with #f anymore"))))
	 (res #f))
    (set! res (apply proc db params))
    (if (not idb)(sqlite3:finalize! dbstruct))
    (if (not idb)(dbi:close dbstruct))
    ;; (print "open-run-close-no-exception-handling END" )
    res))

(define open-run-close open-run-close-no-exception-handling)

(define (datashare:get-pkgs db area-filter version-filter iter-filter)
  (let ((res '()))
    (sqlite3:for-each-row ;; replace with fold ...
     (lambda (a . b)
       (set! res (cons (list->vector (cons a b)) res)))
    (dbi:for-each-row ;; replace with fold ...
     (lambda (output)
       (set! res (cons output res)))
     db 
     (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path "
	   " FROM pkgs WHERE area like ? AND version_name LIKE ? AND iteration " iter-filter ";")
     area-filter version-filter)
    (reverse res)))

(define (datashare:get-pkg db area-name version-name #!key (iteration #f))
  (let ((dat '())
	(res #f))
    (sqlite3:for-each-row ;; replace with fold ...
     (lambda (a . b)
       (set! dat (cons (list->vector (cons a b)) dat)))
    (dbi:for-each-row ;; replace with fold ...
     (lambda (output)
       (set! dat (cons output dat)))
     db 
     (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path "
	   " FROM pkgs WHERE area=? AND version_name=? ORDER BY iteration ASC;")
     area-name version-name)
    ;; now filter for iteration, either max if #f or specific one
    (if (null? dat)
	#f
	(let loop ((hed (car dat))
		   (tal (cdr dat))
		   (cur 0))
	  (let ((itr (datashare:pkg-get-iteration hed)))
	    (if (equal? itr iteration) ;; this is the one if iteration is specified
		hed
		(if (null? tal)
		    hed
		    (loop (car tal)(cdr tal)))))))))

(define (datashare:get-versions-for-area db area-name #!key (version-patt #f))
  (let ((res '())
	(data (make-hash-table)))
    (sqlite3:for-each-row
    (dbi:for-each-row
      (lambda (output)
     (lambda (version-name submitter iteration submitted-time comment)
       ;;                                              0           1         2           3           4
       (hash-table-set! data version-name (vector version-name submitter iteration submitted-time comment)))
       (hash-table-set! data version-name (vector version-name submitter iteration submitted-time comment))))
     db 
     "SELECT version_name,submitter,iteration,datetime,comment FROM pkgs WHERE area='megatest' AND version_name != 'latest' AND version_name LIKE ? ORDER BY datetime asc;"
     (or version-patt "%"))
    (map (lambda (x)(hash-table-ref data x))(sort (hash-table-keys data) string-ci>=))))

;;======================================================================
;; DATA IMPORT/EXPORT
339
340
341
342
343
344
345
346

347
348
349
350
351
352
353

354
355
356
357
358
359
360
343
344
345
346
347
348
349

350
351
352
353
354
355
356

357
358
359
360
361
362
363
364







-
+






-
+







	  (create-directory targ-path #t)
	  (datashare:set-stored-path db id targ-path)
	  (print "Running command: rsync -av " source-path "/ " targ-path "/")
	  (let ((th1 (make-thread (lambda ()
				    (let ((pid (process-run "rsync" (list "-av" (conc source-path "/") (conc targ-path "/")))))
				      (process-wait pid)
				      (datashare:set-copied db id "yes")
				      (sqlite3:finalize! db)))
				      (dbi:close db)))
				   "Data copy")))
	    (thread-start! th1))
	  #t)
	(begin
	  (print "ERROR: Not enough space in storage area " dest-path)
	  (datashare:set-copied db id "no")
	  (sqlite3:finalize! db)
	  (dbi:close db)
	  #f))))

(define (datashare:get-areas configdat)
  (let* ((areadat (configf:get-section configdat "areas"))
	 (areas   (if areadat (map car areadat) '())))
    areas))

375
376
377
378
379
380
381
382

383
384
385
386
387
388
389
379
380
381
382
383
384
385

386
387
388
389
390
391
392
393







-
+







		  (datashare:set-latest db id area-name version iteration)))
	      (let ((id (datashare:get-id db area-name version iteration)))
		(datashare:set-stored-path db id spath)
		(datashare:set-copied db id "yes")
		(datashare:set-copied db id "n/a")
		(datashare:set-latest db id area-name version iteration)))
	  (print "ERROR: Failed to get an iteration number"))
      (sqlite3:finalize! db)
      (dbi:close db)
      (cons #t "Successfully saved data")))))

(define (datashare:get-best-storage configdat)
  (let* ((storage     (configf:lookup configdat "settings" "storage"))
	 (store-areas (if storage (string-split storage) '())))
    (print "Looking for available space in " store-areas)
    (datashare:find-most-space store-areas)))
605
606
607
608
609
610
611
612

613
614
615
616
617
618
619
609
610
611
612
613
614
615

616
617
618
619
620
621
622
623







-
+







				(lambda (area)
				  (let* ((path     (conc "/" (cadr area)))
					 (fullpath (conc basepath path)))
				    (if (not (hash-table-ref/default installed-dat path #f))
					(tree:add-node tb2 "Installed" (datashare:path->lst path)))
				    (hash-table-set! installed-dat path (datashare:pathdat-apply-heuristics configdat fullpath))))
				areas)
			       (sqlite3:finalize! db))))
			       (dbi:close db))))
	   (apply          (iup:button "Apply"
				       #:action
				       (lambda (obj)
					 (if curr-record
					     (let* ((area        (datashare:pkg-get-area        curr-record))
						    (stored-path (datashare:pkg-get-stored_path curr-record))
						    (source-type (datashare:pkg-get-store_type  curr-record))
737
738
739
740
741
742
743
744

745
746
747
748
749
750
751
741
742
743
744
745
746
747

748
749
750
751
752
753
754
755







-
+







				     ((link) (datashare:pkg-get-source-path curr-record))
				     ((copy) stored-path)
				     (else #f)))
		      (dest-stub   (configf:lookup configdat "areas" area))
		      (target-path (conc basepath "/" dest-stub)))
		 (datashare:build-dir-make-link stored-path target-path)
		 (datashare:record-pkg-ref db (datashare:pkg-get-id curr-record) target-path)
		 (sqlite3:finalize! db)
		 (dbi:close db)
		 (print "Creating link from " stored-path " to " target-path))))))
    ((publish)
     (if (< (length args) 3)
	 (begin 
	   (print "ERROR: Missing arguments; " (string-intersperse args ", "))
	   (exit 1))
	 (let* ((srcpath  (list-ref args 0))
779
780
781
782
783
784
785
786

787
788
789
790
791
792
793
783
784
785
786
787
788
789

790
791
792
793
794
795
796
797







-
+







			  (vector-ref x 0)
			  (vector-ref x 1) 
			  (vector-ref x 2) 
			  (conc "\"" (time->string (seconds->local-time (vector-ref x 3))) "\"")
			  (conc "\"" (vector-ref x 4) "\""))
		  (print (vector-ref x 0))))
	    versions)
       (sqlite3:finalize! db)))))
       (dbi:close db)))))

;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION!
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.datasharerc")))
  (if (file-exists? debugcontrolf)
      (load debugcontrolf)))

(define (main)