[movitz-cvs] CVS update: movitz/losp/lib/net/ip4.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz/losp/lib/net
In directory common-lisp.net:/tmp/cvs-serv4673

Modified Files:
	ip4.lisp 
Log Message:
Wrote format-ip-header, format-udp-header, etc.

Date: Wed Nov 24 11:06:26 2004
Author: ffjeld

Index: movitz/losp/lib/net/ip4.lisp
diff -u movitz/losp/lib/net/ip4.lisp:1.8 movitz/losp/lib/net/ip4.lisp:1.9
--- movitz/losp/lib/net/ip4.lisp:1.8	Tue Nov 23 17:14:49 2004
+++ movitz/losp/lib/net/ip4.lisp	Wed Nov 24 11:06:25 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Apr 30 13:52:57 2003
 ;;;;                
-;;;; $Id: ip4.lisp,v 1.8 2004/11/23 16:14:49 ffjeld Exp $
+;;;; $Id: ip4.lisp,v 1.9 2004/11/24 10:06:25 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -26,6 +26,8 @@
 	   #:ip4-address
 	   #:ip4-test
 	   #:ip4-free
+	   #:format-ip4-header
+	   #:format-udp-header
 	   #:*ip4-nic*
 	   #:*ip4-ip*))
 
@@ -79,6 +81,37 @@
   (ldb (byte 4 0)
        (ip4-ref packet start +ip-header-version-header-length+ :unsigned-byte8)))
 
+(defun ip-header-source (packet &optional (start 14))
+  (subseq packet (+ start 12) (+ start 16)))
+
+(defun ip-header-destination (packet &optional (start 14))
+  (subseq packet (+ start 16) (+ start 20)))
+
+(defun format-ip4-header (packet &key (start 14) (payload 0)
+				      (id 0) (ttl 64) (checksum t)
+				      (protocol 0) (flags 0)
+				      (fragment-offset 0)
+				      source destination)
+  (setf (ip4-ref packet start 0 :unsigned-byte16) #x4500
+	(ip4-ref packet start 2 :unsigned-byte16) (+ payload 20)
+	(ip4-ref packet start 4 :unsigned-byte16) id
+	(ip4-ref packet start 6 :unsigned-byte16) (dpb flags (byte 3 13) fragment-offset)
+	(ip4-ref packet start 8 :unsigned-byte8) ttl
+	(ip4-ref packet start 9 :unsigned-byte8) protocol)
+  (when source
+    (replace packet source :start1 (+ start 12)))
+  (when destination
+    (replace packet destination :start1 (+ start 16)))
+  (cond
+   ((eq t checksum)
+    (setf (ip4-ref packet start 10 :unsigned-byte16) 0)
+    (setf (ip4-ref packet start 10 :unsigned-byte16)
+      (logxor #xffff
+	      (checksum-octets packet start (+ start 20)))))
+   ((integerp checksum)
+    (setf (ip4-ref packet start 10 :unsigned-byte16) checksum)))
+  packet)
+
 (defun checksum-ok (x)
   (= #xffff
      (+ (ldb (byte 16 0) x)
@@ -272,11 +305,51 @@
 (defun udp-dst-port (packet &optional (start 34))
   (ip4-ref packet start 2 :unsigned-byte16))
 
+(defun (setf udp-dst-port) (value packet &optional (start 34))
+  (setf (ip4-ref packet start 2 :unsigned-byte16)
+    value))
+
 (defun udp-length (packet &optional (start 34))
   (ip4-ref packet start 4 :unsigned-byte16))
 
+(defun (setf udp-length) (value packet &optional (start 34))
+  (setf (ip4-ref packet start 4 :unsigned-byte16)
+    value))
+
 (defun udp-checksum (packet &optional (start 34))
   (ip4-ref packet start 6 :unsigned-byte16))
+
+(defun (setf udp-checksum) (value packet &optional (start 34))
+  (setf (ip4-ref packet start 6 :unsigned-byte16)
+    value))
+
+(defun format-udp-header (packet &key (start 34)
+				      (source *ip4-ip*) (source-port 1024)
+				      destination (destination-port 0)
+				      (payload (- (length packet) start 8))
+				      (checksum t))
+  (let ((udp-length (+ payload 8)))
+    (format-ip4-header packet
+		       :source source
+		       :destination destination
+		       :payload udp-length
+		       :protocol +ip-protocol-udp+)
+    (setf (ip4-ref packet start 0 :unsigned-byte16) source-port
+	  (ip4-ref packet start 2 :unsigned-byte16) destination-port
+	  (ip4-ref packet start 4 :unsigned-byte16) udp-length)
+    (cond
+     ((integerp checksum)
+      (setf (ip4-ref packet start 6 :unsigned-byte16) checksum))
+     ((eq t checksum)
+      (setf (ip4-ref packet start 6 :unsigned-byte16) 0)
+      (setf (ip4-ref packet start 6 :unsigned-byte16)
+	(logxor #xffff
+		(add-u16-ones-complement (checksum-octets source)
+					 (checksum-octets destination)
+					 +ip-protocol-udp+ udp-length
+					 (checksum-octets packet start (+ start udp-length)))))))
+    packet))
+  
 
 (defmethod udp-input ((stack ip4-stack) packet ip-start udp-start)
   (warn "Got UDP packet of length ~D from ~@v/ip4:pprint-ip4/."