aboutsummaryrefslogtreecommitdiff
path: root/j1eforth/ipv4.4th
blob: 080686c1969dbeeca19e625991b9ceb0d59e72fe (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
(
	I feel that the Kernel is at it's best for now and that I can proceed
	to do some other things. Note that version 1 is just to make the whole
	thing work, later on I might look at optimisation where I might have to move
	some stuff around so that memory utilization and execution speed efficiency is
	achieved.So far the Kernel works without needing tweaks.

	Work in progress: Implementing simple ipv4 for the j1eforth model

	7 project targets:

	  1. Add multi-tasking support to the Kernel - 0%
	  2. Modify j1 sim to use pcap interface for network tx and rx - 0%
	  3. ARP  - 0%
	  4. ICMP - 0%
	  5. IP   - 0%
	  6. UDP  - 0%
	  7. TCP  - 0%

	Hopefully I will get time to do all this and also document the design of
	the j1eforth Kernel for those who are starting out with forth and also those
	who wish to tinker with the Kernel for fun.
)

hex

forth-wordlist >voc forth

vocabulary ipv4.1
only forth also ipv4.1

ipv4.1 definitions

variable active_struct

: field
   create over , +
  does>
   @ active_struct @ + ;

( ethernet frame )

0
  6 field eth_dest      ( 48 bit source address )
  6 field eth_src       ( 48 bit destination address )
  2 field eth_type      ( 16 bit type )
constant eth_frame%

( arp message )

0
  2 field arp_hw        ( 16 bit hw type )
  2 field arp_proto     ( 16 bit protocol )
  1 field arp_hlen      (  8 bit hw address length )
  1 field arp_plen      (  8 bit protocol address length )
  2 field arp_op        ( 16 bit operation )
  6 field arp_shw       ( 48 bit sender hw address )
  4 field arp_sp        ( 32 bit sender ipv4 address )
  6 field arp_thw       ( 48 bit target hw address )
  4 field arp_tp        ( 32 bit target ipv4 address )
constant arp_message%

( arp cache )

0
  4 field ac_ip         ( 32 bit protocol address )
  6 field ac_hw         ( 48 bit hw address )
constant arp_cache%

( ipv4 datagram header )

0
  1 field ip_vhl    (  4 bit version and 4 bit header length )
  1 field ip_tos        (  8 bit type of service )
  2 field ip_len        ( 16 bit length )
  2 field ip_id         ( 16 bit identification )
  2 field ip_frags      (  3 bit flags 13 bit fragment offset )
  1 field ip_ttl        (  8 bit time to live )
  1 field ip_proto      (  8 bit protocol number )
  2 field ip_checksum   ( 16 bit checksum )
  4 field ip_source     ( 32 bit source address )
  4 field ip_dest       ( 32 bit destination address )
constant ip_header%

( icmp header )

0
  1 field icmp_type     (  8 bits type )
  1 field icmp_code     (  8 bits code )
  2 field icmp_checksum ( 16 bits checksum )
constant icmp_header%

( udp datagram )

0
  2 field udp_source    ( 16 bit source port )
  2 field udp_dest      ( 16 bit destination port )
  2 field udp_len       ( 16 bit length )
  2 field udp_checksum  ( 16 bit checksum )
constant udp_datagram%

( tcp header )

0
  2 field tcp_source    ( 16 bit source port )
  2 field tcp_dest      ( 16 bit destination port )
  4 field tcp_seq       ( 32 bit sequence number )
  4 field tcp_ack       ( 32 bit acknowledgement )
  1 field tcp_offset    (  8 bit offset )
  2 field tcp_flags     ( 16 bit flags )
  1 field tcp_window    (  8 bit window size )
  2 field tcp_checksum  ( 16 bit checksum )
  2 field tcp_urgent    ( 16 bit urgent pointer )
constant tcp_header%

4000 constant eth_rx_buf

: htons ( n -- n )
  dup ff and 8 lshift swap ff00 and 8 rshift or ;

create ip_addr a8c0 , fe0b ,
create ip_netmask ffff , 00ff ,
create hw_addr bd00 , 333b , 7f05 ,

   8 constant eth_ip_type
 608 constant eth_arp_type
3580 constant eth_rarp_type

100 constant arp_request_type
200 constant arp_reply_type

0 constant icmp_echo_reply
8 constant icmp_echo

0 constant arp_action

: arp_lookup  0 to arp_action ;
: arp_update  1 to arp_action ;
: arp_insert  2 to arp_action ;
: arp_delete  3 to arp_action ;
: +arp_age    4 to arp_action ;

: (arp_lookup)  cr ." compare" . . ;
: (arp_update)  cr ." update"  . . ;
: (arp_insert)  cr ." insert" ;
: (arp_delete)  cr ." delete" ;
: (+arp_age)    cr ." age" ;

: arp_table ( u -- )
  create here over allot swap erase
   does>
   swap arp_cache% * +
   arp_action 0 to arp_action
   case
    0 of (arp_lookup)  endof
    1 of (arp_update)  endof
    2 of (arp_insert)  endof
    3 of (arp_delete)  endof
    4 of (+arp_age)    endof
    ." unknown cache option"
   endcase ;

arp_cache% 8 * arp_table arp_cache

: eth_rx f008 @ ;
: eth_tx f008 ! ;

: checksum ( address count -- checksum)
  over + 0 -rot 
  do
   i @ + i @ over u> if 1+ then
  -2 +loop
  dup 10 rshift swap ffff and +
  dup 10 rshift +
  ffff xor ;
: arp_in ( -- )
  eth_frame% active_struct +!
  arp_op @ arp_request_type = if
   100            arp_hw !
   eth_ip_type    arp_proto !
   6              arp_hlen c!
   4              arp_plen c!
   arp_reply_type arp_op !
   arp_shw        arp_thw 6 cmove
   hw_addr        arp_shw 6 cmove
   arp_sp         arp_tp  4 cmove
   ip_addr        arp_sp  4 cmove
   arp_thw
   eth_rx_buf active_struct !
   eth_dest 6 cmove
   hw_addr eth_src 6 cmove
   eth_arp_type eth_type !
   eth_tx
  else
   ( arp_update )
  then ;
: icmp_in
  ip_len @ htons
  ip_header% active_struct +!
  icmp_type c@ 8 = if
   0 icmp_type c!
   icmp_checksum @ fff7 = if
    9 icmp_checksum +!
   else 8 icmp_checksum +! then
  else
   cr ." weird icmp packet"
  then eth_tx ;
: udp_in cr ." got udp packet." ;
: tcp_in cr ." got tcp packet." ;
: ip_in ( -- )
  eth_frame% active_struct +!
  ip_vhl @ 45 = if
   ip_proto c@ case
     1 of
        ip_source dup ip_dest 4 cmove
        ip_addr swap 4 cmove
        icmp_in
	   endof
     6 of tcp_in endof
    17 of udp_in endof
	cr ." unknown ip protocol:"
   endcase
  else
   cr ." unsupported ip version detected"
  then ;
: process ( -- )
  eth_type @ case
   eth_arp_type of arp_in endof
   eth_ip_type of ip_in endof
   cr ." unknown ethernet protocol"
  endcase ;
: pcap_poll
  eth_rx_buf active_struct !
  active_struct @ 5dc erase
  eth_rx ;
: round
  pcap_poll 0 <> if
   process
  then ;
: main
  begin
   round
  again
;

( main )

forth definitions
ipv4.1 definitions