( Please define +FTP to IFDEF compile FTP and HTTP servers ) TACHYON V4 IFDEF W5500.fth @rest org FORGET W5500.fth } pub W5500.fth PRINT" WIZNET W5500 driver 170421.0000 " ; @org W@ == @rest --- remember data org for FORGET IFNDEF =[ ALIAS CASE =[ ALIAS BREAK ] } --- dummy LEDs - revector like this: ' MYLED ' RDYLED W! pub RDYLED DROP ; pub LANLED DROP ; IFNDEF >UPPER pri >UPPER ( str1 -- ) --- Convert lower-case letters to upper-case DUP LEN$ 1 DOFOR I C@ $61 $7A WITHIN IF I C@ 32 XOR I C! THEN LOOP ; } \ Return with a random number between the specified limits from min to max-1 pub GETRND ( max min -- n ) SWAP OVER - RND 2/ SWAP MOD SWAP + ; --- some default IP settings that are only loaded in on a new pcb and if storage locations in upper eeprom is blank &192.168.0.1 == myGW &192.168.0.99 == myIP &255.255.255.0 == mySN ( HARDWARE DEFINITIONS ) --- create code variable for WIZnet chip pins that is saved in EEPROM clong wizpins ( &ce.miso.mosi.sck ) pub WIZPINS DUP wizpins ! wizpins E! ; --- set default pins to use - change at anytime then init &13.12.15.14 WIZPINS --- to revector these just write a vector to the CFA of these words using ' MYRESET ' WRESET W! pub WRESET ( on/off -- ) DROP ; pub WPWRDN ( on/off ) DROP ; ( Diagram: WIZnet SPI timing ) --- Setup both read and write control byte constants for selected block - 160512 \ 0 == wrc --- Control byte - b7..5 = socket ; b4..b3 = tx/rx/skt/com section ; b2 = r/w ; b1..b0 = 0 \ 0 == rdc PRIVATE byte wrc byte rdc --- skt.2 skt.1 skt.0 seg.1 - seg.0 rw 0 0 --- BLOCK ADDRESSING --- \ 7 6 5 4 3 2 1 0 \ --BLOCK-- -SET- RW -LEN- --- Select socket, rx or tx block in the current socket pri SKTBLK ( blk -- ) rdc C@ $1C ANDN OR --- clear reg/tx/rx context b4,b3 pri ctrl! DUP rdc C! 4 OR wrc C! ; --- preset control control for reads or writes pub @COMMON 0 ctrl! ; --- common registers ( socket 0, bank 0) pub @SKT 8 SKTBLK ; --- select RX buffer pub @TX $10 SKTBLK ; --- select TX buffer pub @RX $18 SKTBLK ; --- select RX buffer --- WRITE METHODS --- pri LX! SPIWR16 DROP wrc C@ SPIWRB DROP ; pri COMLC! @COMMON pub LC! ( byte wizadr -- ) LX! SPIWRB pri LX DROP SPICE ; pri COMLW! @COMMON pub LW! ( word wizadr -- ) LX! SPIWR16 LX ; pri COML! @COMMON pub L! ( long wizadr -- ) LX! SPIWR SPIWR SPIWR SPIWR LX ; --- READ METHODS --- pri LX@ SPIWR16 DROP rdc C@ SPIWRB ; pri COMLC@ @COMMON pub LC@ ( wizadr -- data ) LX@ SPIRD SPICE >B ; pub LW@ ( wizadr -- data ) LX@ DROP 0 SPIRD SPIRD SPICE ; pub L@ ( wizadr -- data ) LX@ SPIRD SPIRD SPIRD SPIRD SPICE ; --- BLOCK TRANSFER METHODS --- --- 140703 - Allow block read/write to access virtual memory if > $8000 PRIVATE long vread long vwrite --- maintain a read/write pointer for any virtual memory writes --- Read a block of memory from the WIZnet --- if dst is > $8000 then use virtual memory pub LREAD ( src dst cnt -- ) ROT LX@ DROP OVER 15 >> --- hub RAM or virtual memory? IF 2DUP + vwrite ! 1 DOFOR 0 SPIRD I XC! LOOP --- byte read every 5.5us (96MHZ) ELSE 1 DOFOR 0 SPIRD I C! LOOP --- Read to hub RAM THEN SPICE ; --- Write a block to the WIZnet - 3.2ms/512 bytes = = 6.25us/byte = 160kB/sec : 1kB block in 4.63ms (217K/sec) pub LWRITE ( src dst cnt -- ) SWAP LX! 0 -ROT 1 DOFOR IC@ SPIWRB LOOP SPICE ; ( ----------------------------------- REGISTER LEVEL INTERFACE -------------------------------- ) --- EEPROM CONFIG BACKUP --- --- Use the top part of the 64K EEPROM to save IP settings --- 141219 Moved from $FF00 to $FFC0 because EEWORDS using top 32K of EEPROM $FFC0 == @gateway $FFC4 == @sip $FFC8 == @subnet $FFCC == @mac $FFD0 == @ports ( 8 longs ) $FFF0 == @wcold \ common registers \ Access common registers pub wMODE ( mask -- ) 0 COMLC! ; pub GATEWAY ( addr -- ) DUP @gateway E! 1 COML! ; pub SUBNET ( mask -- ) DUP @subnet E! 5 COML! ; pub MAC ( high low -- ) DUP @mac E! $0B COML! 9 LW! ; pub SIP ( long -- ) DUP @sip E! $0F COML! ; pri INTS@ ( -- ints ) $15 COMLC@ ; pri INTMASK ( mask -- ) $16 COMLC! ; pri @RTR ( -- adr ) $19 @COMMON ; pri @RCR ( -- adr ) $1B @COMMON ; pri UIP ( ip -- ) $28 COML! ; pri UPORT ( port -- ) $2C COMLW! ; ( SOCKET INTERRUPTS ) 4 |< == &SENDOK 3 |< == &TIMEOUT 2 |< == &RECV 1 |< == &DISCON 0 |< == &CON { ( SOCKET STATUS CODES ) $00 == SOCK_CLOSED $13 == SOCK_INIT $14 == SOCK_LISTEN $17 == SOCK_ESTABLISHED $1C == SOCK_CLOSE_WAIT $22 == SOCK_UDP $32 == SOCK_IPRAW $42 == SOCK_MACRAW $5F == SOCK_PPOE ( SOCKET TRANSIENT STATUS CODES ) $15 == SOCK_SYNSENT $16 == SOCK_SYNRECV $18 == SOCK_FIN_WAIT $1A == SOCK_CLOSING $1B == SOCK_TIME_WAIT $1D == SOCK_LAST_ACK $11 == SOCK_ARP $21 == SOCK_ARP1 $31 == SOCK_ARP2 } --- current socket plus foreground socket 2 bytes socket --- Set the socket number ( calculates address and sets as a SOCKET constant b7,b6,b5 ) pub SOCKET ( socket -- ) DUP socket C! 5 SHL rdc C@ $1C AND OR ctrl! ; ALIAS SOCKET SKT pub SKT@ socket C@ ; --- modify wrc to address a socket register pub @SOCKET rdc C@ $1B ANDN 8 OR ctrl! ; \ Socket registers ( -- addr ) pri sCMD! 1 @SOCKET LC! ; --- command pri sINTS 2 @SOCKET ; --- interrupts pri sSTAT 3 @SOCKET ; --- status pri sPORT 4 @SOCKET ; --- 2 byte src port pri sDHAR! ( dst. -- ) 6 @SOCKET ; --- 6 byte dest hardware address pri sDIP! ( ip -- ) SWAP $0C @SOCKET L! ; --- 4 byte dest IP address pri sDPORT $10 @SOCKET ; --- 2 byte dest port pri sSSIZE $12 @SOCKET ; --- 2 byte dest max seg size pri sPRO $14 @SOCKET ; --- protocol in IP raw mode pri sRXMEM $1E @SOCKET ; pri sTXMEM $1F @SOCKET ; pri TXFREE@ $20 @SOCKET LW@ ; pri TXREAD $22 @SOCKET ; pri TXWRITE $24 @SOCKET ; pri RXSIZE@ $26 @SOCKET LW@ ; pri RXREAD $28 @SOCKET ; pri RXWRITE $2A @SOCKET ; pri KEEPTMR $2D @SOCKET ; --- keep alive timer \ Protocol modes pri sMODE 0 @SOCKET ; --- mode pri CLOSED 0 sMODE LC! ; pub TCP 1 sMODE LC! ; pub UDP 2 sMODE LC! ; pri IPRAW 3 sMODE LC! ; pri MACRAW 4 sMODE LC! ; pri PPPoE 5 sMODE LC! ; ( SOCKET COMMANDS - use currently select socket ) pub sOPEN 1 sCMD! ; pub sLISTEN 2 sCMD! ; pub sCONNECT 4 sCMD! ; pub sDISCON 8 sCMD! ; pub sCLOSE $10 sCMD! ; pub sSEND $20 sCMD! ; pub sSENDMAC $21 sCMD! ; pub sSENDKEEP $22 sCMD! ; pub sRECV $40 sCMD! ; pri sCLOSED? sSTAT LC@ 0= ; pri sINACTIVE? sSTAT LC@ $17 < ; pri sESTAB? sSTAT LC@ $17 = ; --- closing or wait closing pri sCLOSING? sSTAT LC@ $18 $1B WITHIN ; --- Test and reset the connection interrupt; pri sCONNECTED? sINTS LC@ &CON AND DUP IF &CON sINTS LC! THEN ; pri sDISCON? sINTS LC@ &DISCON AND DUP IF $FF sINTS LC! THEN ; --- save port config and set port pub PORT! ( srcport -- ) DUP SKT@ 4* @ports + E! pub SetPORT sPORT LW! ; { Since the W5500??? read and write index registers are unreadable until a connection has been established or cannot be written incrementally until a send then these are buffered for when they become readable } 8 words txwr --- tx write buffers for 8 sockets pub @txwr ( -- addr ) txwr SKT@ 2* + ; --- Init local copies of tx write indices pub !TXWR txwr 32 $FF FILL ; --- invalidate all txwr pointers (W5500 workaround) long txtime long txsize byte autosend --- Flag to control whether LANSEND sends when it receives a LF or not \ $0A autosend C! --- preset to autosend TIMER sendtimer pri WAITSEND txsize @ 0EXIT --- don't bother if it's empty #5000 sendtimer TIMEOUT --- give it some time to send what it has BEGIN sINTS LC@ &SENDOK AND --- until sent TXREAD LW@ TXWRITE LW@ = AND sendtimer TIMEOUT? OR --- or until timeout UNTIL &SENDOK sINTS LC! --- reset the sent interrupt flag ; --- Request WIZnet to send off current transmit data in buffer pub ?SENDPOLL txtime @ CNT@ - ABS CLKFREQ 7 >> > --- 1/128 sec timeout since last 0EXIT pub ?SEND --- check to see if anything still needs to be sent txsize @ 0EXIT --- Exit if buffer empty pub LANSEND &SENDOK sINTS LC! --- Clear send interrupt @txwr W@ TXWRITE LW! sSEND --- update TXWRITE register and command WIZnet to SEND WAITSEND txsize ~ --- reset txsize (buffer empty) ; --- send out a character through the WIZnet - either block mode or autosend pub LANEMIT ( ch -- ) DUP @txwr W@ @TX LC! --- write character to buffer @txwr W++ CNT@ txtime ! --- update local write index and activity txsize ++ --- keep count of how much might be accumulating in the h/w buffer $0A = autosend C@ AND --- SEND if this is an CRLF end of line and autosend is active txsize @ $3F0 > OR --- or AUTOSEND if buffer size is large enough already IF LANSEND THEN --- Update WIZnet chip and command it to send what it has ; pub LANKEY ( -- ch ) RXSIZE@ IF RXREAD LW@ DUP @RX LC@ --- read a character from the receive buffer SWAP 1+ RXREAD LW! sRECV --- update read index ELSE ?POLL \ keypoll W@ ?DUP IF CALL THEN --- implement a keypoll for when LANKEY is doing nothing 0 --- return with a null character THEN ; ( Redirect console output to the LAN ) pub LAN ' LANEMIT uemit W! ' LANKEY ukey W! @txwr @ 1+ 0= IF TXWRITE LW@ @txwr ! THEN --- force an update (assumed valid) if the index is "invalid" ; ( diagnostic to the terminal to reflect what is begin typed to the LAN ) pub LANCONEMIT DUP (EMIT) LANEMIT ; IFDEF KEY? ( allow input from both the serial console and the LAN socket ) pub LANCONKEY ( -- ch ) LANKEY KEY? AND OR ; } IFNDEF KEY? ( allow input from both the serial console and the LAN socket ) pub LANCONKEY ( -- ch ) LANKEY KEY OR ; } --- use both LAN and CON for output pub LANCON CON CR LAN ' LANCONEMIT uemit W! ; --- initialization --- ( Set the factory defaults on very first run - generate a random MAC in the 01.FF.xx.xx.xx.xx range ) pub WCOLD CR PRINT" Setting default IP configuration " myGW @gateway E! myIP @sip E! mySN @subnet E! RND @mac E! --- random MAC at first run, Need to have a unique ID 8 0 SWAP 1 DOFOR 0 I 4* @ports + E! LOOP $A55A @wcold E! ; \ Init the SPI for the WIZnet chip pub !WIZIO \ !PCB wizpins @ DUP SPIPINS --- Use SPI --- clock low >B LOW \ *WNCK LOW \ *WNDI LOW --- reset chip if these functions have been enabled ON WRESET OFF WPWRDN OFF WRESET ; \ $02FF == oui2 pub !WIZIP @wcold E@ $A55A <> IF WCOLD THEN @gateway E@ GATEWAY --- Assign a default gateway @subnet E@ SUBNET @sip E@ SIP $02FF @mac E@ MAC 8 0 SWAP 1 DOFOR I 4* @ports + E@ I SOCKET SetPORT LOOP $0A autosend C! --- preset to autosend ; pri !TXBUFS 8 0 SWAP 1 DOFOR I SOCKET $800 0 SWAP 2 DOFOR 0 I @TX L! 0 I @RX L! LOOP LOOP ; pub !WIZ !WIZIO !TXBUFS !WIZIP ; --- set WIZnet chip as source for any DUMP type operations pub WIZ ' LC@ dmm W! ' LW@ dmm 2+ W! ' L@ dmm 4 + W! ; PRIVATE $800 == WBUFSZ pri LSEND DUP @txwr W+! TXWRITE LW@ SWAP @TX LWRITE LANSEND ; --- Read from WIZnet buffer into file until buffer is exhausted --- Used by FTP STOR pri LREADSKT ( dst --- ) vwrite ! BEGIN RXSIZE@ ?DUP WHILE ( cnt ) RXREAD LW@ ( cnt index ) --- fetch receive read index for this socket SWAP vwrite @ SWAP ( wizptr filedst cnt ) DUP >R @RX LREAD vwrite ++ --- read WIZnet buffer directly into file and update vwrite+1 R> RXREAD LW@ + RXREAD LW! --- update read index in advance sRECV 10 ms --- signal that buffer up to READ index has been read REPEAT ; 64 bytes sktbuf --- holding buffer for socket registers pri @SKTBUF sktbuf + ; pri .EMIT '.' EMIT ; pri .IPX DUP >B $30A PRINTNUM 8 >> ; pri .IP ( off -- ) DECIMAL 3 SPACES pub .IP1 @SKTBUF U@ .IPX .EMIT .IPX .EMIT .IPX .EMIT .IPX DROP ; pri .@SKTBUF @SKTBUF pri .PTR C@++ 8 << SWAP C@ + ( $7FF AND ) $2410 PRINTNUM .EMIT ; IFNDEF SWAPB pri SWAPB ( word -- word2 ) DUP 8 >> SWAP >B 8 << OR ; } { SKT HH:MM:SS MODE PORT DEST TXRD TXWR RXRD RXWR RXSZ IR STATUS IP ADDR #1 00:00:00 TCP 21 52775 967F.967F. . . . 00 17 ESTABLISHED 192.168.016.002. } pub .SKTHD CR BOLD PRINT" SKT HH:MM:SS MODE PORT DEST TXRD TXWR RXRD RXWR RXSZ IR STATUS IP ADDR" PLAIN ; pub .SOCKET ( n -- ) .SKTHD pub .SKT DUP SOCKET 0 sktbuf $30 @SOCKET LREAD --- read in registers 0 @SKTBUF C@ IF CR '#' EMIT . 2 SPACES .TIME ELSE DROP EXIT THEN 0 @SKTBUF C@ SPACE 4* " CLSDTCP UDP IPRWMACRPPP !06!!07! " + 4 CTYPE SPACE 4 @SKTBUF W@ SWAPB $250A PRINTNUM SPACE --- PORT 16 @SKTBUF W@ SWAPB $250A PRINTNUM SPACE --- DPORT $22 .@SKTBUF $24 .@SKTBUF --- TXRD TXWR $28 .@SKTBUF $2A .@SKTBUF --- RXRD RXWR $26 .@SKTBUF SPACE --- RX SIZE 2 @SKTBUF C@ .BYTE SPACE --- INT REG 3 @SKTBUF C@ DUP .BYTE --- STATUS REG \ pri .SSTAT ( byte -- ) --- STATUS DESCRIPTION SWITCH SPACE 0 =[ PRINT" closed " ] $13 =[ PRINT" INIT " ] $14 =[ PRINT" LISTEN " ] $16 =[ PRINT" SYNRECV " $0C .IP ] $17 =[ PRINT" ESTABLISHED " $0C .IP ] $18 =[ PRINT" FIN WAIT " $0C .IP ] $1C =[ PRINT" closed wait " $0C .IP ] $22 =[ PRINT" UDP OPEN " ] $32 =[ PRINT" IPRAW OPEN " ] ; pub ifconfig 0 sktbuf $40 @COMMON LREAD \ read in common registers BOLD CR PRINT" NETWORK STATUS:" PLAIN CR PRINT" LINK " 1 $2E @SKTBUF SET? IF PRINT" *UP*" ELSE PRINT" DOWN" THEN CR PRINT" HARDWARE: " PRINT" WIZnet W5500 V" $39 @SKTBUF C@ . CR PRINT" SRC IP " $0F .IP CR PRINT" MASK " 5 .IP CR PRINT" GATEWAY" 1 .IP CR PRINT" MAC " 9 @SKTBUF 6 1 DOFOR I C@ .BYTE PRINT" ." LOOP pub .SOCKETS .SKTHD 8 0 SWAP 1 DOFOR I .SKT LOOP CR ; PUBLIC \ SOCKETS - W5500 has 8 sockets - define 4 of them 0 == NETMAN --- network management 1 == FTP 2 == FTPDAT 3 == TELNET 4 == HTTP --- uses sockets 4..7 PRIVATE : skt$ " NETFTPDATTELWEBWEBWEBWEB " ; pub EASYNET.fth PRINT" WIZNET NETWORK SERVERS 170421.0000 " ; pri UNKNOWN \ \\\ delim C@ 1+ $0D <> IF BEGIN KEY $0D <> WHILE DROP REPEAT THEN \ if there is more than get it and discard LANCON PRINT" 550 Unknown command " @WORD PRINT$ CR LANSEND ; PRIVATE word un IFNDEF QUIET \ Turn the Forth console into a quiet non-echoing/prompting command interpreter pub QUIET IF OFF ECHO ' NOOP prompt W! --- Non-interactive mode - just accept "commands" ELSE ON ECHO prompt W~ THEN ; } word blkpoll 512 == BUFSIZ --- BLKSEND will send a file sector by sector pri BLKSEND ( xaddr cnt -- ) \ send chunks of up to one complete sector at buffer address ?DUP 0= IF DROP EXIT THEN BEGIN OVER FSADR OVER BUFSIZ MIN ( xaddr cnt bufadr bufcnt ) \ grab it a sector at a time >L \ save the bufcnt (referenced as IX) IX LSEND \ copy source buffer directly to socket tx buffer blkpoll W@ ?DUP IF CALL THEN \ callback hook used by applications ( src cnt ) IX - SWAP L> + SWAP ( xaddr cnt ) \ update source parameters block by block DUP 0= \ until the source buffer is exhausted (cnt=0) sCLOSED? OR \ or if closed UNTIL 2DROP ; \ : FILE@ FSECT@ 8<< 2* ; --- Send the currently open file in block mode pub SENDFILE ( offset -- ) FSIZE@ OVER - BLKSEND ; \ LANLED blink variables byte ledcnt byte ledon ( Console diagnostic message handler ) byte msgs pub MSGS ( on/off -- ) msgs C! ; long msgstk pri message setting with 0 being the highest uemit @ msgstk ! msgs C@ <= IF CON ELSE NULLOUT THEN REVERSE .DT PRINT" #" SKT@ DUP PRINT SPACE 3 * skt$ + 3 CTYPE SPACE ; pri MSG> PLAIN CR msgstk @ uemit ! ; pri FlushSkt @WORD 1- 28 ERASE ; --- erase any garbage that has already been accumulated { HELP LANSKT ( -- ) Set console's socket backup to the current one - allows console processing of server commands } pub LANSKT SKT@ socket 1+ C! LAN ; { HELP UpdateTXWR Due to limitations of WIZnet read/write register access a copy is maintained and updated when possible } --- TXWRITE is now readable - buffer it pri UpdateTXWR TXWRITE LW@ @txwr W! ; TIMER contd pri KEEPALIVE #300000 contd TIMEOUT ; --- ms 300 seconds = 5 MINS byte disreq --- background timer cog can only request a disconnect pri DISCREQ disreq C~~ ; --- timeout sets disreq flag which is handled by main loop pub CONNECTED? ( -- flg ) sCONNECTED? --- Has CONNECT interrupt been set? DUP IF --- and save result OFF ECHO --- Setup Tachyon to handle command/response mode UpdateTXWR ( 1 ) CON SKT@ .SOCKET --- let console know what is happening BEGIN BEGIN KEY 0= UNTIL 3 ms KEY 0= UNTIL --- discard any console input as well LAN KEEPALIVE ON LANLED FlushSkt --- flush out anything already sitting there ' DISCREQ contd ALARM THEN ; { HELP BYE Disconnect socket (which may progress through DISCON WAIT) and flip the shell back to the console Report the socket status } pub BYE sDISCON CON SKT@ .SOCKET LAN ; pri DISC? ( -- flg ) disreq C@ sESTAB? AND IF BYE disreq C~ 0 contd ALARM THEN --- process disconnect req if active sCLOSED? sCLOSING? OR --- or if it's closed OR closing or $1C? sSTAT LC@ $1C = OR --- CLOSE WAIT - check this out - gets stuck on this ( #2 22:09:58 TCP 80 39416 EE08.EE08. 83. 83. . 00 1C closed wait 150.070XXXX ) sDISCON? OR DUP --- disconnect interrupt? OR closed - ok IF ( 1 ) sCLOSE sOPEN sLISTEN OFF QUIET OFF LANLED FlushSkt CON SKT@ .SOCKET THEN ; pri CONNECT ( 1 ) ; byte constat --- relay connection status to application { TELNET IACs pri /DO #253 pri IAC ( cmd -- ) #255 EMIT EMIT ; pri /SB #250 IAC ; pri /SE #240 IAC ; pri /WILL #251 IAC ; pri /WONT #252 IAC ; pri /DONT #254 IAC ; pri /NAWS #31 EMIT ; pri /LINEMODE #34 EMIT ; pri /ECHO 1 EMIT ; } pri ?TELNET TELNET SOCKET --- Use the TELNET socket CONNECTED? --- New connection? IF $54 constat C! --- indicate connection status active as Telnet 1 flags 1+ SET --- be interactive but not reset etc with certain controls ledcnt C~ CON CR LAN autosend C~ --- let 1/128 timeout handle characters or blocks " TELNET.INI" FOPEN$ IF FILEIN THEN --- execute IAC script to setup remote telnet client WAITSEND " WELCOME.TEL" FOPEN$ IF (cat) ELSE PRINT" WELCOME TO THE TACHYON WIZNET TELNET SESSION!" CR --- default Welcome banner THEN FlushSkt --- Reset rx buffer and receive LANSKT --- redirect console to this LAN socket OFF QUIET OFF ECHO KEEPALIVE THEN DISC? IF --- Process disconnection ( 0 ) $74 constat C! CON 1 flags 1+ CLR THEN ; IFDEF +FTP pub RESOLVE ( namestr -- ip ) HTTP SOCKET ; { HTTP/1.0 302 Found Cache-Control: private Content-Type: text/html; charset=UTF-8 Location: http://www.google.com.au/?gfe_rd=cr&ei=UH_EVO24O63u8wfd74GYAQ Content-Length: 262 Date: Sun, 25 Jan 2015 05:29:52 GMT Server: GFE/2.0 Alternate-Protocol: 80:quic,p=0.02 302 Moved

