Megatest

Check-in [5cb3a069f8]
Login
Overview
Comment:wip
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | v1.63-tdb-dotserver-refactor
Files: files | file ages | folders
SHA1: 5cb3a069f8e032fd54407a3db3c2f25c97663b8c
User & Date: bjbarcla on 2017-01-03 16:07:22
Other Links: branch diff | manifest | tags
Context
2017-01-03
16:07
wip Closed-Leaf check-in: 5cb3a069f8 user: bjbarcla tags: v1.63-tdb-dotserver-refactor
14:08
wip check-in: e617679e45 user: bjbarcla tags: v1.63-tdb-dotserver-refactor
Changes

Modified http-transport.scm from [7e12c76127] to [e1abcb3338].

397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
			(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep")
                        ;;(BB> "http-transport: ->dbprep")
			(thread-sleep! 0.5) ;; give some margin for queries to complete before switching from file based access to server based access
			(set! *dbstruct-db*  (db:setup)) ;;  run-id))
			(set! server-going #t)
			(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running")
                        ;;(BB> "http-transport: ->running")
			(server:write-dotserver *toppath* iface port (current-process-id) 'http)
                        (thread-start! *watchdog*)
                        (server:complete-attempt *toppath*))
		      (begin ;; gotta exit nicely
                        ;;(BB> "http-transport: ->collision")
			(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "collision")
			(http-transport:server-shutdown server-id port))))))
      
      ;; when things go wrong we don't want to be doing the various queries too often
      ;; so we strive to run this stuff only every four seconds or so.







|

|







397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
			(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep")
                        ;;(BB> "http-transport: ->dbprep")
			(thread-sleep! 0.5) ;; give some margin for queries to complete before switching from file based access to server based access
			(set! *dbstruct-db*  (db:setup)) ;;  run-id))
			(set! server-going #t)
			(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running")
                        ;;(BB> "http-transport: ->running")
			(server:write-dotserver *toppath* iface port (current-process-id) 'http) ;; create file .server
                        (thread-start! *watchdog*)
                        (server:complete-attempt *toppath*)) ;; delete file .starting-server
		      (begin ;; gotta exit nicely
                        ;;(BB> "http-transport: ->collision")
			(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "collision")
			(http-transport:server-shutdown server-id port))))))
      
      ;; when things go wrong we don't want to be doing the various queries too often
      ;; so we strive to run this stuff only every four seconds or so.

Modified server.scm from [5f46daa549] to [055a606575].

224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240







241
242
243
244
245
246
247
248
249
250

251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
	   (lambda ()
	     (read-line)))
	 #f))))

(define (server:read-dotserver->server-url areapath)
  (let* ((temp (server:read-dotserver areapath))
         (tokens (if temp (string-split temp ":") '())))
    (if (eq? 3 (length tokens))
        (string-join (list-ref tokens 0) ":" (list-ref tokens 1))
        #f)))

(define (server:read-dotserver->pid areapath)
  (let* ((temp (server:read-dotserver areapath))
         (tokens (if temp (string-split temp ":") '())))
    (if (eq? 3 (length tokens))
        (list-ref tokens 2)
        #f)))








(define (server:running-or-starting? areapath) ;; Note: may be unreiable on non-homehost due to NFS lag
  (or (server:read-dotserver areapath) (server:start-attempted? areapath)))

;; write a .server file in *toppath* with hostport
;; return #t on success, #f otherwise
;;
(define (server:write-dotserver areapath hostportpid)
  (let ((lock-file   (conc areapath "/.server.lock"))
	(server-file (conc areapath "/.server")))

    (if (common:simple-file-lock lock-file)
	(let ((res (handle-exceptions
		    exn
		    #f ;; failed for some reason, for the moment simply return #f
		    (with-output-to-file server-file
		      (lambda ()
			(print hostportpid)))
		    #t)))
	  (debug:print-info 0 *default-log-port* "server file " server-file " for " hostportpid " created")
	  (common:simple-file-release-lock lock-file)
	  res)
	#f)))

(define (server:remove-dotserver-file areapath hostport)
  (let ((serverurl   (server:read-dotserver->server-url areapath))
	(server-file (conc areapath "/.server"))







|






|


>
>
>
>
>
>
>







|

|
>






|

|







224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
	   (lambda ()
	     (read-line)))
	 #f))))

(define (server:read-dotserver->server-url areapath)
  (let* ((temp (server:read-dotserver areapath))
         (tokens (if temp (string-split temp ":") '())))
    (if (eq? 4 (length tokens))
        (string-join (list-ref tokens 0) ":" (list-ref tokens 1))
        #f)))

(define (server:read-dotserver->pid areapath)
  (let* ((temp (server:read-dotserver areapath))
         (tokens (if temp (string-split temp ":") '())))
    (if (eq? 4 (length tokens))
        (list-ref tokens 2)
        #f)))

(define (server:read-dotserver->transport areapath)
  (let* ((temp (server:read-dotserver areapath))
         (tokens (if temp (string-split temp ":") '())))
    (if (eq? 4 (length tokens))
        (string->symbol (list-ref tokens 3))
        #f)))

(define (server:running-or-starting? areapath) ;; Note: may be unreiable on non-homehost due to NFS lag
  (or (server:read-dotserver areapath) (server:start-attempted? areapath)))

;; write a .server file in *toppath* with hostport
;; return #t on success, #f otherwise
;;
(define (server:write-dotserver areapath host port pid transport)
  (let ((lock-file   (conc areapath "/.server.lock"))
	(server-file (conc areapath "/.server"))
        (payload (conc host ":" port ":" pid ":" transport)))
    (if (common:simple-file-lock lock-file)
	(let ((res (handle-exceptions
		    exn
		    #f ;; failed for some reason, for the moment simply return #f
		    (with-output-to-file server-file
		      (lambda ()
			(print payload)))
		    #t)))
	  (debug:print-info 0 *default-log-port* "server file " server-file " for " payload " created")
	  (common:simple-file-release-lock lock-file)
	  res)
	#f)))

(define (server:remove-dotserver-file areapath hostport)
  (let ((serverurl   (server:read-dotserver->server-url areapath))
	(server-file (conc areapath "/.server"))

Modified tasks.scm from [7914349b64] to [65c2fe0cbf].

328
329
330
331
332
333
334




335
336
337
338
339
340
341
     (conc "SELECT " selstr " FROM servers WHERE state in ('available','running','dbprep') ORDER BY start_time DESC;")
     )
    (vector header res)))

(define (tasks:get-server mdb run-id #!key (retries 10))
  (let ((res  #f)
	(best #f))




    (handle-exceptions
     exn
     (begin
       (print-call-chain (current-error-port))
       (debug:print 0 *default-log-port* "WARNING: tasks:get-server db access error.")
       (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
       (debug:print 0 *default-log-port* " for run " run-id)







>
>
>
>







328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
     (conc "SELECT " selstr " FROM servers WHERE state in ('available','running','dbprep') ORDER BY start_time DESC;")
     )
    (vector header res)))

(define (tasks:get-server mdb run-id #!key (retries 10))
  (let ((res  #f)
	(best #f))

    (set! res (vector id interface port pubport transport pid hostname)))

    
    (handle-exceptions
     exn
     (begin
       (print-call-chain (current-error-port))
       (debug:print 0 *default-log-port* "WARNING: tasks:get-server db access error.")
       (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
       (debug:print 0 *default-log-port* " for run " run-id)