Megatest

Check-in [959864784f]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:nmsg server start working
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.65-multi-db
Files: files | file ages | folders
SHA1: 959864784f3e7cf5452de90a774c7772eb3f7e51
User & Date: matt on 2019-02-02 22:35:10
Other Links: branch diff | manifest | tags
Context
2019-02-02
22:57
Minor tidy check-in: f801207647 user: matt tags: v1.65-multi-db
22:35
nmsg server start working check-in: 959864784f user: matt tags: v1.65-multi-db
22:04
pass 2 on nmsg transport setup check-in: 6899c9d176 user: matt tags: v1.65-multi-db
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified megatest.scm from [ca1500225d] to [3da797c58e].

︙︙
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34

;; (include "megatest-version.scm")

;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)

(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:)
     readline apropos json http-client directory-utils typed-records
     http-client srfi-18 extras format)

;; Added for csv stuff - will be removed
;;
(use sparse-vectors)

(require-library mutils)









|








20
21
22
23
24
25
26
27
28
29
30
31
32
33
34

;; (include "megatest-version.scm")

;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)

(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:)
     readline apropos json http-client directory-utils typed-records
     http-client srfi-18 extras format (prefix pkts pkts:))

;; Added for csv stuff - will be removed
;;
(use sparse-vectors)

(require-library mutils)
︙︙

Modified nmsg-transport.scm from [885fd93f8a] to [cf3eba2587].

︙︙
17
18
19
20
21
22
23
24



25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56

;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

(declare (unit nmsg-transport))