302 Moved

The document has moved here. } pub GETTIME HTTP SOCKET " google.com" RESOLVE HTTP SOCKET $0C L! --- contact google.com and set dest IP LAN PRINT" GET /" CR --- issue GET request --- Date: Sun, 25 Jan 2015 05:29:52 GMT ; \ Print the byte as a decimal number pri .BYTEDEC ( byte -- ) >B 10 PRINTNUM ; \ pri .IPD ( long -- ) DUP 24 SHR .BYTEDEC COMMA DUP 16 SHR .BYTEDEC COMMA DUP 8 SHR .BYTEDEC COMMA .BYTEDEC ; pri COMMA ',' EMIT ; pri .IPD 4 FOR DUP 24 >> 10 PRINTNUM 8<< DUP IF COMMA THEN NEXT DROP ; \ " user" 32 STRING user$ \ " pass" 16 STRING pass$ 32 bytes user$ 16 bytes pass$ pri GETFNAME GETWORD DUP C@ $2F = IF 1+ THEN --- adjust name if / is used DUP LEN$ 1- OVER + C@ $2E = IF 0 OVER DUP LEN$ 1- + C! THEN --- remove final period ; pri ECHOREQ CON CR BEGIN LANKEY DUP EMIT 0= UNTIL --- Just echo the request to the console for now ; { HELP USER FTP COMMAND Syntax: USER username Send this command to begin the login process. username should be a valid username on the system, or "anonymous" to initiate an anonymous login. } pre USER ON LANLED GETWORD user$ $! PRINT" 331 User admin OK. Password required" CR ; pre PASS ON LANLED GETWORD pass$ $! PRINT" 230 OK. Current restricted directory is /" CR ; long type { HELP TYPE FTP COMMAND Syntax: TYPE type-character [second-type-character] Sets the type of file to be transferred. type-character can be any of: A - ASCII text E - EBCDIC text I - image (binary data) L - local format For A and E, the second-type-character specifies how the text should be interpreted. It can be: N - Non-print (not destined for printing). This is the default if second-type-character is omitted. T - Telnet format control (, , etc.) C - ASA Carriage Control For L, the second-type-character specifies the number of bits per byte on the local system, and may not be omitted. } pre TYPE ON LANLED GETWORD type 4 CMOVE LAN PRINT" 200 TYPE is now " type C@ EMIT CR ; word dataport { HELP PORT FTP COMMAND Syntax: PORT a1,a2,a3,a4,p1,p2 Specifies the host and port to which the server should connect for the next file transfer. This is interpreted as IP address a1.a2.a3.a4, port p1*256+p2. } pre PORT \ accept port number ON LANLED GETWORD NUMBER dataport W! LAN PRINT" 200 Port is now " dataport W@ .DEC CR ; \ 227 Entering Passive Mode (192,168,16,106,248,252) { HELP PASV FTP COMMAND Syntax: PASV Tells the server to enter "passive mode". In passive mode, the server will wait for the client to establish a connection with it rather than attempting to connect to a client-specified port. The server will respond with the address of the port it is listening on, with a message like: 227 Entering Passive Mode (a1,a2,a3,a4,p1,p2) where a1.a2.a3.a4 is the IP address and p1*256+p2 is the port number. } pre PASV ON LANLED --- max min dataport 50000 40000 GETRND dataport W! \ pick a random port in the specified range FTPDAT SOCKET sCLOSE \ Prep the data port socket TCP dataport W@ SetPORT sOPEN sLISTEN \ Set the port and open listen for connection ( 1 ) \ respond that all is accepted FTP SOCKET LAN \ switch back to FTP socket PRINT" 227 Entering Passive Mode with port " \ dataport W@ .DEC \ Response with msg and port PRINT" (" @sip E@ .IPD COMMA dataport 1+ C@ .BYTEDEC COMMA dataport C@ .BYTEDEC PRINT" )" CR ; { HELP SYST FTP COMMAND Syntax: SYST Returns a word identifying the system, the word "Type:", and the default transfer type (as would be set by the TYPE command). For example: UNIX Type: L8 } pre SYST ON LANLED PRINT" 215 Unix Type: L8" CR ; { HELP FEAT FTP COMMAND Where a server-FTP process does not support the FEAT command, it will respond to the FEAT command with a 500 or 502 reply. This is simply the normal "unrecognized command" reply that any unknown command would elicit. Errors in the command syntax, such as giving parameters, will result in a 501 reply. Server-FTP processes that recognize the FEAT command, but implement no extended features, and therefore have nothing to report, SHOULD respond with the "no-features" 211 reply. However, as this case is practically indistinguishable from a server-FTP that does not recognize the FEAT command, a 500 or 502 reply MAY also be used. The "no-features" reply MUST NOT use the multi-line response format, exactly one response line is required and permitted. Replies to the FEAT command MUST comply with the following syntax. Text on the first line of the reply is free form, and not interpreted, and has no practical use, as this text is not expected to be revealed to end users. The syntax of other reply lines is precisely defined, and if present, MUST be exactly as specified. feat-response = error-response / no-features / feature-listing no-features = "211" SP *TCHAR CRLF feature-listing = "211-" *TCHAR CRLF 1*( SP feature CRLF ) "211 End" CRLF feature = feature-label [ SP feature-parms ] feature-label = 1*VCHAR feature-parms = 1*TCHAR Note that each feature line in the feature-listing begins with a single space. That space is not optional, nor does it indicate general white space. This space guarantees that the feature line can } pre FEAT ON LANLED PRINT" 211 no Features supported" CR { PRINT" 211-no Features supported" CR PRINT" yet to be implemented" CR PRINT" 211 End" CR } ; { HELP MDTM FTP COMMAND The server-PI will respond to the MDTM command with a 213 reply giving the last modification time of the file whose pathname was supplied, or a 550 reply if the file does not exist, the modification time is unavailable, or some other error has occurred. mdtm-response = "213" SP time-val CRLF / error-response Example response: 213 19980615100045.014 } pre MDTM ON LANLED GETFNAME FOPEN$ DROP autosend C~~ PRINT" 550 Modification time not available" CR ; { HELP CDUP FTP COMMAND Syntax: CDUP Makes the parent of the current directory be the current directory. } pre CDUP ON LANLED PRINT" 250 Directory successfully changed" CR ; \ " FILENAME.TXT " 0 STRING cwd$ : cwd$ " FILENAME.TXT " ; { HELP CWD Syntax: CWD remote-directory Makes the given directory be the current directory on the remote host } pre CWD ( ) ON LANLED GETWORD DUP cwd$ $! DUP " /" $= SWAP LEN$ 0= OR IF PRINT" 250 okay" ELSE PRINT" 550 Not a directory" THEN CR ; { HELP PWD Syntax: PWD Returns the name of the current directory on the remote host. } pre PWD ON LANLED PRINT" 257 \"/\" is your current location" CR ; pub ?DISC #300 ms BYE ; { HELP LIST FTP COMMAND Syntax: LIST [remote-filespec] If remote-filespec refers to a file, sends information about that file. If remote-filespec refers to a directory, sends information about each file in that directory. remote-filespec defaults to the current directory. This command must be preceded by a PORT or PASV command. } pre LIST \ \\\ delim 1+ C@ $20 = IF GETWORD DROP THEN --- ignore a remote-filespec uemit W@ --- allow this to be dumped to the console in interactive mode IF KEEPALIVE ON LANLED LANCON PRINT" 150 Here comes the directory listing" CR LANSEND ( 1 ) FTPDAT SOCKET CONNECT autosend C~ LAN .LIST --- Send off the directory listing in compatible format LANSEND WAITSEND #50 ms FTPDAT SOCKET BYE autosend C~~ FTP SOCKET LANCON PRINT" 226 Directory send OK" CR LANSEND ( 1 ) ?DISC ELSE CR .LIST THEN ; { This is how most UNIX, Novell, and MacOS ftp servers send their time Jul 06 12:57 or Jul 6 1999 -rwxrwxrwx 1 502 500 674 Sep 4 2014 HELP.TXT -rwxrwxrwx 1 502 500 65536 Sep 4 2014 FIRMWARE.ROM } { Feature list from NAS FTP 211-Extensions supported: EPRT IDLE MDTM SIZE REST STREAM MLST type*;size*;sizd*;modify*;UNIX.mode*;UNIX.uid*;UNIX.gid*;unique*; MLSD TVFS ESTP PASV EPSV SPSV ESTA AUTH TLS PBSZ PROT UTF8 211 End. } { HELP SIZE FTP COMMAND Syntax: SIZE remote-filename Returns the size of the remote file as a decimal number. } pre SIZE ON LANLED GETFNAME FOPEN$ ( 1 ) LANCON IF PRINT" 213 " FSIZE@ #10 PRINTNUM ELSE PRINT" 550 Could not get file size." THEN CR LANSEND ; { 0000_C800: 55 53 45 52 20 61 6E 6F 6E 79 6D 6F 75 73 0D 0A USER anonymous.. 0000_C810: 50 41 53 53 20 63 68 72 6F 6D 65 40 65 78 61 6D PASS chrome@exam 0000_C820: 70 6C 65 2E 63 6F 6D 0D 0A 53 59 53 54 0D 0A 50 ple.com..SYST..P 0000_C830: 57 44 0D 0A 54 59 50 45 20 49 0D 0A 50 41 53 56 WD..TYPE I..PASV 0000_C840: 0D 0A 53 49 5A 45 20 2F 0D 0A 50 41 53 56 0D 0A ..SIZE /..PASV.. 0000_C850: 43 57 44 20 2F 0D 0A 4C 49 53 54 20 2D 6C 0D 0A CWD /..LIST -l.. 550 Could not get the file size } --- send accepted or rejected message to FTP client pri FTPMSG ( flg -- ) FTP SOCKET LANCON IF ON LANLED PRINT" 150 Accepted data connection for " FILE$ PRINT$ CR LANSEND FTPDAT SOCKET CONNECT LAN ELSE PRINT" 550 File not available" CR LANSEND THEN ; --- FTP rename file request --- \ " FILENAME.EXT" 0 STRING RNFR$ \ place for source string for rename (PBJ: 0 STRING or #12 > req for null term.) : RNFR$ " FILENAME.TXT " ; { HELP RNFR FTP COMMAND Syntax: RNFR from-filename Used when renaming a file. Use this command to specify the file to be renamed; follow it with an RNTO command to specify the new name for the file. } pre RNFR GETFNAME RNFR$ $! FTP SOCKET LANCON PRINT" 350 Waiting for RNTO" CR LANSEND ; { HELP RNTO FTP COMMAND Syntax: RNTO to-filename Used when renaming a file. After sending an RNFR command to specify the file to rename, send this command to specify the new name for the file. } pre RNTO RNFR$ FOPEN$ DROP GETFNAME RENAME$ FTP SOCKET LANCON PRINT" 250 Rename done" CR LANSEND ; { Command: RETR PREVIOUS.ROM Response: 150 Accepted data connection for PREVIOUS.ROM Response: 226 File successfully transferred Status: File transfer successful, transferred 65,536 bytes in 1 second } --- FTP Retrieve a file i.e. RETR /LOG0001.TXT --- { HELP RETR FTP COMMAND Syntax: RETR remote-filename Begins transmission of a file from the remote host. Must be preceded by either a PORT command or a PASV command to indicate where the server should send data. } pre RETR KEEPALIVE GETFNAME FOPEN$ --- get the file name and try to open it 0 SWAP pri (RETR) ( position flg/addr -- ) DUP FTPMSG IF ( position ) FILE$ 3 RIGHT$ " LOG" $= IF --- If it's a log file then just send up to EOF marker DROP 0 0 APPEND 16 MAX \ IF fwrite @ OVER - 16 MAX ELSE FSIZE@ THEN BLKSEND --- Just send all the text up to the EOF or at least 16 ELSE --- else send the whole file SENDFILE THEN #100 ms ?SEND BYE --- close the data connection FTP SOCKET LANCON PRINT" 226 File successfully transferred" CR LANSEND --- Announce successful transfer ELSE DROP THEN FTP SOCKET ?DISC ; { HELP STOR FTP COMMAND Syntax: STOR remote-filename Begins transmission of a file to the remote site. Must be preceded by either a PORT command or a PASV command so the server knows where to accept data from. Usage Command: STOR PREVIOUS.ROM Response: 150 Accepted data connection for PREVIOUS.ROM Response: 250 File rcvd PREVIOUS.ROM Status: File transfer successful, transferred 65,536 bytes in 5 seconds } pre STOR KEEPALIVE GETFNAME --- get file name to store FMAKEOPEN$ RW --- try to open it for overwrite DUP FTPMSG --- send appropriate FTP message if accepted or not, connect to FTPDAT if accepted ?SEND IF ( 1 ) FTPDAT SOCKET BEGIN fwrite @ LREADSKT ( dst --- ) vwrite @ fwrite ! --- update file write index DISC? UNTIL FTP SOCKET LANCON PRINT" 250 File rcvd " FILE$ PRINT$ CR LANSEND FSTAMP ( 1 ) THEN FTPDAT SOCKET ?DISC FTP SOCKET ?DISC ; { HELP REST FTP COMMAND Syntax: REST position Sets the point at which a file transfer should start; useful for resuming interrupted transfers. For nonstructured files, this is simply a decimal number. This command must immediately precede a data transfer command (RETR or STOR only); i.e. it must come after any PORT or PASV command. } pre REST ( ) GETWORD NUMBER --- read the offset specified (RETR) --- retrieve as usual from this offset ; \ $10A EMIT .FREE $10A EMIT ( *** FTP SERVER - relies on the Forth console to interpret FTP commands directly *** ) pri ?FTP FTP SOCKET CONNECTED? --- examine interrupt register for a new connection etc IF $46 constat C! CON CR ON QUIET autosend C~~ LANCON PRINT" 220 WELCOME TO THE TACHYON WIZNET FTP SESSION!" CR --- Welcome banner KEEPALIVE --- Give FTP a maximum 5 min session LANSKT --- makes sure the console uses this connection and socket THEN DISC? IF $66 constat C! CON THEN ; ( HTTP COMMANDS ) --- some WIP here while I sort out my webpage files and content formatting etc \ Sample content header - just for testing pri CONTENT ( str -- ) 1 UPPER --- otherwise convert requested file name to uppercase THEN FOPEN$ NOT IF " HTTP404.HTM" FOPEN$ DROP THEN --- on file not found - use default 404 file LAN --- Direct all output to the selected socket ?CONTENT --- Handle content headers 1 " FILE$ PRINT$ MSG> --- echo name of actual file served UpdateTXWR @txwr W@ TXREAD LW! FILE$ 3 RIGHT$ DUP " TXT" $= IF DROP GETTXT ?SEND EXIT THEN --- plain text file ( only uppercase ?? or is >upper used somewhere?) " HTX" $= IF GETHTX ?SEND EXIT THEN --- we have a html template file HTX with embedded FORTH 0 FSIZE@ BLKSEND --- or just send the whole file ?SEND ; { HELP HEAD HTTP COMMAND The HEAD method is identical to GET except that the server MUST NOT return a message-body in the response. The metainformation contained in the HTTP headers in response to a HEAD request SHOULD be identical to the information sent in response to a GET request. This method can be used for obtaining metainformation about the entity implied by the request without transferring the entity-body itself. This method is often used for testing hypertext links for validity, accessibility, and recent modification. The response to a HEAD request MAY be cacheable in the sense that the information contained in the response MAY be used to update a previously cached entity from that resource. If the new field values indicate that the cached entity differs from the current entity (as would be indicated by a change in Content-Length, Content-MD5, ETag or Last-Modified), then the cache MUST treat the cache entry as stale. } pre HEAD --- just repond back with the same head ECHOREQ ; pre GET ( -- \ Open up the file name and send it ) --- /index.htm HTTP/1.1 KEEPALIVE LAN GETWORD DUP LEN$ getsz => IF DROP " GET$ to long" THEN GET$ COPY$ --- get the name and store in GET$ \ GETWORD 1 --- Let me know about a request ECHOREQ GETPAGE ; 1 == #hskts --- select from 1 to 4 sockets for HTTP processing { HELP ?HTTP Service the HTTP server socket } pri ?HTTP HTTP #hskts 1 DOFOR I SOCKET CONNECTED? IF $48 constat C! ON QUIET --- Disable interactive mode prompts KEEPALIVE LANSKT --- Let the same socket talk to the foreground Forth console when it switches back THEN DISC? IF $68 constat C! CON THEN LOOP ; } \ ----------------------------------------------------------------------------------------------------------- \ word lk \ spare ctrls: A F G K N O R T Y pri ~k C~ 8 KEY! ; pri ?CTRLS lastkey C@ lk W@ <> IF lastkey DUP C@ DUP lk W! SWITCH ^A =[ ~k CON DISCARD OFF QUIET PRINT" ENQ " PLAIN CONSOLE ] ^F =[ ~k [CON DISCARD ifconfig CON] ] --- kill background key poll (servers) ^O =[ ~k keypoll W~ OFF QUIET CON ] ^Y =[ ~k [CON DISCARD .SOCKETS CON] ] ^~ =[ ~k CON DISCARD 8 0 SWAP 1 DOFOR I SOCKET BYE LOOP ] ^\ =[ ~k CON OFF QUIET DEBUG ] DROP SWITCH@ IF CON OFF QUIET PLAIN THEN THEN ; pri ?LED --- the LED should be blinking very briefly when it's idle but alive 1 ledcnt C+! ledcnt C@ ledon C@ < LANLED --- reflect current connection status as a long or short blink constat C@ $61 < IF constat C@ ELSE 1 THEN ledon C! ; byte fsave byte netflgs --- 1 inhibit console shortcuts ( Main server loop - checks and services sockets - 1.3ms when idle ) pub ?EASYNET ?LED SKT@ socket 1+ C! --- swap current socket between foreground and background fsel C@ fsave C! 3 FILE --- use foreground file ?TELNET --- Poll the TELNET server ?SENDPOLL IFDEF +FTP ?FTP --- Poll the FTP server ?HTTP --- Poll the WEB server } \ \\\ 5 SOCKET SKT@ 5 = IF CONNECTED? IF REBOOT THEN THEN --- 911 reset ?SDCARD TRUE 8 0 SWAP 1 DOFOR I SOCKET sCLOSED? AND LOOP IF CON THEN --- force console back to serial if not busy socket 1+ C@ SOCKET --- restore foreground socket fsave C@ FILE --- restore foreground file DEPTH 8 > IF !SP THEN --- clean up abnormal stack \ 1 netflgs SET? ?EXIT --- skip controls if flag is set ; pub RESTART CON PLAIN ifconfig CR CR REBOOT ; pub !EASYNET !WIZ #150 ms --- Setup WIZnet chip #5000 @RTR LW! 16 @RCR LC! --- setup retry counters CR PRINT" *** Tachyon Forth EASYNET Network Servers and EASYFILE File Server *** " CR CR 4 ledon C! --- just setup an LED blink time ON RDYLED --- Now init the IP addresses (stored in high 64K EEPROM) TELNET SOCKET sCLOSE TCP #10001 PORT! sOPEN sLISTEN --- Setup TELNET but on port 10001 IFDEF +FTP " anonymous" user$ $! \ " password" pass$ $! #20 dataport W! \ Default FTP data port \ FTP SOCKET sCLOSE TCP #21 PORT! sOPEN sLISTEN --- Setup FTP HTTP #hskts 1 DOFOR I SOCKET sCLOSE TCP #80 PORT! sOPEN sLISTEN LOOP } ; pub EASYNET \ BOOT --- 5 SOCKET SKT@ 5 = IF TCP #911 PORT! sOPEN sLISTEN THEN --- if we have more than 4 sockets then use one for 911 reboot !EASYNET 1 second PRINT" ... ready! " CR ifconfig --- report WIZnet status constat C~~ ' ?EASYNET +POLL --- Poll the server in the background ' ?CTRLS +POLL --- process console shortcuts CR PRINT" * WEB, FTP, and TELNET servers running * " \ MOUNT CR ; END ' EASYNET +INIT ?BACKUP --- uncomment this next line to have EASYNET run at boot \ ' EASYNET +INIT