From: John Benediktsson Date: Sun, 30 Jan 2022 19:21:26 +0000 (-0800) Subject: protocols.tftp: move to tftp X-Git-Tag: 0.99~1601 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=685e695f3cec54371d20732d59787059900d1c84 protocols.tftp: move to tftp --- diff --git a/extra/protocols/tftp/authors.txt b/extra/protocols/tftp/authors.txt deleted file mode 100644 index 7c1b2f2279..0000000000 --- a/extra/protocols/tftp/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/extra/protocols/tftp/tftp.factor b/extra/protocols/tftp/tftp.factor deleted file mode 100644 index 38c4eaeaf7..0000000000 --- a/extra/protocols/tftp/tftp.factor +++ /dev/null @@ -1,114 +0,0 @@ -! Copyright (C) 2019 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs combinators -combinators.short-circuit continuations destructors endian -io io.directories io.encodings.binary io.encodings.latin1 -io.encodings.string io.encodings.utf8 io.files io.files.info -io.sockets kernel math math.parser namespaces pack prettyprint -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-client ( bytes -- ) - 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 ) - binary swap - '[ _ 512 * seek-absolute seek-input 512 read ] with-file-reader ; - -: 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 - ] [ - drop - ] if ; - -: handle-send-file ( bytes -- ) - "\0" split harvest first2 [ utf8 decode ] bi@ - over { [ file-exists? ] [ file-info directory? not ] } 1&& [ - "netascii" sequence= utf8 binary ? 0 read-file boa - tftp-client get clients get set-at - 0 handle-send-file-next - ] [ - 2drop "File not found" send-error - ] if ; - -: 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 ] - [ [ . flush ] with-global 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 ; diff --git a/extra/tftp/authors.txt b/extra/tftp/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/tftp/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/tftp/tftp.factor b/extra/tftp/tftp.factor new file mode 100644 index 0000000000..1de4c9c6ae --- /dev/null +++ b/extra/tftp/tftp.factor @@ -0,0 +1,114 @@ +! Copyright (C) 2019 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs combinators +combinators.short-circuit continuations destructors endian +io io.directories io.encodings.binary io.encodings.latin1 +io.encodings.string io.encodings.utf8 io.files io.files.info +io.sockets kernel math math.parser namespaces pack prettyprint +random sequences sequences.extras splitting strings ; +IN: 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-client ( bytes -- ) + 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 ) + binary swap + '[ _ 512 * seek-absolute seek-input 512 read ] with-file-reader ; + +: 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 + ] [ + drop + ] if ; + +: handle-send-file ( bytes -- ) + "\0" split harvest first2 [ utf8 decode ] bi@ + over { [ file-exists? ] [ file-info directory? not ] } 1&& [ + "netascii" sequence= utf8 binary ? 0 read-file boa + tftp-client get clients get set-at + 0 handle-send-file-next + ] [ + 2drop "File not found" send-error + ] if ; + +: 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 ] + [ [ . flush ] with-global 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 ;