Dear Scsh Maintainers,
I'm trying to get my tftp server to work with the recent patch to
network1.c
I'm having other trouble related to memory now, and it seems
proportional to the amount of bytes transferred.
This is odd, -- I really think my program should run with bounded
space (and not so much -- just the single buffer). I believe my
program is tail-recrsive where it needs to be.
I tried to isolate the problem to the reading, writing or socket I/O,
but I was unsuccessful, so I'm providing the whole program.
Here are the steps to test.
1. Store the program below in a file (e.g. /tmp/tftptest.scm).
2. Run scsh, doing this:
(load "/home/hp/prog/sys/tftp/test.scm")
(tftp-server 9999 "/") ; runs on port 9999, gets files from "/".
3. In a different shell, do this (to fetch the kernel, with the path
"/bsd" on my machine):
cd /tmp
tftp
tftp> connect localhost 9999
tftp> get bsd
4. Scsh will start printing out block numbers, and hopefully crash
(one time it just exited without an exhausted heap):
1 2 3 .... 7631 7632
Interrupt: post-gc 1> aborting 0
Interrupt: post-gc
2> ,debug
'#{Continuation (pc 19) (unnamed in unnamed in compose-continuation in threads)}
[0] '#{Procedure 1822 (unnamed in really-steal-port! in i/o)}
[1] '#{Continuation (pc 92) (interrupt-thread in threads)}
[2] '#{Procedure 1822 (unnamed in really-steal-port! in i/o)}
[3] '#{Continuation (pc 100) (dynamic-wind in wind)}
inspect: ,d
'#{Continuation (pc 100) (dynamic-wind in wind)}
[0] '#{Procedure 601 (list in scheme-level-1)}
[1] #f
[2] '#{Procedure 2047 (nothing in channel-i/o)}
[3] '#{Procedure 1550 (block in threads)}
[4] '#{Procedure 2051 (unnamed in unnamed in wait-for-channel ---)}
inspect: ,d
'#{Exception-continuation (pc 30) (loop in unnamed in channel-read ---)}
[0] 0
[1] '#{Procedure 458 (loop in unnamed in channel-read ---)}
[2] #t
[3] 1
[4] 1
[5] '#{Byte-vector (length 1) 10}
[6] 0
[7] 'any
[8] '#{Input-channel "standard input"}
inspect: ,d
'#{Continuation (pc 104) (unnamed in read-char-handler in i/o)}
[0] '#{Input-fdport #{Input-channel "standard input"}}
[1] #f
inspect: ,d
'#{Continuation (pc 62) (with-dynamic-env in fluids)}
[0] '#{Procedure 1109 (unnamed in with-dynamic-env in fluids)}
[1] '((# # # # # ---) (# . #f) (# # # # # ---) (# . #) (# # # # # ---) ---)
[2] #f
[3] #f
inspect: ,d
'#{Continuation (pc 35) (protect-port-op in i/o)}
[0] '#{Input-fdport #{Input-channel "standard input"}}
[1] '#{Procedure 1716 (unnamed in unnamed in one-arg-proc->handler ---)}
inspect: ,d
'#{Exception-continuation (pc 5) (loop in prompt-loop in really-read-command
---)}
[0] '#{Procedure 5842 (loop in prompt-loop in really-read-command ---)}
[1] '#{Procedure 5841 (prompt-loop in really-read-command in
command-processor)}
[2] '#{Output-fdport #{Output-channel "standard output"}}
[3] "1> "
[4] #t
[5] '#{Input-fdport #{Input-channel "standard input"}}
[6] '#{Procedure 5828 (no-more-commands in command-processor)}
inspect: ,d
'#{Continuation (pc 62) (with-dynamic-env in fluids)}
[0] '#{Procedure 1109 (unnamed in with-dynamic-env in fluids)}
[1] '((# . #f) (# # # # # ---) (# . #) (# # # # # ---) (# # # # #) ---)
[2] #f
[3] #f
inspect: ,d
'#{Continuation (pc 41) (loop in unnamed in real-command-loop ---)}
[0] '#{Procedure 5961 (loop in unnamed in real-command-loop ---)}
inspect: ,d
'#{Continuation (pc 62) (with-dynamic-env in fluids)}
[0] '#{Procedure 1109 (unnamed in with-dynamic-env in fluids)}
[1] '((# # # # # ---) (# . #) (# # # # # ---) (# # # # #) (# # # #) ---)
[2] #f
[3] #f
inspect: ,d
'#{Continuation (pc 15) (thread-start in thread-top-level in threads)}
[0] '#{Procedure 1505 (unnamed in thread-start in thread-top-level ---)}
[1] '#{Procedure 5959 (real-command-loop in command-processor)}
;;;; The simple tftp server:
;;;;
;;;;
(define (grab-n l n k k-err)
(let loop ((r '())
(l l)
(n n))
(cond ((= n 0) (k (reverse r) l))
((null? l) (k-err))
(else (loop (cons (car l) r)
(cdr l)
(- n 1))))))
(define (grab-num l n k k-err)
(grab-n l n (lambda (num-chars rest)
(k (+ (* 256 (char->ascii (car num-chars)))
(char->ascii (cadr num-chars)))
rest))
k-err))
(define (grab-str l k-ok k-err)
(let loop ((r '())
(l l))
(cond ((null? l) (k-err))
((eq? (car l) (ascii->char 0)) (k-ok (list->string (reverse r)) (cdr
l)))
(else (loop (cons (car l) r) (cdr l))))))
(define (grab-cmd l)
(let ((err (lambda () 'format-error)))
(grab-num l 2 (lambda (num rest)
(case num
((1) ;1 Read request (RRQ)
(grab-str rest
(lambda (filename rest)
(grab-str rest
(lambda (mode rest)
(if (null? rest)
`(read ,filename ,mode)
(err)))
err))
err))
((2) ; 2 Write request (WRQ)
)
((3) ; Data (DATA)
)
((4) ; Acknowledgment (ACK)
(grab-num rest 2 (lambda (code rest)
`(ack ,code))
err))
((5) ; Error (ERROR)
(grab-num rest 2 (lambda (err-code rest)
(grab-str rest
(lambda (msg rest)
(if (null? rest)
`(error ,err-code
,msg)
(err)))
err))
err))
))
err)))
(define (send-byte-l sock l addr)
(let ((s (apply string-append (map (lambda (x)
(cond ((char? x) (string x))
((number? x) (string (ascii->char
x)))
((string? x) x)
((not x) "") (else (error x))))
l))))
(if (not (string? s))
(error s))
(send-message sock
s
0 (string-length s) 0 addr)))
(define (same-inet-sockets? . sl)
(apply equal? (map (lambda (s)
(call-with-values (lambda ()
(socket-address->internet-address
s))
list)) sl)))
(define (network-short n)
(list (quotient n 256)
(remainder n 256)))
;;; a partial tftp server
(define (tftp-server server-port dir)
(letrec ((s (create-socket protocol-family/internet socket-type/datagram)))
(bind-socket s (internet-address->socket-address
internet-address/any
server-port))
(dynamic-wind
(lambda () #f)
(lambda () (let loop ()
(call-with-values (lambda () (receive-message/partial s
1024))
(lambda (thing addr)
(let loop ((cmd (grab-cmd (string->list thing))))
(case (car cmd)
;;; there should be a spawn here, but leave it
out, for ease of testing.
((read) (call-with-input-file (string-append dir
(cadr cmd))
(lambda (in)
(let ((new-sock (create-socket
protocol-family/internet
socket-type/datagram)))
(let loop ((file-str
(read-string 512 in))
(block-no 1))
(let resend ()
(for-each display (list
block-no " "))
(send-byte-l new-sock
`(,@(network-short 3) ; data opcode
,@(network-short block-no)
,file-str)
addr)
(call-with-values
(lambda ()
(receive-message/partial new-sock 1024))
(lambda (str addr-2)
(if (not
(same-inet-sockets? addr-2 addr))
(send-byte-l
new-sock `( 0 5 0 5 "bad port" 0) addr-2)
(let ((cmd (grab-cmd
(string->list str))))
(if (eq? (car cmd)
'ack)
(let ((blockno
(cadr cmd)))
(cond ((and
(= blockno block-no)
(string? file-str)
(equal? (string-length file-str)
512))
(loop
(read-string 512 in) (+ 1 block-no)))
((=
blockno block-no) (write 'done)) ;; less than 512, got the ack
(else
(resend))))
(resend)))))))
(close-socket new-sock))))))
(else
(write "oops")
(error (string->list thing)))))))
(loop)))
(lambda () (close-socket s)))))
|