Overview
Context
Changes
Modified Makefile
from [9634350b91]
to [9bee85deab].
︙ | | |
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
|
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
|
-
+
-
-
+
+
-
-
+
+
|
# base64 dot-locking \
# csv-xml z3
# "(define (toplevel-command . a) #f)"
# if egrep 'version.*3.0' $(shell dirname $(shell dirname $(shell which csi)))/lib/chicken/7/readline.setup-info;then \
readline-fix.scm :
if [[ $(shell chicken-status | grep readline | awk '{print $4}' | cut -d. -f1) -gt 3 ]];then \
if [[ $(shell chicken-status | grep breadline | awk '{print $4}' | cut -d. -f1) -gt 3 ]];then \
echo "(define *use-new-readline* #f)" > readline-fix.scm; \
else \
echo "(define *use-new-readline* #t)" > readline-fix.scm;\
fi
altdb.scm :
echo ";; optional alternate db setup" > altdb.scm
echo "(define *available-db* (make-hash-table))" >> altdb.scm
if csi -ne '(use mysql-client)';then \
echo "(use mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \
if csi -ne '(import mysql-client)';then \
echo "(import mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \
fi
if csi -ne '(use postgresql)';then \
echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\
if csi -ne '(import postgresql)';then \
echo "(import postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\
fi
portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
# create a pdf dot graphviz diagram from notations in rmt.scm
rmt.pdf : rmt.scm
|
︙ | | |
Modified commonmod.scm
from [9ac021e7df]
to [b29d0a4e08].
︙ | | |
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
|
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
|
-
+
|
(prefix dbi dbi:)
stack
md5
message-digest
z3
directory-utils
system-information
;;sparse-vectors
sparse-vectors
)
(import pkts)
(import (prefix mtconfigf configf:))
(import (prefix mtargs args:))
(include "common_records.scm")
|
︙ | | |
Modified mutils/mutils.scm
from [9ec33d98cf]
to [a5f23f82ed].
︙ | | |
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
|
-
+
-
|
;; This is from the perl world, a hash of hashes is a super easy way to keep a handle on
;; lots of disparate data
;;
(module mutils
*
(import chicken scheme
(import (chicken base) (chicken io) scheme
;; data-structures posix
srfi-1
;; srfi-13
srfi-69
;; ports
extras
regex
)
(define (mutils:hierhash-ref hh . keys)
(if (null? keys)
#f
(let loop ((ht hh)
|
︙ | | |
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
|
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
|
-
+
|
(if (eof-object? l)
(reverse res)
(if (or (string-match comment l)
(string-match blank l))
(loop (read-line fh) res)
(loop (read-line fh) (cons l res)))))))
(use sparse-vectors)
(import sparse-vectors)
;; this is a simple two dimensional sparse array
;; ONLY TWO DIMENSIONS!!! SEE ARRAY-LIB IF YOUR NEEDS ARE GREATER!!
;;
(define (mutils:make-sparse-array)
(let ((a (make-sparse-vector)))
|
︙ | | |
Modified pgdbmod.scm
from [cbf87ade64]
to [3525eec6ab].
︙ | | |
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
|
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
|
-
-
+
+
|
(declare (uses mtconfigf))
(declare (uses commonmod))
(declare (uses mtargs))
(module pgdbmod
*
(import scheme chicken data-structures extras files)
(use posix
(import scheme (chicken base) (chicken file) (chicken string) (chicken sort) (chicken condition) (chicken string))
(import
(prefix dbi dbi:)
srfi-69 srfi-1 typed-records)
(import (prefix mtconfigf configf:))
(import (prefix mtargs args:))
(import commonmod)
|
︙ | | |
Modified stml2/stml2.scm
from [3dca2d569e]
to [44fdf7437b].
︙ | | |
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
-
+
-
+
|
;; stml is a list of html strings
;; (declare (unit stml))
(module stml2
*
(import (chicken base) scheme queues srfi-13 (chicken port) (chicken io) (chicken file) srfi-69 srfi-1 (chicken condition))
(import (chicken random) (chicken base) (chicken string) (chicken time) scheme queues srfi-13 (chicken port) (chicken io) (chicken file) srfi-69 srfi-1 (chicken condition) (chicken time posix) (chicken process-context posix) (chicken pathname) (chicken blob) (chicken format) (chicken process) (chicken process-context))
(import cookie)
(import (prefix dbi dbi:) (prefix crypt c:) typed-records)
;; (declare (uses misc-stml))
(use regex)
(import regex)
;; The (usually global) sdat contains everything about the session
;;
(defstruct sdat
;; database
(dbtype 'pg)
(dbinit #f)
|
︙ | | |
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
|
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
|
-
+
|
;; to obscure and indirect database ids use one time keys
;;
;; (s:get-key 'n 1) => "n99e1882" n=number 99e is the week number since 1970, remainder is random
;; (s:key->val "n1882") => 1
;;
;; first letter is a type: n=number, s=string, b=boolean
(define (s:get-key key-type val)
(let ((mkrandstr (lambda (innum)(number->string (random innum) 16)))
(let ((mkrandstr (lambda (innum)(number->string (pseudo-random-integer innum) 16)))
(week (number->string (quotient (current-seconds) (* 7 24 60 60)) 16)))
(let loop ((siz 1000)
(key (conc key-type week (mkrandstr 100)))
(num 0))
(if (s:session-var-get key) ;; have a collision
(loop (cond ;; in the unlikey event we have trouble getting a new var, keep increasing the size of the number
((< num 50) 100)
|
︙ | | |
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
|
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
|
-
+
-
+
|
#;(define session:valid-chars "abcdefghijklmnopqrstuvwxyz0123456789") ;; cookies are case insensitive.
#;(define session:num-valid-chars (string-length session:valid-chars))
#;(define (session:get-nth-char nth)
(substring session:valid-chars nth (+ nth 1)))
#;(define (session:get-rand-char)
(session:get-nth-char (random session:num-valid-chars)))
(session:get-nth-char (pseudo-random-integer session:num-valid-chars)))
#;(define (session:make-rand-string len)
(let loop ((res "")
(n 1))
(if (> n len) res
(loop (string-append res (session:get-rand-char))
(+ n 1)))))
;; maybe replace above make-rand-string with this someday?
;;
#;(define (session:generic-make-rand-string len seed-string)
(let ((num-chars (string-length seed-string)))
(let loop ((res "")
(n 1))
(let ((char-num (random num-chars)))
(let ((char-num (pseudo-random-integer num-chars)))
(if (> n len) res
(loop (string-append res (substring seed-string char-num (+ char-num 1)))
(+ n 1)))))))
;; Rely on crypt egg's default settings being secure enough, accept
;; backwards-compatible OpenSSL crypt passwords too.
;;
|
︙ | | |
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
|
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
|
-
+
-
+
|
(define session:valid-chars "abcdefghijklmnopqrstuvwxyz0123456789") ;; cookies are case insensitive.
(define session:num-valid-chars (string-length session:valid-chars))
(define (session:get-nth-char nth)
(substring session:valid-chars nth (+ nth 1)))
(define (session:get-rand-char)
(session:get-nth-char (random session:num-valid-chars)))
(session:get-nth-char (pseudo-random-integer session:num-valid-chars)))
(define (session:make-rand-string len)
(let loop ((res "")
(n 1))
(if (> n len) res
(loop (string-append res (session:get-rand-char))
(+ n 1)))))
;; maybe replace above make-rand-string with this someday?
;;
(define (session:generic-make-rand-string len seed-string)
(let ((num-chars (string-length seed-string)))
(let loop ((res "")
(n 1))
(let ((char-num (random num-chars)))
(let ((char-num (pseudo-random-integer num-chars)))
(if (> n len) res
(loop (string-append res (substring seed-string char-num (+ char-num 1)))
(+ n 1)))))))
;;======================================================================
;; P A R A M S
|
︙ | | |
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
|
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
|
-
+
|
(if debugmode (session:log self "session:setup dbfname=" dbfname ", dbtype=" dbtype ", dbinit=" dbinit))
(if (eq? dbtype 'sqlite3)
;; The 'auto method will distribute dbs across the disk using hash
;; of user host and user. TODO
;; (if (eq? dbfname 'auto) ;; This is the auto assignment of a db based on hash of IP
(let ((dbpath (pathname-directory dbfname))) ;; do a couple sanity checks here to make setting up easier
(if debugmode (session:log self "INFO: setting up for sqlite3 db access to " dbfname))
(if (not (file-write-access? dbpath))
(if (not (file-writable? dbpath))
(session:log self "WARNING: Cannot write to " dbpath)
(if debugmode (session:log self "INFO: " dbpath " is writeable")))
(if (file-exists? dbfname)
(begin
;; (session:log self "setting dbexists to #t")
(set! dbexists #t))))
(if debugmode (session:log self "INFO: setting up for pg db access to account info " dbinit)))
|
︙ | | |
Modified tasksmod.scm
from [f340b0fd3c]
to [96bece454d].
︙ | | |
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
-
-
+
+
|
(declare (uses commonmod))
(declare (uses pgdbmod))
(declare (uses mtconfigf))
(module tasksmod
*
(import scheme chicken data-structures extras)
(use (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable
(import scheme (chicken base) (chicken condition) (chicken string) (chicken process) (chicken process-context) (chicken process-context posix) (chicken file) (chicken file posix) system-information )
(import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69 format srfi-1 matchable
regex)
(import commonmod)
(import (prefix mtconfigf configf:))
(import pgdbmod)
(include "common_records.scm")
|
︙ | | |
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
-
+
-
+
-
+
|
(print-call-chain (current-error-port))
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(debug:print 5 *default-log-port* " exn=" (condition->list exn))))
(let* ((dbpath (db:dbfile-path )) ;; (tasks:get-task-db-path))
(dbfile (conc dbpath "/monitor.db"))
(avail (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away
(exists (common:file-exists? dbpath))
(write-access (file-write-access? dbpath))
(write-access (file-writable? dbpath))
(mdb (cond ;; what the hek is *toppath* doing here?
((and (string? *toppath*)(file-write-access? *toppath*))
((and (string? *toppath*)(file-writable? *toppath*))
(sqlite3:open-database dbfile))
((file-read-access? dbpath) (sqlite3:open-database dbfile))
((file-readable? dbpath) (sqlite3:open-database dbfile))
(else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath))
(handler (sqlite3:make-busy-timeout 36000)))
(if (and exists
(not write-access))
(set! *db-write-access* write-access)) ;; only unset so other db's also can use this control
(sqlite3:set-busy-handler! mdb handler)
(db:set-sync mdb) ;; (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;"))
|
︙ | | |
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
|
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
|
-
+
-
+
-
-
+
+
|
(define (tasks:need-server run-id)
(equal? (configf:lookup *configdat* "server" "required") "yes"))
;; no elegance here ...
;;
(define (tasks:kill-server hostname pid #!key (kill-switch ""))
(debug:print-info 0 *default-log-port* "Attempting to kill server process " pid " on host " hostname)
(setenv "TARGETHOST" hostname)
(set-environment-variable! "TARGETHOST" hostname)
(let* ((logdir (if (directory-exists? "logs")
"logs/"
""))
(logfile (if logdir (conc "logs/server-"pid"-"hostname".log") #f))
(gzfile (if logfile (conc logfile ".gz"))))
(setenv "TARGETHOST_LOGF" (conc logdir "server-kills.log"))
(set-environment-variable! "TARGETHOST_LOGF" (conc logdir "server-kills.log"))
(system (conc "nbfake kill "kill-switch" "pid))
(when logfile
(thread-sleep! 0.5)
(if (common:file-exists? gzfile) (delete-file gzfile))
(system (conc "gzip " logfile))
(unsetenv "TARGETHOST_LOGF")
(unsetenv "TARGETHOST"))))
(unset-environment-variable! "TARGETHOST_LOGF")
(unset-environment-variable! "TARGETHOST"))))
;;======================================================================
;; M O N I T O R S
;;======================================================================
(define (tasks:remove-monitor-record mdb)
|
︙ | | |