I'm trying to make a TFTP server with scsh. I'm using OpenBSD and
0.6.6 (King Conan). I have not patched in Mike's stuff for process
forms.
To my horror, I'm getting a low-level error that appears random to
me. Exactly when (and how) seems non-deterministic.
This is really concerning and depressing for me.
I've hacked my TFTP server down just for this bug report (no thread
for the transfer, no file input --- just datagram i/o), but it still
seems broken just the same.
I'm using the "King Conan" version --- I haven't patched in Mike's
stuff to make the extended processes and so on more like normal scheme
objects. I'm doing this with OpenBSD, if that helps.
If you need more info on my system, please say. I'm assuming not.
I'd love any help on this. I'm totally stuck.
Here's the program (please store in "bugreport.scm"):
(define (network-short n)
(list (quotient n 256)
(remainder n 256)))
(define (same-inet-sockets? . sl)
(apply equal? (map (lambda (s)
(call-with-values (lambda ()
(socket-address->internet-address
s))
list)) sl)))
(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)))
(letrec ((s (create-socket protocol-family/internet socket-type/datagram))
(server-port 6666))
(bind-socket s (internet-address->socket-address
internet-address/any ;;(car (host-info:addresses (host-info
"localhost")))
server-port))
(dynamic-wind
(lambda () #f)
(lambda () (call-with-values (lambda () (receive-message/partial s 1024))
(lambda (thing addr)
;;; This part should be in its own thread,
;;; but leave that out until it doesn't crash
;;; horribly.
(let ((new-sock (create-socket protocol-family/internet
socket-type/datagram))
(file-str
"abcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeab"
))
(let loop ((block-no 1))
(let resend ()
;; send out the current block of data.
(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)
;; TFTP rfc says to reject if from bad port.
(if (not (same-inet-sockets? addr-2 addr))
(send-byte-l new-sock `( 0 5 0 5 "bad port"
0) addr-2)
;; check the code -- should normally be an
ACK=4
(let ((message-as-list (map char->ascii
(string->list str)))
(get-shorty (lambda (l)
(+ (* (car l) 256) (cadr
l)))))
(if (= (get-shorty message-as-list)
4) ;ACK
(let ((incoming-blockno (get-shorty
(cddr message-as-list))))
(write incoming-blockno)
(newline)
(cond ((and (= incoming-blockno
block-no)
(string? file-str)
(equal?
(string-length file-str)
512))
(loop (+ 1 block-no)))
(else (resend))))
(resend))))))))
(close-socket new-sock)))))
(lambda () (close-socket s))))
And here's how to test it:
put that code in a file. load it into scsh.
> (load "bugreport.scm")
bugreport.scm
Then go to the shell and do this:
heath:test {106} tftp
tftp> connect localhost 6666
tftp> get bsd
You'll see a column of numbers streaming by in the scheme window (as
it prints out the block number) until it gives an error:
1
2
3
...
12136
Error: exception
wrong-type-argument
(return-from-callback "send_substring" '#{Random object})
1>
Here's other errors that it stops on (note --- blows out on different
blocks and for a suspicious looking "Random object" -- and further
below for "error while displaying condition" and "weak pointer"). This
stuff really scares me:
Top level
> (load "bugreport.scm")
bugreport.scm
1
2
...
537
Error: exception
wrong-type-argument
(return-from-callback "send_substring" '#{Random object})
1>
....................
1745
Error: exception
wrong-type-argument
(return-from-callback "send_substring" <Error while displaying
condition.>
1>
................
Error: exception
wrong-type-argument
(return-from-callback "send_substring" '#{Weak-pointer})
1>
Heath
|