Megatest

Check-in [3e5fcece74]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Another file (mostly) ported to chicken 5
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.80-mbi
Files: files | file ages | folders
SHA1: 3e5fcece7434e3471928a742d4cbae2710d728c1
User & Date: matt on 2023-04-01 21:20:53
Other Links: branch diff | manifest | tags
Context
2023-04-03
15:08
Fixed ticket c10775f9d83a4e29f50f9ccdbfc9fd326f493e2e Closed-Leaf check-in: e37f1ded41 user: matt tags: v1.80-mbi
2023-04-01
21:20
Another file (mostly) ported to chicken 5 check-in: 3e5fcece74 user: matt tags: v1.80-mbi
18:08
Converted couple more files to ck5 check-in: 07ba2ed8da user: matt tags: v1.80-mbi
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified Makefile from [0903ad3b9c] to [e2b76a9cc6].

︙︙
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56

dashboard-transport-mode.scm : dashboard-transport-mode.scm.template
	cp dashboard-transport-mode.scm.template dashboard-transport-mode.scm

megatest.scm : transport-mode.scm
dashboard.scm : dashboard-transport-mode.scm

# dbmod.import.o is just a hack here
mofiles/dbfile.o     : mofiles/debugprint.o mofiles/commonmod.o dbmod.import.o
configf.o : commonmod.import.o
db.o : dbmod.import.o
mofiles/debugprint.o : mofiles/mtargs.o

# ftail.scm rmtmod.scm commonmod.scm removed
# MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm	\
#             mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm	\








|








42
43
44
45
46
47
48
49
50
51
52
53
54
55
56

dashboard-transport-mode.scm : dashboard-transport-mode.scm.template
	cp dashboard-transport-mode.scm.template dashboard-transport-mode.scm

megatest.scm : transport-mode.scm
dashboard.scm : dashboard-transport-mode.scm

# dbmod.import.o is just a hack here
mofiles/dbfile.o     : mofiles/debugprint.o mofiles/commonmod.o
configf.o : commonmod.import.o
db.o : dbmod.import.o
mofiles/debugprint.o : mofiles/mtargs.o

# ftail.scm rmtmod.scm commonmod.scm removed
# MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm	\
#             mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm	\
︙︙

Modified tcp-transportmod.scm from [8f58514e4b] to [d49ae3185c].

︙︙
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
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87


(declare (unit tcp-transportmod))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses dbfile))
(declare (uses dbmod))

(use address-info)

(module tcp-transportmod
	*
	
  (import scheme
	  (prefix sqlite3 sqlite3:)
	  chicken

	  data-structures

	  address-info
	  directory-utils
	  extras
	  files
	  hostinfo
	  matchable
	  md5
	  message-digest
	  ports
	  posix
























	  regex
	  regex-case
	  s11n
	  srfi-1
	  srfi-18
	  srfi-4
	  srfi-69
	  stack
	  typed-records
	  tcp-server
	  tcp
	  
	  debugprint
	  commonmod
	  dbfile
	  dbmod
	)

;;======================================================================
;; client
;;======================================================================

;; (define keep-age-param (make-parameter 10)) ;; qif file age, if over move to attic

;; Used ONLY for client
;;
(defstruct tt-conn
  host
  port
  host-port
  dbfname
  server-id
  server-start
  pid
)

;; Used for BOTH clients and servers
(defstruct tt
  ;; client related
  (conns (make-hash-table)) ;; dbfname -> conn









<
<



|
|
|
>

<
|
<


|
<
<
<


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
<










|
|
|
|
|
|
|








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
59
60
61
62
63
64
65
66
67
68
69
70
71
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
98
99
100
101
102
103


(declare (unit tcp-transportmod))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses dbfile))
(declare (uses dbmod))



(module tcp-transportmod
	*
	
(import scheme)
(cond-expand
 (chicken-4
  (import chicken
	  data-structures

	  hostinfo

	  extras
	  files
	  directory-utils



	  ports
	  posix
	  ))
 (chicken-5
  (import chicken.base
	  chicken.condition
	  chicken.file
	  chicken.file.posix
	  chicken.io
	  chicken.port
	  chicken.process
	  chicken.process-context
	  chicken.process-context.posix
	  chicken.sort
	  chicken.string
	  chicken.time
	  system-information
	  socket
	  )
  (define unsetenv unset-environment-variable!)))
  
(import (prefix sqlite3 sqlite3:))
(import address-info)
(import matchable)
(import md5)
(import message-digest)
(import regex)
(import regex-case)
(import s11n)
(import srfi-1)
(import srfi-18)
(import srfi-4)
(import srfi-69)
(import stack)
(import typed-records)
(import tcp-server)
(import tcp6)

(import debugprint)
(import commonmod)
(import dbfile)
(import dbmod)


;;======================================================================
;; client
;;======================================================================

;; (define keep-age-param (make-parameter 10)) ;; qif file age, if over move to attic

;; Used ONLY for client
;;
(defstruct tt-conn
  (host #f)
  (port #f)
  (host-port #f)
  (dbfname #f)
  (server-id #f)
  (server-start #f)
  (pid #f)
)

;; Used for BOTH clients and servers
(defstruct tt
  ;; client related
  (conns (make-hash-table)) ;; dbfname -> conn
︙︙
684
685
686
687
688
689
690
691
692


693
694
695
696
697
698
699
700
701
702
703




704










705
706
707
708
709
710
711

  (message-digest-string (md5-primitive) 
			 (with-output-to-string
			   (lambda ()
			     (write (list areapath
                                          (current-process-id)
					  (argv)))))))


(define (tt:get-best-guess-address hostname)


  (let ((res #f))
    (for-each 
     (lambda (adr)
       (if (not (eq? (u8vector-ref adr 0) 127))
	   (set! res adr)))
     ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME
     (vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
    (string-intersperse 
     (map number->string
	  (u8vector->list
	   (if res res (hostname->ip hostname)))) ".")))















(define (tt:get-servinfo-dir areapath)
  (let* ((spath (conc areapath"/.servinfo")))
    (if (not (file-exists? spath))
	(create-directory spath #t))
    spath))

;;======================================================================








<

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








700
701
702
703
704
705
706

707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742

  (message-digest-string (md5-primitive) 
			 (with-output-to-string
			   (lambda ()
			     (write (list areapath
                                          (current-process-id)
					  (argv)))))))


(define (tt:get-best-guess-address hostname)
  (cond-expand
   (chicken-4
    (let ((res #f))
      (for-each 
       (lambda (adr)
	 (if (not (eq? (u8vector-ref adr 0) 127))
	     (set! res adr)))
       ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME
       (vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
      (string-intersperse 
       (map number->string
	    (u8vector->list
	     (if res res (hostname->ip hostname)))) ".")))
   (chicken-5
    (let* ((get-first (lambda (str) ;; "1.2.3.4" => 1, but "127.1.2.3 => 0 so it sorts last
			(let* ((res (string->number (car (string-split str ".")))))
			  (if (eq? res 127)
			      0
			      res))))
	   (addresses (sort
		       (map address-info-host (address-infos hostname))
		       (lambda (a b)
			 (let* ((a-first (get-first a))
				(b-first (get-first b)))
			   (> a-first b-first))))))
      (car addresses)))))
    
  
(define (tt:get-servinfo-dir areapath)
  (let* ((spath (conc areapath"/.servinfo")))
    (if (not (file-exists? spath))
	(create-directory spath #t))
    spath))

;;======================================================================
︙︙

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