protocols.tftp: Fix some bugs.
- needed pack-be - tftp clients seem to send an ACK even before receiving an error for a missing file - handles directories now, "File not found" to improve: - use the client/server pair as a key maybe - handle file writing - throw errors that are not io-timeout once we have a cross-platform timeout error objectfreebsd-work
parent
591a468800
commit
184b614e89
|
@ -1,11 +1,11 @@
|
||||||
! Copyright (C) 2019 Doug Coleman.
|
! Copyright (C) 2019 Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors arrays assocs combinators continuations
|
USING: accessors arrays assocs combinators
|
||||||
destructors fry io io.backend.unix io.binary io.directories
|
combinators.short-circuit continuations destructors fry io
|
||||||
io.encodings.binary io.encodings.latin1 io.encodings.string
|
io.binary io.directories io.encodings.binary io.encodings.latin1
|
||||||
io.encodings.utf8 io.files io.sockets kernel math math.parser
|
io.encodings.string io.encodings.utf8 io.files io.files.info
|
||||||
namespaces pack random sequences sequences.extras splitting
|
io.sockets kernel math math.parser namespaces pack prettyprint
|
||||||
strings ;
|
random sequences sequences.extras splitting strings ;
|
||||||
IN: protocols.tftp
|
IN: protocols.tftp
|
||||||
|
|
||||||
CONSTANT: TFTP-RRQ 1 ! Read request (RRQ)
|
CONSTANT: TFTP-RRQ 1 ! Read request (RRQ)
|
||||||
|
@ -48,15 +48,20 @@ SYMBOL: tftp-servers
|
||||||
tftp-servers [ H{ } clone ] initialize
|
tftp-servers [ H{ } clone ] initialize
|
||||||
TUPLE: read-file path encoding block ;
|
TUPLE: read-file path encoding block ;
|
||||||
|
|
||||||
: send-file-block ( bytes block -- )
|
: send-client ( bytes -- )
|
||||||
TFTP-DATA swap 2array "SS" pack B{ } prepend-as
|
|
||||||
tftp-client get tftp-server get send ;
|
tftp-client get tftp-server get send ;
|
||||||
|
|
||||||
|
: send-error ( message -- )
|
||||||
|
[ TFTP-ERROR 1 ] dip 3array "SSa" pack-be send-client ;
|
||||||
|
|
||||||
|
: send-file-block ( bytes block -- )
|
||||||
|
TFTP-DATA swap 2array "SS" pack-be B{ } prepend-as
|
||||||
|
send-client ;
|
||||||
|
|
||||||
: read-file-block ( path n -- bytes )
|
: read-file-block ( path n -- bytes )
|
||||||
binary swap
|
binary swap
|
||||||
'[ _ 512 * seek-absolute seek-input 512 read ] with-file-reader ;
|
'[ _ 512 * seek-absolute seek-input 512 read ] with-file-reader ;
|
||||||
|
|
||||||
ERROR: unknown-client client ;
|
|
||||||
: handle-send-file-next ( block -- )
|
: handle-send-file-next ( block -- )
|
||||||
drop
|
drop
|
||||||
tftp-client get clients get ?at [
|
tftp-client get clients get ?at [
|
||||||
|
@ -64,14 +69,18 @@ ERROR: unknown-client client ;
|
||||||
[ [ 1 + ] change-block block>> ] bi
|
[ [ 1 + ] change-block block>> ] bi
|
||||||
send-file-block
|
send-file-block
|
||||||
] [
|
] [
|
||||||
unknown-client
|
drop
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: handle-send-file ( bytes -- )
|
: handle-send-file ( bytes -- )
|
||||||
"\0" split harvest first2 [ utf8 decode ] bi@
|
"\0" split harvest first2 [ utf8 decode ] bi@
|
||||||
|
over { [ exists? ] [ file-info directory? not ] } 1&& [
|
||||||
"netascii" sequence= utf8 binary ? 0 read-file boa
|
"netascii" sequence= utf8 binary ? 0 read-file boa
|
||||||
tftp-client get clients get set-at
|
tftp-client get clients get set-at
|
||||||
0 handle-send-file-next ;
|
0 handle-send-file-next
|
||||||
|
] [
|
||||||
|
2drop "File not found" send-error
|
||||||
|
] if ;
|
||||||
|
|
||||||
: read-tftp-command ( -- )
|
: read-tftp-command ( -- )
|
||||||
tftp-server get receive tftp-client [
|
tftp-server get receive tftp-client [
|
||||||
|
@ -90,7 +99,7 @@ ERROR: unknown-client client ;
|
||||||
tftp-server get dup addr>> port>> tftp-servers get-global set-at
|
tftp-server get dup addr>> port>> tftp-servers get-global set-at
|
||||||
[
|
[
|
||||||
[ read-tftp-command t ]
|
[ read-tftp-command t ]
|
||||||
[ dup io-timeout? [ drop ] [ rethrow ] if f ] recover
|
[ [ . flush ] with-global f ] recover
|
||||||
] loop
|
] loop
|
||||||
] with-variable
|
] with-variable
|
||||||
] with-variable
|
] with-variable
|
||||||
|
|
Loading…
Reference in New Issue