(module
 nmsg-transport
 (
  *



  )

(import scheme posix chicken data-structures ports)

(use pkts)
(use nanomsg srfi-18)

;;start a server, returns the connection
;;
(define (start-server portnum )
  (let ((rep (nn-socket 'rep)))
    (handle-exceptions
     exn
     (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
       (print "ERROR: Failed to start server \"" emsg "\"")
       #f)
     (nn-bind rep (conc "tcp://*:" portnum)))
    rep))

;; open connection to server, send message, close connection
;;
;;  to take an action on failure use proc which is called with the error info
;;    (proc exn errormsg)
;;
(define (open-send-close host-port msg attrib #!key (timeout 3)(proc #f)) ;; default timeout is 3 seconds
  (let ((req  (nn-socket 'req))
        (uri  (conc "tcp://" host-port))
        (res  #f)
        ;; (contacts (alist-ref 'contact attrib))
        (mode (alist-ref 'mode attrib))) 
    (handle-exceptions
     exn








<
>
>
>









|














|








17
18
19
20
21
22
23

24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58

;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

(declare (unit nmsg-transport))

(module
 nmsg-transport
 (

  nmsg:start-server
  nmsg:open-send-close
  nmsg:open-send-receive
  )

(import scheme posix chicken data-structures ports)

(use pkts)
(use nanomsg srfi-18)

;;start a server, returns the connection
;;
(define (nmsg:start-server portnum )
  (let ((rep (nn-socket 'rep)))
    (handle-exceptions
     exn
     (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
       (print "ERROR: Failed to start server \"" emsg "\"")
       #f)
     (nn-bind rep (conc "tcp://*:" portnum)))
    rep))

;; open connection to server, send message, close connection
;;
;;  to take an action on failure use proc which is called with the error info
;;    (proc exn errormsg)
;;
(define (nmsg:open-send-close host-port msg attrib #!key (timeout 3)(proc #f)) ;; default timeout is 3 seconds
  (let ((req  (nn-socket 'req))
        (uri  (conc "tcp://" host-port))
        (res  #f)
        ;; (contacts (alist-ref 'contact attrib))
        (mode (alist-ref 'mode attrib))) 
    (handle-exceptions
     exn
︙︙
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90

       (thread-start! th1)
       (thread-start! th2)
       (thread-join! th1)
       res))))

;; default timeout is 3 seconds
;;
(define (open-send-receive host-port msg attrib #!key (timeout 3)(proc #f)) 
  (let ((req  (nn-socket 'req))
        (uri  (conc "tcp://" host-port))
        (res  #f)
        (mode (alist-ref 'mode attrib))) 
    (handle-exceptions
     exn
     (let ((emsg ((condition-property-accessor 'exn 'message) exn)))








|








78
79
80
81
82
83
84
85
86
87
88
89
90
91
92

       (thread-start! th1)
       (thread-start! th2)
       (thread-join! th1)
       res))))

;; default timeout is 3 seconds
;;
(define (nmsg:open-send-receive host-port msg attrib #!key (timeout 3)(proc #f)) 
  (let ((req  (nn-socket 'req))
        (uri  (conc "tcp://" host-port))
        (res  #f)
        (mode (alist-ref 'mode attrib))) 
    (handle-exceptions
     exn
     (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
︙︙

Modified rmt.scm from [5c2483726b] to [3d460d177a].

︙︙
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38

(declare (uses api))
(declare (uses http-transport))
(include "common_records.scm")

(declare (uses portlogger))
(import portlogger)
(declare (uses nmsg-transport))
(import (prefix nmsg-transport nmsg:))

(use (prefix pkts pkts:) srfi-18)
;;
;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
;;

;; generate entries for ~/.megatestrc with the following








|








24
25
26
27
28
29
30
31
32
33
34
35
36
37
38

(declare (uses api))
(declare (uses http-transport))
(include "common_records.scm")

(declare (uses portlogger))
(import portlogger)
(declare (uses nmsg-transport))
(import nmsg-transport)

(use (prefix pkts pkts:) srfi-18)
;;
;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
;;

;; generate entries for ~/.megatestrc with the following
︙︙
72
73
74
75
76
77
78

79
80
81
82
83
84
85
86
87
88

89
90
91
92
93
94
95

			       'main
			       'passive)))
	 (port-num     (portlogger:open-run-close portlogger:find-port))
	 (nmsg-conn    (nmsg:start-server port-num))
	 (pktspec      (nmsg-pktspec *nmsg-conndat*))
	 (pktdir       (conc (get-environment-variable "MT_RUN_AREA_HOME")
			     "/.server-pkts")))

    ;; server is started, now create pkt if needed
    (if (eq? server-type 'main)
	(nmsg-pkt-set! *nmsg-conndat* 
		       (pkts:write-alist-pkt
			pktdir 
			`((hostname . ,(get-host-name))
			  (port     . ,port-num)
			  (pid      . ,(current-process-id)))
			pktspec)))
    (nmsg-conn-set! *nmsg-conndat* nmsg-conn)

    ))
;;======================================================================
;;  S U P P O R T   F U N C T I O N S
;;======================================================================

;; if a server is either running or in the process of starting call client:setup
;; else return #f to let the calling proc know that there is no server available








>



|






>








72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97

			       'main
			       'passive)))
	 (port-num     (portlogger:open-run-close portlogger:find-port))
	 (nmsg-conn    (nmsg:start-server port-num))
	 (pktspec      (nmsg-pktspec *nmsg-conndat*))
	 (pktdir       (conc (get-environment-variable "MT_RUN_AREA_HOME")
			     "/.server-pkts")))
    (if (not (directory? pktdir))(create-directory pktdir))
    ;; server is started, now create pkt if needed
    (if (eq? server-type 'main)
	(nmsg-pkt-set! *nmsg-conndat* 
		       (pkts:write-alist->pkt
			pktdir 
			`((hostname . ,(get-host-name))
			  (port     . ,port-num)
			  (pid      . ,(current-process-id)))
			pktspec)))
    (nmsg-conn-set! *nmsg-conndat* nmsg-conn)
    (mutex-unlock! (nmsg-mutex *nmsg-conndat*))
    ))
;;======================================================================
;;  S U P P O R T   F U N C T I O N S
;;======================================================================

;; if a server is either running or in the process of starting call client:setup
;; else return #f to let the calling proc know that there is no server available
︙︙

This page was generated in about 0.122s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00