ip-interface gestalt; remove ttl from user-accessible fields
This commit is contained in:
parent
630d0e29bd
commit
ed6f535266
55
ip.rkt
55
ip.rkt
|
@ -1,6 +1,9 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
(provide ;; (struct-out ip-packet)
|
(provide (struct-out ip-packet)
|
||||||
|
(struct-out ip-interface)
|
||||||
|
ip-address->hostname
|
||||||
|
broadcast-ip-address
|
||||||
spawn-ip-driver)
|
spawn-ip-driver)
|
||||||
|
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
|
@ -15,7 +18,8 @@
|
||||||
(require "ethernet.rkt")
|
(require "ethernet.rkt")
|
||||||
(require "arp.rkt")
|
(require "arp.rkt")
|
||||||
|
|
||||||
(struct ip-packet (source destination ttl protocol options body) #:prefab) ;; TODO: more fields
|
(struct ip-packet (source destination protocol options body) #:prefab) ;; TODO: more fields
|
||||||
|
(struct ip-interface (address ethernet) #:prefab)
|
||||||
|
|
||||||
(define IPv4-ethertype #x0800)
|
(define IPv4-ethertype #x0800)
|
||||||
|
|
||||||
|
@ -28,6 +32,10 @@
|
||||||
|
|
||||||
(define default-ttl 64)
|
(define default-ttl 64)
|
||||||
|
|
||||||
|
(define (ip-address->hostname bs)
|
||||||
|
(bit-string-case bs
|
||||||
|
([ a b c d ] (format "~a.~a.~a.~a" a b c d))))
|
||||||
|
|
||||||
(define broadcast-ip-address (bytes 255 255 255 255))
|
(define broadcast-ip-address (bytes 255 255 255 255))
|
||||||
|
|
||||||
(struct state (hwaddr) #:transparent)
|
(struct state (hwaddr) #:transparent)
|
||||||
|
@ -57,13 +65,12 @@
|
||||||
(or (equal? destination-ip my-address)
|
(or (equal? destination-ip my-address)
|
||||||
(equal? destination-ip broadcast-ip-address))
|
(equal? destination-ip broadcast-ip-address))
|
||||||
(>= header-length 5)
|
(>= header-length 5)
|
||||||
(>= (bit-string-length body) (* header-length 4)))
|
(>= (bit-string-byte-count body) (* header-length 4)))
|
||||||
(bit-string-case rest
|
(bit-string-case rest
|
||||||
([ (opts :: binary bytes options-length)
|
([ (opts :: binary bytes options-length)
|
||||||
(data :: binary) ]
|
(data :: binary) ]
|
||||||
(transition s (send (ip-packet (bit-string->bytes source-ip)
|
(transition s (send (ip-packet (bit-string->bytes source-ip)
|
||||||
(bit-string->bytes destination-ip)
|
(bit-string->bytes destination-ip)
|
||||||
ttl
|
|
||||||
protocol
|
protocol
|
||||||
(bit-string->bytes opts)
|
(bit-string->bytes opts)
|
||||||
(bit-string->bytes data))))))
|
(bit-string->bytes data))))))
|
||||||
|
@ -73,30 +80,42 @@
|
||||||
(define (analyze-gestalt g s)
|
(define (analyze-gestalt g s)
|
||||||
(define hwaddr (gestalt->hwaddr g interface-name))
|
(define hwaddr (gestalt->hwaddr g interface-name))
|
||||||
(define new-s (struct-copy state s [hwaddr hwaddr]))
|
(define new-s (struct-copy state s [hwaddr hwaddr]))
|
||||||
(transition new-s '()))
|
(transition new-s (routing-update (compute-gestalt new-s))))
|
||||||
|
|
||||||
|
(define (compute-gestalt s)
|
||||||
|
(gestalt-union
|
||||||
|
(pub (arp-assertion IPv4-ethertype my-address))
|
||||||
|
(sub (ethernet-packet-pattern interface-name #t IPv4-ethertype))
|
||||||
|
(sub (ethernet-packet-pattern interface-name #t IPv4-ethertype) #:level 1)
|
||||||
|
(pub (ethernet-packet-pattern interface-name #f IPv4-ethertype))
|
||||||
|
(sub (ip-packet my-address ? ? ? ?))
|
||||||
|
(pub (ip-packet ? my-address ? ? ?))
|
||||||
|
(if (state-hwaddr s)
|
||||||
|
(pub (ip-interface my-address (ethernet-interface interface-name (state-hwaddr s))))
|
||||||
|
(gestalt-empty))))
|
||||||
|
|
||||||
(list
|
(list
|
||||||
(spawn-icmp-driver my-address)
|
(spawn-icmp-driver my-address)
|
||||||
|
(let ((state0 (state #f)))
|
||||||
(spawn (lambda (e s)
|
(spawn (lambda (e s)
|
||||||
(match e
|
(match e
|
||||||
[(routing-update g)
|
[(routing-update g)
|
||||||
(analyze-gestalt g s)]
|
(analyze-gestalt g s)]
|
||||||
[(message (ethernet-packet _ _ _ _ _ body) _ _)
|
[(message (ethernet-packet _ _ _ _ _ body) _ _)
|
||||||
(analyze-incoming-packet body s)]
|
(analyze-incoming-packet body s)]
|
||||||
[(message (ip-packet _ peer-address ttl protocol options body) _ _)
|
[(message (ip-packet _ peer-address protocol options body) _ _)
|
||||||
(define header-length ;; TODO: ensure options is a multiple of 4 bytes
|
(define header-length ;; TODO: ensure options is a multiple of 4 bytes
|
||||||
(+ IP-MINIMUM-HEADER-LENGTH (quotient (bit-string-length options) 32)))
|
(+ IP-MINIMUM-HEADER-LENGTH (quotient (bit-string-byte-count options) 4)))
|
||||||
(define header0
|
(define header0
|
||||||
(bit-string (IP-VERSION :: bits 4)
|
(bit-string (IP-VERSION :: bits 4)
|
||||||
(header-length :: bits 4)
|
(header-length :: bits 4)
|
||||||
0 ;; TODO: service type
|
0 ;; TODO: service type
|
||||||
((+ (* header-length 4)
|
((+ (* header-length 4) (bit-string-byte-count body))
|
||||||
(/ (bit-string-length body) 8))
|
|
||||||
:: bits 16)
|
:: bits 16)
|
||||||
(0 :: bits 16) ;; TODO: identifier
|
(0 :: bits 16) ;; TODO: identifier
|
||||||
(0 :: bits 3) ;; TODO: flags
|
(0 :: bits 3) ;; TODO: flags
|
||||||
(0 :: bits 13) ;; TODO: fragments
|
(0 :: bits 13) ;; TODO: fragments
|
||||||
ttl
|
default-ttl
|
||||||
protocol
|
protocol
|
||||||
(0 :: bits 16)
|
(0 :: bits 16)
|
||||||
(my-address :: binary bits 32)
|
(my-address :: binary bits 32)
|
||||||
|
@ -111,18 +130,13 @@
|
||||||
(bit-string ((ip-checksum 10 header0) :: binary)
|
(bit-string ((ip-checksum 10 header0) :: binary)
|
||||||
(body :: binary)))))]
|
(body :: binary)))))]
|
||||||
[_ #f]))
|
[_ #f]))
|
||||||
(state #f)
|
state0
|
||||||
(gestalt-union
|
(compute-gestalt state0)))))
|
||||||
(pub (arp-assertion IPv4-ethertype my-address))
|
|
||||||
(sub (ethernet-packet-pattern interface-name #t IPv4-ethertype))
|
|
||||||
(sub (ethernet-packet-pattern interface-name #t IPv4-ethertype) #:level 1)
|
|
||||||
(pub (ethernet-packet-pattern interface-name #f IPv4-ethertype))
|
|
||||||
(sub (ip-packet my-address ? ? ? ? ?))))))
|
|
||||||
|
|
||||||
(define (spawn-icmp-driver my-address)
|
(define (spawn-icmp-driver my-address)
|
||||||
(spawn (lambda (e s)
|
(spawn (lambda (e s)
|
||||||
(match e
|
(match e
|
||||||
[(message (ip-packet peer-address _ _ _ _ body) _ _)
|
[(message (ip-packet peer-address _ _ _ body) _ _)
|
||||||
(bit-string-case body
|
(bit-string-case body
|
||||||
([ type code (checksum :: integer bytes 2) (rest :: binary) ] ;; TODO: check cksum
|
([ type code (checksum :: integer bytes 2) (rest :: binary) ] ;; TODO: check cksum
|
||||||
(case type
|
(case type
|
||||||
|
@ -136,7 +150,6 @@
|
||||||
(rest :: binary)))
|
(rest :: binary)))
|
||||||
(transition s (send (ip-packet my-address
|
(transition s (send (ip-packet my-address
|
||||||
peer-address
|
peer-address
|
||||||
default-ttl
|
|
||||||
PROTOCOL-ICMP
|
PROTOCOL-ICMP
|
||||||
#""
|
#""
|
||||||
(ip-checksum 2 reply-data0))))]
|
(ip-checksum 2 reply-data0))))]
|
||||||
|
@ -152,5 +165,5 @@
|
||||||
(else #f))]
|
(else #f))]
|
||||||
[_ #f]))
|
[_ #f]))
|
||||||
(void)
|
(void)
|
||||||
(gestalt-union (pub (ip-packet my-address ? ? PROTOCOL-ICMP ? ?))
|
(gestalt-union (pub (ip-packet my-address ? PROTOCOL-ICMP ? ?))
|
||||||
(sub (ip-packet ? my-address ? PROTOCOL-ICMP ? ?)))))
|
(sub (ip-packet ? my-address PROTOCOL-ICMP ? ?)))))
|
||||||
|
|
Loading…
Reference in New Issue