diff --git a/extra/protocols/tftp/authors.txt b/extra/protocols/tftp/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/protocols/tftp/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/protocols/tftp/tftp.factor b/extra/protocols/tftp/tftp.factor new file mode 100644 index 0000000000..9796922ed5 --- /dev/null +++ b/extra/protocols/tftp/tftp.factor @@ -0,0 +1,105 @@ +! Copyright (C) 2019 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs combinators continuations +destructors fry io io.backend.unix io.binary io.directories +io.encodings.binary io.encodings.latin1 io.encodings.string +io.encodings.utf8 io.files io.sockets kernel math math.parser +namespaces pack random sequences sequences.extras splitting +strings ; +IN: protocols.tftp + +CONSTANT: TFTP-RRQ 1 ! Read request (RRQ) +CONSTANT: TFTP-WRQ 2 ! Write request (WRQ) +CONSTANT: TFTP-DATA 3 ! Data (DATA) +CONSTANT: TFTP-ACK 4 ! Acknowledgment (ACK) +CONSTANT: TFTP-ERROR 5 ! Error (ERROR) + +GENERIC: get-tftp-host ( server -- host ) +M: string get-tftp-host resolve-host random host>> 69 ; +M: integer get-tftp-host "127.0.0.1" swap ; +M: inet4 get-tftp-host ; +M: f get-tftp-host drop "127.0.0.1" 69 ; + +: tftp-get ( filename encoding server -- bytes ) + '[ + TFTP-RRQ _ _ 3array "Saa" pack-be + _ get-tftp-host + f 0 &dispose + [ send ] keep + dup + '[ + _ receive + [ 4 cut swap 2 cut nip be> TFTP-ACK swap 2array "SS" pack-be ] dip + _ send + dup length 511 > + ] loop>array* concat + ] with-destructors ; + +: tftp-get-netascii ( filename server/port/inet4/f -- bytes ) + "netascii" swap tftp-get latin1 decode ; + +: tftp-get-octet ( filename server/port/inet4/f -- bytes ) + "octet" swap tftp-get ; + +SYMBOL: tftp-server +SYMBOL: tftp-client +SYMBOL: clients +SYMBOL: tftp-servers +tftp-servers [ H{ } clone ] initialize +TUPLE: read-file path encoding block ; + +: send-file-block ( bytes block -- ) + TFTP-DATA swap 2array "SS" pack B{ } prepend-as + tftp-client get tftp-server get send ; + +: read-file-block ( path n -- bytes ) + binary swap + '[ _ 512 * seek-absolute seek-input 512 read ] with-file-reader ; + +ERROR: unknown-client client ; +: handle-send-file-next ( block -- ) + drop + tftp-client get clients get ?at [ + [ [ path>> ] [ block>> ] bi read-file-block ] + [ [ 1 + ] change-block block>> ] bi + send-file-block + ] [ + unknown-client + ] if ; + +: handle-send-file ( bytes -- ) + "\0" split harvest first2 [ utf8 decode ] bi@ + "netascii" sequence= utf8 binary ? 0 read-file boa + tftp-client get clients get set-at + 0 handle-send-file-next ; + +: read-tftp-command ( -- ) + tftp-server get receive tftp-client [ + 2 cut swap be> { + { TFTP-RRQ [ handle-send-file ] } + { TFTP-ACK [ be> handle-send-file-next ] } + [ number>string " unimplemented" append throw ] + } case + ] with-variable ; + +: start-tftp-server ( directory port/f -- ) + get-tftp-host + '[ + H{ } clone clients [ + _ tftp-server [ + tftp-server get dup addr>> port>> tftp-servers get-global set-at + [ + [ read-tftp-command t ] + [ dup io-timeout? [ drop ] [ rethrow ] if f ] recover + ] loop + ] with-variable + ] with-variable + ] with-directory ; + +ERROR: tftp-server-not-running port ; +: stop-tftp-server ( port -- ) + tftp-servers get-global ?delete-at [ + dispose + ] [ + tftp-server-not-running + ] if ;