Changeset 4535 in project


Ignore:
Timestamp:
06/13/07 21:23:39 (13 years ago)
Author:
Kon Lovett
Message:

Bug fix for new synch & osprocess.

Location:
remote-launch
Files:
9 edited

Legend:

Unmodified
Added
Removed
  • remote-launch/launch-process.scm

    r2986 r4535  
    66;; - Doesn't support remote connections of spawned process stdin/stdout;
    77;; i.e. remote-pipe.
    8 ;;
    9 ;; - Since no pipes processes must be explicitly waited (reaped) on so no zombies.
    108
    119(use miscmacros misc-extn-procs lookup-table synch osprocess)
     
    2220        last-exp ) ) ) )
    2321
    24 (define *processes*
    25   (make-synchronized-object (make-dict fx=) 'processes))
     22(define *processes* (make-object/synch (make-dict fx=) 'processes))
    2623
    2724(define (process-started? pid)
     
    3734      (last-process-exception exp)
    3835      #f)
    39     (receive [in out pid err osp] (osprocess cmd #:arguments args)
     36    (receive [pid in out err osp] (osprocess cmd #:arguments args)
    4037      (%let/synch ([dict *processes*])
    4138        (dict-set! dict pid osp) )
  • remote-launch/launch-setup.scm

    r3579 r4535  
    3737  (handle-exceptions exp
    3838    #f
    39     (receive [in out pid err osp]
     39    (receive [pid in out err osp]
    4040             (osprocess (make-chicken-setup-commandline opts) #:reap? #f)
    4141      (begin0
  • remote-launch/remote-launch-client.scm

    r3579 r4535  
    66;; - Should match version-number w/ server?
    77
    8 (use srfi-1 srfi-18 tcp utils srfi-9)
    9 (use openssl miscmacros misc-extn mathh-int synch openssl)
     8(use srfi-1 srfi-9 srfi-18)
     9(use tcp utils)
     10(use openssl miscmacros misc-extn mathh-int synch)
    1011
    1112(eval-when (compile)
     
    7374;;;
    7475
    75 (define *serial-number* (make-synchronized-object 0 'serial-number))
     76;;
     77
     78(define *serial-number* (make-object/synch -1 'serial-number))
    7679
    7780(define (next-serial-number)
    78         (%synch-with *serial-number* sno
    79                 (begin0
    80                         sno
    81                         (set-synchronized-object! *serial-number* (add1 sno))) ) )
     81        (%set!/synch [sno *serial-number*] (add1 sno)) )
     82
     83;;
    8284
    8385(define (make-request-sender client)
     
    113115(define (make-shutdown-request client pid)
    114116        (make-request-packet 'shutdown client pid) )
     117
     118;;
    115119
    116120(define (response-packet? obj)
     
    125129       (string? (response-packet-receiver-name obj))
    126130       (integer? (response-packet-serial obj)) ) )
     131
     132;;
    127133
    128134(define (request-response client req)
     
    177183        ;
    178184        (when (symbol? ctx)
    179                 (set! ctx (if (eq? 'none ctx) #f (ssl-make-client-context ctx))))
     185                (set! ctx (and (not (eq? 'none ctx)) (ssl-make-client-context ctx))))
    180186        ;
    181187        (unless (or (string? name) (symbol? name))
     
    234240                (error 'remote-spawn-request "invalid command name" cmd))
    235241        ;
    236         (request-response client
    237                 (make-spawn-request client cmd (map ->string args))) )
     242        (request-response client (make-spawn-request client cmd (map ->string args))) )
    238243
    239244;;
  • remote-launch/remote-launch-eggdoc.scm

    r2825 r4535  
    3232    (author (url "mailto:klovett@pacbell.net" "Kon Lovett"))
    3333    (history
     34      (version "0.4" "Update for new osprocess, misc-extn, synch")
    3435      (version "0.3" "Update for new chicken-setup")
    3536      (version "0.2" "Better chicken version")
  • remote-launch/remote-launch-server.scm

    r3579 r4535  
    4949;; Chicken extension in the Chicken repository
    5050
    51 (use srfi-1 srfi-13 srfi-18 extras utils posix tcp)
    52 (use openssl tcp-server srfi-37 args misc-extn misc-extn-list)
     51(use srfi-1 srfi-13 srfi-18)
     52(use extras utils posix tcp)
     53(use srfi-37 args)
     54(use openssl tcp-server misc-extn misc-extn-list)
    5355
    5456(declare
     
    6769
    6870;;;
    69 
    70 #;(define version
    71   (let ([lst (string-tokenize "$Revision$")])
    72     (if (length>1 lst)
    73       (second lst)
    74       "0.0.0") ) )
    7571
    7672(define listen-port DEFAULT-REMOTE-LAUNCH-PORT)
     
    205201
    206202(define (platform-information)
    207   `((server-version . ,version-number)
    208     (chicken-version . ,(chicken-version))
    209     (machine-byte-order . ,(machine-byte-order))
    210     (machine-type . ,(machine-type))
    211     (software-type . ,(software-type))
    212     (software-version . ,(software-version)) ) )
     203  `((server-version       . ,version-number)
     204    (chicken-version      . ,(chicken-version))
     205    (machine-byte-order   . ,(machine-byte-order))
     206    (machine-type         . ,(machine-type))
     207    (software-type        . ,(software-type))
     208    (software-version     . ,(software-version)) ) )
    213209
    214210;;;
     
    225221       (integer? (request-packet-serial obj)) ) )
    226222
     223;;
     224
    227225(define (request-kind? req knd)
    228226  (eq? (request-packet-operation req) knd) )
     227
     228;;
    229229
    230230(define (platform-request? req)
     
    280280
    281281(define (do-platform-request req local)
    282   (apply make-request-response-packet req local
    283     (platform-information)) )
     282  (apply make-request-response-packet req local (platform-information)) )
    284283
    285284(define (do-repository-list-request req local)
    286285  (let ([out+err (chicken-repository-list)])
    287     (make-request-response-packet req local
    288       (car out+err) (cdr out+err)) ) )
     286    (make-request-response-packet req local (car out+err) (cdr out+err)) ) )
    289287
    290288(define (do-extension-information-request req local)
     
    292290         [extn (first args)]
    293291         [info (extension-information extn)])
    294     (apply make-request-response-packet req local
    295       info) ) )
     292    (apply make-request-response-packet req local info) ) )
    296293
    297294(define (do-install-request req local)
     
    299296         [extn (first args)]
    300297         [out+err
    301           (let-values (([host proxy] (request-install-host-proxy-values (cdr args))))
     298          (receive [host proxy] (request-install-host-proxy-values (cdr args))
    302299            (parameterize ([chicken-setup-host host] [chicken-setup-proxy proxy])
    303               (chicken-install-extension extn)))])
    304     (make-request-response-packet req local
    305       (car out+err) (cdr out+err)) ) )
     300              (chicken-install-extension extn) ) )])
     301    (make-request-response-packet req local (car out+err) (cdr out+err)) ) )
    306302
    307303(define (do-uninstall-request req local)
     
    309305         [extn (first args)]
    310306         [out+err (chicken-uninstall-extension extn)])
    311     (make-request-response-packet req local
    312       (car out+err) (cdr out+err)) ) )
     307    (make-request-response-packet req local (car out+err) (cdr out+err)) ) )
    313308
    314309(define (do-spawn-request req local)
     
    316311         [pid (start-process! (first args) (cdr args))])
    317312    (if pid
    318       (make-request-response-packet req local
    319         pid (process-started? pid))
    320       (make-error-response-packet req local
    321         "cannot spawn process" (last-process-exception)) ) ) )
     313      (make-request-response-packet req local pid (process-started? pid))
     314      (make-error-response-packet req local
     315                                  "cannot spawn process"
     316                                  (last-process-exception)) ) ) )
    322317
    323318(define (do-exit-request req local)
     
    327322         [exp (last-process-exception)])
    328323    (if (or term (not exp))
    329       (make-request-response-packet req local
    330         pid term)
    331       (make-error-response-packet req local
    332           "cannot check exit status for process" exp) ) ) )
     324      (make-request-response-packet req local pid term)
     325      (make-error-response-packet req local
     326                                  "cannot check exit status for process"
     327                                  exp) ) ) )
    333328
    334329(define (do-shutdown-request req local)
     
    337332         [ok (shutdown-process! pid)])
    338333    (if ok
    339       (make-request-response-packet req local
    340         pid (reap-process! pid))
    341       (make-error-response-packet req local
    342         "cannot terminate process" (last-process-exception)) ) ) )
     334      (make-request-response-packet req local pid (reap-process! pid))
     335      (make-error-response-packet req local
     336                                  "cannot terminate process"
     337                                  (last-process-exception)) ) ) )
    343338
    344339;;;
     
    346341(define (do-request req local remote)
    347342  (cond
    348     [(platform-request? req)
    349       (do-platform-request req local)]
    350     [(repository-list-request? req)
    351       (do-repository-list-request req local)]
    352     [(extension-information-request? req)
    353       (do-extension-information-request req local)]
    354     [(install-request? req)
    355       (do-install-request req local)]
    356     [(uninstall-request? req)
    357       (do-uninstall-request req local)]
    358     [(spawn-request? req)
    359       (do-spawn-request req local)]
    360     [(exit-request? req)
    361       (do-exit-request req local)]
    362     [(shutdown-request? req)
    363       (do-shutdown-request req local)]
     343    [(platform-request? req)                (do-platform-request req local)]
     344    [(repository-list-request? req)         (do-repository-list-request req local)]
     345    [(extension-information-request? req)   (do-extension-information-request req local)]
     346    [(install-request? req)                 (do-install-request req local)]
     347    [(uninstall-request? req)               (do-uninstall-request req local)]
     348    [(spawn-request? req)                   (do-spawn-request req local)]
     349    [(exit-request? req)                    (do-exit-request req local)]
     350    [(shutdown-request? req)                (do-shutdown-request req local)]
    364351    [else
    365352      (make-error-response-packet req local
    366         "unrecognized launch request" (request-packet-operation req))]) )
     353                                  "unrecognized launch request"
     354                                  (request-packet-operation req))]) )
    367355
    368356(define (process-request req local remote)
     
    370358    [(not (request-packet? req))
    371359      (make-error-response-packet req local
    372         "invalid launch request packet"
    373         req)]
     360                                  "invalid launch request packet"
     361                                  req)]
    374362    [(not (equal? remote (request-packet-sender-address req)))
    375363      (make-error-response-packet req local
    376         "launch request sender mismatch"
    377         remote (request-packet-sender-address req))]
     364                                  "launch request sender mismatch"
     365                                  remote (request-packet-sender-address req))]
    378366    [else
    379367      (do-request req local remote)] ) )
     
    382370  (let ([req (read)])
    383371    (receive [local remote] (tcp-addresses (current-input-port))
    384       (write (process-request req local remote)))
    385     (flush-output)) )
     372      (write (process-request req local remote)) )
     373    (flush-output) ) )
    386374
    387375;;; Main
  • remote-launch/remote-launch-test.scm

    r3933 r4535  
    1717
    1818(define-test start-server-test "Launchd Server"
    19   (if (eq? (test::run-mode) 'driven)
    20     (expect-set! *launchd-pid* (process-run "chicken-launchd"))
    21     (expect-set! *launchd-pid* (process-run "chicken-launchd" '("--debug"))))
     19  (expect-set! *launchd-pid* (process-run "chicken-launchd"
     20                                          (if (eq? 'driven (test::run-mode)) '() '("--debug"))))
    2221  (expect-zero (sleep 1))
    2322)
  • remote-launch/remote-launch.setup

    r3977 r4535  
    11(include "setup-header")
    22
    3 (define rl-dir (make-repository-pathname "remote-launch"))
    4 (create-directory rl-dir)
    5 (copy-file "cacert.pem" (make-pathname rl-dir "server-certs.pem"))
    6 (copy-file "privkey.pem" (make-pathname rl-dir "server-privs.pem"))
    7 (copy-file "cacert-client.pem" (make-pathname rl-dir "client-certs.pem"))
     3(required-extension-version 'synch "1.4" 'osprocess "1.2" 'misc-extn "2.9.3")
     4
     5;;
     6
     7(define REMOTE-LAUNCH-REPO (make-repository-pathname "remote-launch"))
     8(create-directory REMOTE-LAUNCH-REPO)
     9
     10(define (make-privacy-enhanced-mail-pathname dn bn)
     11  (make-pathname (and dn (->string dn)) (->string bn) "pem") )
     12
     13(define (copy-privacy-enhanced-mail-file fn tn)
     14  (copy-file (make-privacy-enhanced-mail-pathname #f fn)
     15             (make-privacy-enhanced-mail-pathname REMOTE-LAUNCH-REPO tn)) )
     16
     17(copy-privacy-enhanced-mail-file "cacert" "server-certs")
     18(copy-privacy-enhanced-mail-file "privkey" "server-privs")
     19(copy-privacy-enhanced-mail-file "cacert-client" "client-certs")
     20
     21;;
    822
    923(compile -O3 -d0 -b -G remote-launch-server.scm -o chicken-launchd)
    1024(install-program 'remote-launch-server
    1125        '("chicken-launchd")
    12         '((version "0.3")
     26        '((version "0.4")
    1327          (documentation "remote-launch.html")))
    1428
    15 (install-dynld remote-launch-client "0.3" (documentation "remote-launch.html"))
     29(install-dynld remote-launch-client "0.4" (documentation "remote-launch.html"))
    1630
    1731(install-test "remote-launch-test.scm")
  • remote-launch/setup-header.scm

    r4212 r4535  
    3030  (make-filename bn ##sys#load-dynamic-extension) )
    3131
     32(define (make-static-filename bn)
     33  (make-filename bn "o") )
     34
    3235(define (make-source-filename bn)
    3336  (make-filename bn "scm") )
     
    7376(define test-driver-arguments
    7477  (make-parameter
    75     (string-append TESTBASE-TEST-DRIVER-OPTIONS (if (setup-verbose-flag) " -v" ""))
    76     (lambda (x) (if (string? x) x (test-driver-arguments)))))
     78    (string-append TESTBASE-TEST-DRIVER-OPTIONS
     79                   (if (setup-verbose-flag) " -v" ""))
     80    (lambda (x)
     81      (if (string? x) x (test-driver-arguments)))))
     82
     83(define (copy-tests . flnms)
     84  (unless (file-exists? TESTBASE-TESTS-DIRECTORY)
     85    (create-directory TESTBASE-TESTS-DIRECTORY) )
     86  (map
     87    (lambda (x)
     88      (if (list? x)
     89        ; then has extra files (probably test data)
     90        (begin
     91          (for-each (cut copy-file-to-test-repository <>) x)
     92          (car x))
     93        ; else test is self contained
     94        (begin (copy-file-to-test-repository x) x)))
     95    flnms) )
     96
     97(define (run-tests . tsts)
     98  ; Quote driver command for Windows.
     99  ; Test filenames CANNOT include whitespace (Windows issue).
     100  (for-each
     101    (cute system* "\"~A\" ~A ~A"
     102                  TESTBASE-TEST-DRIVER (test-driver-arguments) <>)
     103    tsts) )
    77104
    78105(define (install-test . flnms)
    79106  (newline)
    80   (print "* Installing test files in " TESTBASE-TESTS-DIRECTORY #\:)
    81   (unless (file-exists? TESTBASE-TESTS-DIRECTORY)
    82     (create-directory TESTBASE-TESTS-DIRECTORY) )
    83   (let ([tsts
    84           (map
    85             (lambda (x)
    86               (if (list? x)
    87                 ;then has extra files (probably test data)
    88                 (begin
    89                   (for-each (cut copy-file-to-test-repository <>) x)
    90                   (car x))
    91                 ;else test is self contained
    92                 (begin
    93                   (copy-file-to-test-repository x)
    94                   x)))
    95             flnms)])
    96   (if (string>? "2.610" (chicken-version))
    97     (begin
    98       (newline)
    99       (print "* Chicken 2.610+ needed to perform testing.") )
     107  (print "* Installing TestBase Test-Files in " TESTBASE-TESTS-DIRECTORY #\:)
     108  (let ([tsts (apply copy-tests flnms)])
    100109    (if (installed-program-exists? TESTBASE-TEST-DRIVER)
    101110      (begin
     
    103112          (newline)
    104113          (print "* Running test files" #\:) )
    105         ; Quote driver command for Windows.
    106         ; Test filenames CANNOT include whitespace.
    107         (for-each
    108           (cute system* "\"~A\" ~A ~A" TESTBASE-TEST-DRIVER (test-driver-arguments) <>)
    109           tsts) )
     114        (apply run-tests tsts) )
    110115      (begin
    111116        (newline)
    112         (print "* TestBase is not installed. Cannot perform testing.") ) ) ) ) )
     117        (print "* TestBase Driver is not installed; cannot perform testing.") ) ) ) )
    113118
    114119;; Options Parsing
     
    169174    ,@OPT) )
    170175
     176(define-macro (compile-static SRCSTAFIL . OPT)
     177  `(compile
     178    -c
     179    -O2 -d1
     180    ,(make-source-filename SRCSTAFIL)
     181    -unit ,SRCSTAFIL
     182    -o ,(make-static-filename SRCSTAFIL)
     183    -check-imports -emit-exports ,(make-exports-filename SRCSTAFIL)
     184    ,@OPT) )
     185
     186(define-macro (compile-static/rename SRCSTAFIL OUTSTAFIL . OPT)
     187  `(compile
     188    -c
     189    -O2 -d1
     190    ,(make-source-filename SRCSTAFIL)
     191    -unit ,OUTSTAFIL
     192    -o ,(make-static-filename OUTSTAFIL)
     193    -check-imports -emit-exports ,(make-exports-filename OUTSTAFIL)
     194    ,@OPT) )
     195
    171196;; Note that these cannot accept quasi-stuff in OPT
    172197
  • remote-launch/version-number.scm

    r2690 r4535  
    11;;;; version-number.scm
    22
    3 (define version-number "0.3")
     3(define version-number "0.4")
Note: See TracChangeset for help on using the changeset viewer.