Artifact 900250564a62efca2b8669bc11a5a5e8b1eb9cbd:
- File rpctest/rpctest.scm — part of check-in [cf97950521] at 2015-12-07 22:26:52 on branch v1.60 — Switched rcp test to use sql-de-lite (user: matt size: 2822) [more...]
0000: 3b 3b 3b 3b 20 72 70 63 2d 64 65 6d 6f 2e 73 63 ;;;; rpc-demo.sc 0010: 6d 0a 3b 3b 3b 3b 20 53 69 6d 70 6c 65 20 64 61 m.;;;; Simple da 0020: 74 61 62 61 73 65 20 73 65 72 76 65 72 20 2f 20 tabase server / 0030: 63 6c 69 65 6e 74 0a 0a 3b 3b 3b 20 73 74 61 72 client..;;; star 0040: 74 20 73 65 72 76 65 72 20 74 68 75 73 6c 79 3a t server thusly: 0050: 20 2e 2f 72 70 63 74 65 73 74 20 73 65 72 76 65 ./rpctest serve 0060: 72 20 74 65 73 74 2e 64 62 0a 3b 3b 3b 20 79 6f r test.db.;;; yo 0070: 75 20 77 69 6c 6c 20 6e 65 65 64 20 74 6f 20 69 u will need to i 0080: 6e 69 74 20 74 65 73 74 2e 64 62 3a 0a 3b 3b 3b nit test.db:.;;; 0090: 20 73 71 6c 69 74 65 33 20 74 65 73 74 2e 64 62 sqlite3 test.db 00a0: 20 22 43 52 45 41 54 45 20 54 41 42 4c 45 20 66 "CREATE TABLE f 00b0: 6f 6f 20 28 69 64 20 49 4e 54 45 47 45 52 20 50 oo (id INTEGER P 00c0: 52 49 4d 41 52 59 20 4b 45 59 2c 20 76 61 72 20 RIMARY KEY, var 00d0: 54 45 58 54 2c 20 76 61 6c 20 54 45 58 54 29 3b TEXT, val TEXT); 00e0: 22 0a 0a 28 72 65 71 75 69 72 65 2d 65 78 74 65 "..(require-exte 00f0: 6e 73 69 6f 6e 20 28 73 72 66 69 20 31 38 29 20 nsion (srfi 18) 0100: 65 78 74 72 61 73 20 74 63 70 20 72 70 63 20 73 extras tcp rpc s 0110: 71 6c 2d 64 65 2d 6c 69 74 65 29 0a 0a 3b 3b 3b ql-de-lite)..;;; 0120: 20 43 6f 6d 6d 6f 6e 20 74 68 69 6e 67 73 0a 0a Common things.. 0130: 28 64 65 66 69 6e 65 20 74 6f 74 61 6c 2d 71 75 (define total-qu 0140: 65 72 69 65 73 20 30 29 0a 28 64 65 66 69 6e 65 eries 0).(define 0150: 20 73 74 61 72 74 2d 74 69 6d 65 20 28 63 75 72 start-time (cur 0160: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 0a rent-seconds)).. 0170: 28 64 65 66 69 6e 65 20 6f 70 65 72 61 74 69 6f (define operatio 0180: 6e 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f n (string->symbo 0190: 6c 20 28 63 61 72 20 28 63 6f 6d 6d 61 6e 64 2d l (car (command- 01a0: 6c 69 6e 65 2d 61 72 67 75 6d 65 6e 74 73 29 29 line-arguments)) 01b0: 29 29 0a 28 64 65 66 69 6e 65 20 70 61 72 61 6d )).(define param 01c0: 20 28 63 61 64 72 20 28 63 6f 6d 6d 61 6e 64 2d (cadr (command- 01d0: 6c 69 6e 65 2d 61 72 67 75 6d 65 6e 74 73 29 29 line-arguments)) 01e0: 29 0a 28 70 72 69 6e 74 20 22 4f 70 65 72 61 74 ).(print "Operat 01f0: 69 6f 6e 3a 20 22 20 6f 70 65 72 61 74 69 6f 6e ion: " operation 0200: 20 22 2c 20 70 61 72 61 6d 3a 20 22 20 70 61 72 ", param: " par 0210: 61 6d 29 0a 0a 3b 3b 20 68 61 76 65 20 61 20 70 am)..;; have a p 0220: 6f 6f 6c 20 6f 66 20 64 62 27 73 20 74 6f 20 70 ool of db's to p 0230: 69 63 6b 20 66 72 6f 6d 0a 28 64 65 66 69 6e 65 ick from.(define 0240: 20 2a 64 62 70 6f 6f 6c 2a 20 27 28 29 29 0a 28 *dbpool* '()).( 0250: 64 65 66 69 6e 65 20 2a 70 6f 6f 6c 2d 6d 75 74 define *pool-mut 0260: 65 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 ex* (make-mutex) 0270: 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d )..(define (get- 0280: 64 62 29 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 db). (mutex-loc 0290: 6b 21 20 2a 70 6f 6f 6c 2d 6d 75 74 65 78 2a 29 k! *pool-mutex*) 02a0: 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 2a 64 . (if (null? *d 02b0: 62 70 6f 6f 6c 2a 29 0a 20 20 20 20 20 20 28 62 bpool*). (b 02c0: 65 67 69 6e 0a 09 28 6d 75 74 65 78 2d 75 6e 6c egin..(mutex-unl 02d0: 6f 63 6b 21 20 2a 70 6f 6f 6c 2d 6d 75 74 65 78 ock! *pool-mutex 02e0: 2a 29 0a 09 28 6c 65 74 20 28 28 64 62 20 28 6f *)..(let ((db (o 02f0: 70 65 6e 2d 64 61 74 61 62 61 73 65 20 70 61 72 pen-database par 0300: 61 6d 29 29 29 0a 09 20 20 28 73 65 74 2d 62 75 am))).. (set-bu 0310: 73 79 2d 68 61 6e 64 6c 65 72 21 20 64 62 20 28 sy-handler! db ( 0320: 62 75 73 79 2d 74 69 6d 65 6f 75 74 20 31 30 30 busy-timeout 100 0330: 30 30 29 29 0a 09 20 20 28 65 78 65 63 20 28 73 00)).. (exec (s 0340: 71 6c 20 64 62 20 22 50 52 41 47 4d 41 20 73 79 ql db "PRAGMA sy 0350: 6e 63 68 72 6f 6e 6f 75 73 3d 30 3b 22 29 29 0a nchronous=0;")). 0360: 09 20 20 64 62 29 29 0a 20 20 20 20 20 20 28 6c . db)). (l 0370: 65 74 20 28 28 72 65 73 20 28 63 61 72 20 2a 64 et ((res (car *d 0380: 62 70 6f 6f 6c 2a 29 29 29 0a 09 28 73 65 74 21 bpool*)))..(set! 0390: 20 2a 64 62 70 6f 6f 6c 2a 20 28 63 64 72 20 2a *dbpool* (cdr * 03a0: 64 62 70 6f 6f 6c 2a 29 29 0a 09 28 6d 75 74 65 dbpool*))..(mute 03b0: 78 2d 75 6e 6c 6f 63 6b 21 20 2a 70 6f 6f 6c 2d x-unlock! *pool- 03c0: 6d 75 74 65 78 2a 29 0a 09 72 65 73 29 29 29 0a mutex*)..res))). 03d0: 0a 28 64 65 66 69 6e 65 20 28 72 65 74 75 72 6e .(define (return 03e0: 2d 64 62 20 64 62 29 0a 20 20 28 6d 75 74 65 78 -db db). (mutex 03f0: 2d 6c 6f 63 6b 21 20 2a 70 6f 6f 6c 2d 6d 75 74 -lock! *pool-mut 0400: 65 78 2a 29 0a 20 20 28 73 65 74 21 20 2a 64 62 ex*). (set! *db 0410: 70 6f 6f 6c 2a 20 28 63 6f 6e 73 20 64 62 20 2a pool* (cons db * 0420: 64 62 70 6f 6f 6c 2a 20 29 29 0a 20 20 28 6c 65 dbpool* )). (le 0430: 74 20 28 28 72 65 73 20 28 6c 65 6e 67 74 68 20 t ((res (length 0440: 2a 64 62 70 6f 6f 6c 2a 29 29 29 0a 20 20 20 20 *dbpool*))). 0450: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! * 0460: 70 6f 6f 6c 2d 6d 75 74 65 78 2a 29 0a 20 20 20 pool-mutex*). 0470: 20 72 65 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 res))..(define 0480: 72 70 63 3a 6c 69 73 74 65 6e 65 72 0a 20 20 28 rpc:listener. ( 0490: 69 66 20 28 65 71 3f 20 6f 70 65 72 61 74 69 6f if (eq? operatio 04a0: 6e 20 27 73 65 72 76 65 72 29 0a 20 20 20 20 20 n 'server). 04b0: 20 28 74 63 70 2d 6c 69 73 74 65 6e 20 28 72 70 (tcp-listen (rp 04c0: 63 3a 64 65 66 61 75 6c 74 2d 73 65 72 76 65 72 c:default-server 04d0: 2d 70 6f 72 74 29 29 0a 20 20 20 20 20 20 28 74 -port)). (t 04e0: 63 70 2d 6c 69 73 74 65 6e 20 30 29 29 29 0a 0a cp-listen 0))).. 04f0: 3b 3b 20 53 74 61 72 74 20 73 65 72 76 65 72 20 ;; Start server 0500: 74 68 72 65 61 64 0a 28 64 65 66 69 6e 65 20 72 thread.(define r 0510: 70 63 3a 73 65 72 76 65 72 0a 20 20 28 6d 61 6b pc:server. (mak 0520: 65 2d 74 68 72 65 61 64 0a 20 20 20 28 63 75 74 e-thread. (cut 0530: 65 20 28 72 70 63 3a 6d 61 6b 65 2d 73 65 72 76 e (rpc:make-serv 0540: 65 72 20 72 70 63 3a 6c 69 73 74 65 6e 65 72 29 er rpc:listener) 0550: 20 22 72 70 63 3a 73 65 72 76 65 72 22 29 0a 20 "rpc:server"). 0560: 20 20 27 72 70 63 3a 73 65 72 76 65 72 29 29 0a 'rpc:server)). 0570: 0a 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 .(thread-start! 0580: 72 70 63 3a 73 65 72 76 65 72 29 0a 0a 3b 3b 3b rpc:server)..;;; 0590: 20 53 65 72 76 65 72 20 73 69 64 65 0a 0a 28 64 Server side..(d 05a0: 65 66 69 6e 65 20 28 73 65 72 76 65 72 29 0a 20 efine (server). 05b0: 20 28 72 70 63 3a 70 75 62 6c 69 73 68 2d 70 72 (rpc:publish-pr 05c0: 6f 63 65 64 75 72 65 21 0a 20 20 20 27 63 68 61 ocedure!. 'cha 05d0: 6e 67 65 2d 72 65 73 70 6f 6e 73 65 2d 70 6f 72 nge-response-por 05e0: 74 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 70 6f t. (lambda (po 05f0: 72 74 29 0a 20 20 20 20 20 28 72 70 63 3a 64 65 rt). (rpc:de 0600: 66 61 75 6c 74 2d 73 65 72 76 65 72 2d 70 6f 72 fault-server-por 0610: 74 20 70 6f 72 74 29 29 0a 20 20 20 23 66 29 0a t port)). #f). 0620: 20 20 3b 3b 28 6c 65 74 20 28 28 64 62 20 20 28 ;;(let ((db ( 0630: 67 65 74 2d 64 62 29 29 28 6f 70 65 6e 2d 64 61 get-db))(open-da 0640: 74 61 62 61 73 65 20 70 61 72 61 6d 29 29 29 0a tabase param))). 0650: 20 20 3b 3b 20 28 73 65 74 2d 66 69 6e 61 6c 69 ;; (set-finali 0660: 7a 65 72 21 20 64 62 20 66 69 6e 61 6c 69 7a 65 zer! db finalize 0670: 21 29 0a 20 20 28 72 70 63 3a 70 75 62 6c 69 73 !). (rpc:publis 0680: 68 2d 70 72 6f 63 65 64 75 72 65 21 0a 20 20 20 h-procedure!. 0690: 27 71 75 65 72 79 0a 20 20 20 28 6c 61 6d 62 64 'query. (lambd 06a0: 61 20 28 73 71 6c 73 74 6d 74 20 63 61 6c 6c 62 a (sqlstmt callb 06b0: 61 63 6b 29 0a 20 20 20 20 20 28 73 65 74 21 20 ack). (set! 06c0: 74 6f 74 61 6c 2d 71 75 65 72 69 65 73 20 28 2b total-queries (+ 06d0: 20 74 6f 74 61 6c 2d 71 75 65 72 69 65 73 20 31 total-queries 1 06e0: 29 29 0a 20 20 20 20 20 28 70 72 69 6e 74 20 22 )). (print " 06f0: 45 78 65 63 75 74 69 6e 67 20 71 75 65 72 79 20 Executing query 0700: 27 22 20 73 71 6c 73 74 6d 74 20 22 27 20 2e 2e '" sqlstmt "' .. 0710: 2e 22 29 0a 20 20 20 20 20 28 6c 65 74 20 28 28 ."). (let (( 0720: 64 62 20 28 67 65 74 2d 64 62 29 29 29 0a 20 20 db (get-db))). 0730: 20 20 20 20 20 28 71 75 65 72 79 20 28 66 6f 72 (query (for 0740: 2d 65 61 63 68 2d 72 6f 77 0a 09 20 20 20 20 20 -each-row.. 0750: 20 20 63 61 6c 6c 62 61 63 6b 29 0a 09 20 20 20 callback).. 0760: 20 20 20 28 73 71 6c 20 64 62 20 73 71 6c 73 74 (sql db sqlst 0770: 6d 74 29 29 0a 20 20 20 20 20 20 20 28 70 72 69 mt)). (pri 0780: 6e 74 20 22 51 75 65 72 79 20 72 61 74 65 3a 20 nt "Query rate: 0790: 22 20 28 2f 20 74 6f 74 61 6c 2d 71 75 65 72 69 " (/ total-queri 07a0: 65 73 20 28 2f 20 28 2d 20 28 63 75 72 72 65 6e es (/ (- (curren 07b0: 74 2d 73 65 63 6f 6e 64 73 29 20 73 74 61 72 74 t-seconds) start 07c0: 2d 74 69 6d 65 29 20 36 30 29 29 20 22 20 70 65 -time) 60)) " pe 07d0: 72 20 6d 69 6e 75 74 65 22 29 0a 20 20 20 20 20 r minute"). 07e0: 20 20 28 70 72 69 6e 74 20 22 6e 75 6d 20 64 62 (print "num db 07f0: 73 3a 20 22 20 28 72 65 74 75 72 6e 2d 64 62 20 s: " (return-db 0800: 64 62 29 29 0a 20 20 20 20 20 20 20 29 29 29 0a db)). ))). 0810: 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 (thread-join! 0820: 72 70 63 3a 73 65 72 76 65 72 29 29 0a 0a 3b 3b rpc:server))..;; 0830: 3b 20 43 6c 69 65 6e 74 20 73 69 64 65 0a 0a 28 ; Client side..( 0840: 64 65 66 69 6e 65 20 28 63 61 6c 6c 62 61 63 6b define (callback 0850: 31 20 2e 20 63 6f 6c 75 6d 6e 73 29 0a 20 20 28 1 . columns). ( 0860: 6c 65 74 20 6c 6f 6f 70 20 28 28 63 20 63 6f 6c let loop ((c col 0870: 75 6d 6e 73 29 20 28 69 20 30 29 29 0a 20 20 20 umns) (i 0)). 0880: 20 28 75 6e 6c 65 73 73 20 28 6e 75 6c 6c 3f 20 (unless (null? 0890: 63 29 0a 20 20 20 20 20 20 28 70 72 69 6e 74 66 c). (printf 08a0: 20 22 7e 61 3d 7e 73 20 22 20 69 20 28 63 61 72 "~a=~s " i (car 08b0: 20 63 29 29 0a 20 20 20 20 20 20 28 6c 6f 6f 70 c)). (loop 08c0: 20 28 63 64 72 20 63 29 20 28 2b 20 69 20 31 29 (cdr c) (+ i 1) 08d0: 29 29 29 0a 20 20 28 6e 65 77 6c 69 6e 65 29 29 ))). (newline)) 08e0: 0a 0a 28 64 65 66 69 6e 65 20 63 61 6c 6c 62 61 ..(define callba 08f0: 63 6b 32 2d 72 65 73 75 6c 74 73 20 27 28 29 29 ck2-results '()) 0900: 0a 0a 28 64 65 66 69 6e 65 20 28 63 61 6c 6c 62 ..(define (callb 0910: 61 63 6b 32 20 2e 20 63 6f 6c 75 6d 6e 73 29 0a ack2 . columns). 0920: 20 20 28 73 65 74 21 20 63 61 6c 6c 62 61 63 6b (set! callback 0930: 32 2d 72 65 73 75 6c 74 73 20 28 63 6f 6e 73 20 2-results (cons 0940: 63 6f 6c 75 6d 6e 73 20 63 61 6c 6c 62 61 63 6b columns callback 0950: 32 2d 72 65 73 75 6c 74 73 29 29 29 0a 0a 28 64 2-results)))..(d 0960: 65 66 69 6e 65 20 28 63 6c 69 65 6e 74 29 0a 20 efine (client). 0970: 20 28 28 72 70 63 3a 70 72 6f 63 65 64 75 72 65 ((rpc:procedure 0980: 20 27 63 68 61 6e 67 65 2d 72 65 73 70 6f 6e 73 'change-respons 0990: 65 2d 70 6f 72 74 20 22 6c 6f 63 61 6c 68 6f 73 e-port "localhos 09a0: 74 22 29 0a 20 20 20 28 74 63 70 2d 6c 69 73 74 t"). (tcp-list 09b0: 65 6e 65 72 2d 70 6f 72 74 20 72 70 63 3a 6c 69 ener-port rpc:li 09c0: 73 74 65 6e 65 72 29 29 0a 20 20 28 28 72 70 63 stener)). ((rpc 09d0: 3a 70 72 6f 63 65 64 75 72 65 20 27 71 75 65 72 :procedure 'quer 09e0: 79 20 22 6c 6f 63 61 6c 68 6f 73 74 22 29 20 70 y "localhost") p 09f0: 61 72 61 6d 20 63 61 6c 6c 62 61 63 6b 31 29 0a aram callback1). 0a00: 20 20 28 72 70 63 3a 70 75 62 6c 69 73 68 2d 70 (rpc:publish-p 0a10: 72 6f 63 65 64 75 72 65 21 20 27 63 61 6c 6c 62 rocedure! 'callb 0a20: 61 63 6b 32 20 63 61 6c 6c 62 61 63 6b 32 29 0a ack2 callback2). 0a30: 20 20 28 28 72 70 63 3a 70 72 6f 63 65 64 75 72 ((rpc:procedur 0a40: 65 20 27 71 75 65 72 79 20 22 6c 6f 63 61 6c 68 e 'query "localh 0a50: 6f 73 74 22 29 20 70 61 72 61 6d 20 63 61 6c 6c ost") param call 0a60: 62 61 63 6b 32 29 0a 20 20 28 70 70 20 63 61 6c back2). (pp cal 0a70: 6c 62 61 63 6b 32 2d 72 65 73 75 6c 74 73 29 0a lback2-results). 0a80: 20 20 28 72 70 63 3a 63 6c 6f 73 65 2d 63 6f 6e (rpc:close-con 0a90: 6e 65 63 74 69 6f 6e 21 20 22 6c 6f 63 61 6c 68 nection! "localh 0aa0: 6f 73 74 22 20 28 72 70 63 3a 64 65 66 61 75 6c ost" (rpc:defaul 0ab0: 74 2d 73 65 72 76 65 72 2d 70 6f 72 74 29 29 29 t-server-port))) 0ac0: 0a 0a 3b 3b 3b 20 52 75 6e 20 69 74 0a 0a 28 69 ..;;; Run it..(i 0ad0: 66 20 28 65 71 3f 20 6f 70 65 72 61 74 69 6f 6e f (eq? operation 0ae0: 20 27 73 65 72 76 65 72 29 0a 20 20 20 20 28 73 'server). (s 0af0: 65 72 76 65 72 29 0a 20 20 20 20 28 63 6c 69 65 erver). (clie 0b00: 6e 74 29 29 0a 0a nt))..