tftp: Implement a client/server for tftp.

The server needs to handle multiple clients. Refactoring...

diff --git a/extra/protocols/tftp/authors.txt b/extra/protocols/tftp/authors.txt
new file mode 100644 (file)
index 0000000..7c1b2f2
--- /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 (file)
index 0000000..9796922
--- /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 <inet4> ;
+M: integer get-tftp-host "127.0.0.1" swap <inet4> ;
+M: inet4 get-tftp-host ;
+M: f get-tftp-host drop "127.0.0.1" 69 <inet4> ;
+
+: tftp-get ( filename encoding server -- bytes )
+    '[
+        TFTP-RRQ _ _ 3array "Saa" pack-be
+        _ get-tftp-host
+        f 0 <inet4> <datagram> &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 [
+            _ <datagram> 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 ;