Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -98,11 +98,12 @@ (thread-sleep! (random 120)) (debug:print-info 0 "trying db call one more time....") (apply open-run-close-no-exception-handling proc idb params)) (apply open-run-close-no-exception-handling proc idb params))) -(define open-run-close open-run-close-exception-handling) +;; (define open-run-close open-run-close-exception-handling) +(define open-run-close open-run-close-no-exception-handling) (define *global-delta* 0) (define *last-global-delta-printed* 0) (define (open-run-close-measure proc idb . params) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -52,10 +52,11 @@ (debug:print 0 "ERROR: cannot find megatest.config, cannot start server, exiting") (exit)))) (let* (;; (iface (if (string=? "-" hostn) ;; #f ;; (get-host-name) ;; hostn)) + (db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily (hostname (get-host-name)) (ipaddrstr (let ((ipstr (if (string=? "-" hostn) (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") #f))) (if ipstr ipstr hostn))) ;; hostname))) @@ -65,19 +66,26 @@ (link-tree-path (config-lookup *configdat* "setup" "linktree"))) (set! *cache-on* #t) (root-path (if link-tree-path link-tree-path (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP! + + ;; Setup the web server and a /ctrl interface + ;; (vhost-map `(((* any) . ,(lambda (continue) + ;; open the db on the first call + (if (not db)(set! db (open-db))) (let* (($ (request-vars source: 'both)) (dat ($ 'dat)) (res #f)) (cond ((equal? (uri-path (request-uri (current-request))) '(/ "hey")) (send-response body: "hey there!\n" headers: '((content-type text/plain)))) + ;; This is the /ctrl path where data is handed to the server and + ;; responses ((equal? (uri-path (request-uri (current-request))) '(/ "ctrl")) (let* ((packet (db:string->obj dat)) (qtype (cdb:packet-get-qtype packet))) (debug:print-info 12 "server=> received packet=" packet) @@ -85,19 +93,23 @@ (begin (mutex-lock! *heartbeat-mutex*) (set! *last-db-access* (current-seconds)) (mutex-unlock! *heartbeat-mutex*))) ;; (mutex-lock! *db:process-queue-mutex*) ;; trying a mutex - (set! res (open-run-close db:process-queue-item open-db packet)) + ;; (set! res (open-run-close db:process-queue-item open-db packet)) + (set! res (db:process-queue-item db packet)) ;; (mutex-unlock! *db:process-queue-mutex*) (debug:print-info 11 "Return value from db:process-queue-item is " res) (send-response body: (conc "ctrl data\n" res "") headers: '((content-type text/plain))))) (else (continue)))))))) - (server:try-start-server ipaddrstr start-port))) + (server:try-start-server ipaddrstr start-port) + ;; lite3:finalize! db))) + )) + ;; (define (server:main-loop) ;; (print "INFO: Exectuing main server loop") ;; (access-log "megatest-http.log") @@ -151,11 +163,11 @@ (open-run-close tasks:server-register tasks:open-db (current-process-id) ipaddrstr portnum 0 'live) (print "INFO: Trying to start server on " ipaddrstr ":" portnum) - ;; (awful-start server:main-loop port: portnum) ;; ip-address: ipaddrstr + ;; This starts the spiffy server (start-server port: portnum) (print "INFO: server has been stopped"))) (define (server:mk-signature) (message-digest-string (md5-primitive) @@ -166,10 +178,13 @@ ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== +;; When using zmq this would send the message back (two step process) +;; with spiffy or rpc this simply returns the return data to be returned +;; (define (server:reply return-addr query-sig success/fail result) (debug:print-info 11 "server:reply return-addr=" return-addr ", result=" result) ;; (send-message pubsock target send-more: #t) ;; (send-message pubsock (db:obj->string (vector success/fail query-sig result))) @@ -196,15 +211,19 @@ exn (if (< numretries 200) (server:client-send-receive serverdat msg)) (begin (debug:print-info 11 "fullurl=" fullurl "\n") + ;; set up the http-client here (max-retry-attempts 100) (retry-request? (lambda (request) (thread-sleep! (/ (if (> numretries 100) 100 numretries) 10)) (set! numretries (+ numretries 1)) #t)) + ;; send the data and get the response + ;; extract the needed info from the http data and + ;; process and return it. (let* ((res (with-input-from-request fullurl ;; #f ;; msg (list (cons 'dat msg)) read-string))) @@ -255,21 +274,21 @@ (port (list-ref hostinfo 2)) (pid (list-ref hostinfo 3))) (debug:print-info 2 "Setting up to connect to " hostinfo) (server:client-connect iface port)) ;; ) (if (> numtries 0) - (let (;; (exe (car (argv))) + (let ((exe (car (argv))) (pid #f)) (debug:print-info 0 "No server available, attempting to start one...") - ;; (set! pid (process-run exe (list "-server" "-" "-debug" (if (list? *verbosity*) - ;; (string-intersperse *verbosity* ",") - ;; (conc *verbosity*))))) - (set! pid (process-fork (lambda () - ;; (current-input-port (open-input-file "/dev/null")) - ;; (current-output-port (open-output-file "/dev/null")) - ;; (current-error-port (open-output-file "/dev/null")) - (server:launch)))) + (set! pid (process-run exe (list "-server" "-" "-debug" (if (list? *verbosity*) + (string-intersperse *verbosity* ",") + (conc *verbosity*))))) + ;; (set! pid (process-fork (lambda () + ;; (current-input-port (open-input-file "/dev/null")) + ;; (current-output-port (open-output-file "/dev/null")) + ;; (current-error-port (open-output-file "/dev/null")) + ;; (server:launch)))) (let loop ((count 0)) (let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db))) (if (not hostinfo) (begin (debug:print-info 0 "Waiting for server pid=" pid " to start") @@ -298,11 +317,12 @@ (sleep 4) (loop)))))) (iface (car server-info)) (port (cadr server-info)) (last-access 0) - (spid (open-run-close tasks:server-get-server-id tasks:open-db #f iface port #f))) + (tdb (tasks:open-db)) + (spid (tasks:server-get-server-id tdb #f iface port #f))) (print "Keep-running got server pid " spid ", using iface " iface " and port " port) (let loop ((count 0)) (thread-sleep! 4) ;; no need to do this very often ;; NB// sync currently does NOT return queue-length (let () ;; (queue-len (cdb:client-call server-info 'sync #t 1))) @@ -309,11 +329,11 @@ ;; (print "Server running, count is " count) (if (< count 1) ;; 3x3 = 9 secs aprox (loop (+ count 1))) ;; NOTE: Get rid of this mechanism! It really is not needed... - (open-run-close tasks:server-update-heartbeat tasks:open-db spid) + (tasks:server-update-heartbeat tdb spid) ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access (mutex-lock! *heartbeat-mutex*) (set! last-access *last-db-access*) (mutex-unlock! *heartbeat-mutex*) @@ -329,11 +349,11 @@ (loop 0)) (begin (debug:print-info 0 "Starting to shutdown the server.") ;; need to delete only *my* server entry (future use) (set! *time-to-exit* #t) - (open-run-close tasks:server-deregister-self tasks:open-db (get-host-name)) + (tasks:server-deregister-self tdb (get-host-name)) (thread-sleep! 1) (debug:print-info 0 "Max cached queries was " *max-cache-size*) (debug:print-info 0 "Server shutdown complete. Exiting") (exit))))))) @@ -344,10 +364,11 @@ (begin (debug:print 0 "ERROR: cannot find megatest.config, exiting") (exit)))) (debug:print-info 2 "Starting the standalone server") (let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db))) + (debug:print 11 "server:launch hostinfo=" hostinfo) (if hostinfo (debug:print-info 2 "NOT starting new server, one is already running on " (car hostinfo) ":" (cadr hostinfo)) (if *toppath* (let* ((th2 (make-thread (lambda () (server:run Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -85,10 +85,11 @@ ;; Server and client management ;;====================================================================== ;; state: 'live, 'shutting-down, 'dead (define (tasks:server-register mdb pid interface port priority state) + (debug:print-info 11 "tasks:server-register " pid " " interface " " port " " priority " " state) (sqlite3:execute mdb "INSERT OR REPLACE INTO servers (pid,hostname,port,start_time,priority,state,mt_version,heartbeat,interface) VALUES(?, ?, ?, strftime('%s','now'), ?, ?, ?, strftime('%s','now'),?);" pid (get-host-name) port priority (conc state) megatest-version interface)