<commit_before>(defpackage #:system.networking
  (:use #:cl #:sys.int)
  (:nicknames #:sys.net)
  (:export register-nic
           ethernet-mac
           transmit-packet
           receive-packet
           arp-lookup
           copy-packet packet-length))

(in-package #:sys.net)

(defvar *cards* '())

(defun register-nic (nic)
  (push nic *cards*))

(defgeneric ethernet-mac (nic))

(defun reduce (function list)
  (cond ((null list) (funcall function))
        ((null (rest list)) (first list))
        (t (let ((x (funcall function (first list) (second list))))
             (dolist (i (cddr list) x)
               (setf x (funcall function x i)))))))

(defun packet-length (packet)
  (reduce '+ (mapcar 'length packet)))

(defun copy-packet (buffer packet &optional (buffer-start 0))
  (dolist (p packet)
    (dotimes (i (length p))
      (setf (aref buffer buffer-start) (aref p i))
      (incf buffer-start))))

(defun ub16ref/be (vector index)
  (logior (ash (aref vector index) 8)
	  (aref vector (1+ index))))
(defun (setf ub16ref/be) (value vector index)
  (setf (aref vector index) (ash value -8)
	(aref vector (1+ index)) (logand value #xFF))
  value)

(defun ub16ref/le (vector index)
  (logior (aref vector index)
	  (ash (aref vector (1+ index)) 8)))
(defun (setf ub16ref/le) (value vector index)
  (setf (aref vector index) (logand value #xFF)
	(aref vector (1+ index)) (ash value -8))
  value)

(defun ub32ref/be (vector index)
  (logior (ash (aref vector index) 24)
	  (ash (aref vector (+ index 1)) 16)
	  (ash (aref vector (+ index 2)) 8)
	  (aref vector (+ index 3))))
(defun (setf ub32ref/be) (value vector index)
  (setf (aref vector index) (ash value -24)
	(aref vector (+ index 1)) (logand (ash value -16) #xFF)
	(aref vector (+ index 2)) (logand (ash value -8) #xFF)
	(aref vector (+ index 3)) (logand value #xFF))
  value)

(defun ub32ref/le (vector index)
  (logior (aref vector index)
	  (ash (aref vector (+ index 1)) 8)
	  (ash (aref vector (+ index 2)) 16)
	  (ash (aref vector (+ index 3)) 24)))
(defun (setf ub32ref/le) (value vector index)
  (setf (aref vector index) (logand value #xFF)
	(aref vector (+ index 1)) (logand (ash value -8) #xFF)
	(aref vector (+ index 2)) (logand (ash value -16) #xFF)
	(aref vector (+ index 3)) (ash value -24))
  value)

(defconstant +ethertype-ipv4+ #x0800)
(defconstant +ethertype-arp+  #x0806)
(defconstant +ethertype-ipv6+ #x86DD)

(defconstant +arp-op-request+ 1)
(defconstant +arp-op-reply+ 2)

(defconstant +arp-hrd-ethernet+ 1)

(defconstant +ip-protocol-icmp+ 1)
(defconstant +ip-protocol-igmp+ 2)
(defconstant +ip-protocol-tcp+ 6)
(defconstant +ip-protocol-udp+ 17)

(defconstant +tcp4-flag-fin+ #b00000001)
(defconstant +tcp4-flag-syn+ #b00000010)
(defconstant +tcp4-flag-rst+ #b00000100)
(defconstant +tcp4-flag-psh+ #b00001000)
(defconstant +tcp4-flag-ack+ #b00010000)

(defconstant +icmp-echo-reply+ 0)
(defconstant +icmp-echo-request+ 8)
(defconstant +icmp-destination-unreachable+ 3)
(defconstant +icmp-time-exceeded+ 11)
(defconstant +icmp-parameter-problem+ 12)

;;; Destination unreachable codes.
(defconstant +icmp-code-net-unreachable+ 0)
(defconstant +icmp-code-host-unreachable+ 1)
(defconstant +icmp-code-protocol-unreachable+ 2)
(defconstant +icmp-code-port-unreachable+ 3)
(defconstant +icmp-code-fragmentation-needed+ 4)
(defconstant +icmp-code-source-route-failed+ 5)

;; Time exceeded codes.
(defconstant +icmp-code-ttl-exceeded+ 0)
(defconstant +icmp-code-fragment-timeout+ 1)

(defparameter *ethernet-broadcast* (make-array 6 :element-type '(unsigned-byte 8)
                                               :initial-element #xFF))

(defparameter *ipv4-interfaces* '())

(defun ifup (nic address)
  (setf (getf *ipv4-interfaces* nic) address))

(defun ifdown (nic)
  (setf (getf *ipv4-interfaces* nic) nil))

(defun ipv4-interface-address (nic &optional (errorp t))
  (or (getf *ipv4-interfaces* nic)
      (and errorp
           (error "No IPv4 address for interface ~S." nic))))

;;; The ARP table is a list of lists. Each list holds:
;;; (protocol-type protocol-address network-address age)
(defvar *arp-table* nil)

(defun arp-receive (interface packet)
  (let* ((htype (ub16ref/be packet 14))
	 (ptype (ub16ref/be packet 16))
	 (hlen (aref packet 18))
	 (plen (aref packet 19))
	 (oper (ub16ref/be packet 20))
	 (sha-start 22)
	 (spa-start (+ sha-start hlen))
	 (tha-start (+ spa-start plen))
	 (tpa-start (+ tha-start hlen))
	 (packet-end (+ tpa-start plen))
	 (merge-flag nil)
         (address (ipv4-interface-address interface nil)))
    ;; Ethernet hardware type and IPv4.
    (when (and (eql htype +arp-hrd-ethernet+) (eql hlen 6)
	       (eql ptype +ethertype-ipv4+) (eql plen 4))
      (let ((spa (ub32ref/be packet spa-start))
	    (tpa (ub32ref/be packet tpa-start)))
	;; If the pair <protocol type, sender protocol address> is
	;; already in my translation table, update the sender
	;; hardware address field of the entry with the new
	;; information in the packet and set Merge_flag to true.
	(dolist (e *arp-table*)
	  (when (and (eql (first e) ptype)
		     (eql (second e) spa))
	    (setf (third e) (subseq packet sha-start spa-start)
		  merge-flag t)
	    (return)))
	(when (and address (eql tpa address))
	  (unless merge-flag
	    (push (list ptype spa (subseq packet sha-start spa-start) 0) *arp-table*))
	  (when (eql oper +arp-op-request+)
	    ;; Copy source hardware address to dest MAC and target h/w address.
	    (dotimes (i 6)
	      (setf (aref packet i) (aref packet (+ sha-start i))
		    (aref packet (+ tha-start i)) (aref packet (+ sha-start i))))
	    ;; Copy source protocol address to target protocol address.
	    (dotimes (i plen)
	      (setf (aref packet (+ tpa-start i)) (aref packet (+ spa-start i))))
	    ;; Set source hardware address and source MAC to the interface's MAC.
	    (let ((mac (ethernet-mac interface)))
	      (dotimes (i 6)
		(setf (aref packet (+ 6 i)) (aref mac i)
		      (aref packet (+ sha-start i)) (aref mac i))))
	    (setf (ub32ref/be packet spa-start) address
		  (ub16ref/be packet 20) +arp-op-reply+)
	    (transmit-packet interface (list packet))))))))

(defun send-arp (interface ptype address)
  "Send an ARP packet out onto the wire."
  (unless (eql ptype +ethertype-ipv4+)
    (error "Unsupported protocol type ~S" ptype))
  (let ((packet (make-array 42 :element-type '(unsigned-byte 8)))
	(mac (ethernet-mac interface)))
    ;; Fill in various hardware address fields.
    (dotimes (i 6)
      ;; Ethernet destination.
      (setf (aref packet i) #xFF
	    ;; Ethernet source.
	    (aref packet (+ 6 i)) (aref mac i)
	    ;; ARP source hardware address.
	    (aref packet (+ 22 i)) (aref mac i)))
    ;; Set the source and target protocol addresses.
    (setf (ub32ref/be packet 28) (ipv4-interface-address interface)
	  (ub32ref/be packet 38) address
	  ;; Various other fields.
	  (ub16ref/be packet 12) +ethertype-arp+
	  (ub16ref/be packet 14) +arp-hrd-ethernet+
	  (ub16ref/be packet 16) +ethertype-ipv4+
	  (aref packet 18) 6
	  (aref packet 19) 4
	  (ub16ref/be packet 20) +arp-op-request+)
    (transmit-packet interface (list packet))))

(defun arp-lookup (interface ptype address)
  "Convert ADDRESS to an Ethernet address."
  ;; Scan the ARP table.
  (dolist (e *arp-table*)
    (when (and (eql (first e) ptype)
	       (eql (second e) address))
      (return-from arp-lookup (third e))))
  (dotimes (attempt 3)
    (send-arp interface ptype address)
    ;; FIXME: better timeout.
    (sys.int::process-wait-with-timeout "ARP Lookup" 200
			       (lambda ()
				 (dolist (e *arp-table* nil)
				   (when (and (eql (first e) ptype)
					      (eql (second e) address))
				     (return t)))))
    (dolist (e *arp-table*)
      (when (and (eql (first e) ptype)
		 (eql (second e) address))
	(return-from arp-lookup (third e))))))

(defstruct tcp-connection
  state
  local-port
  remote-port
  remote-ip
  s-next
  r-next
  window-size
  (max-seg-size 1000)
  rx-data)

(defvar *raw-packet-hooks* nil)
(defvar *tcp-connections* nil)
(defvar *allocated-tcp-ports* nil)
(defvar *server-alist* '())

(defun get-tcp-connection (remote-ip remote-port local-port)
  (dolist (connection *tcp-connections*)
    (when (and (eql (tcp-connection-remote-ip connection) remote-ip)
               (eql (tcp-connection-remote-port connection) remote-port)
               (eql (tcp-connection-local-port connection) local-port))
      (return connection))))

(defun %tcp4-receive (packet remote-ip start end)
  (let* ((remote-port (ub16ref/be packet start))
         (local-port (ub16ref/be packet (+ start 2)))
         (flags (aref packet (+ start 13)))
         (connection (get-tcp-connection remote-ip remote-port local-port)))
    (cond
      (connection
       (tcp4-receive connection packet start end))
      ((eql flags +tcp4-flag-syn+)
       (format t "Establishing TCP connection. l ~D  r ~D  from ~X.~%" local-port remote-port remote-ip)
       (let* ((seq (ub32ref/be packet (+ start 4)))
              (blah (random #x100000000))
              (connection (make-tcp-connection :state :syn-received
                                               :local-port local-port
                                               :remote-port remote-port
                                               :remote-ip remote-ip
                                               :s-next (logand #xFFFFFFFF (1+ blah))
                                               :r-next (logand #xFFFFFFFF (1+ seq))
                                               :window-size 8192)))
         (let ((server (assoc local-port *server-alist*)))
           (cond (server
                  (push connection *tcp-connections*)
                  (tcp4-send-packet connection blah (logand #xFFFFFFFF (1+ seq)) nil
                                    :ack-p t :syn-p t)
                  (funcall (second server) connection))
                 (t (tcp4-send-packet connection blah (logand #xFFFFFFFF (1+ seq)) nil
                                      :ack-p t :rst-p t))))))
      (t (unless (logtest flags +tcp4-flag-rst+)
           (let ((connection (make-tcp-connection :state :syn-received
                                                  :local-port local-port
                                                  :remote-port remote-port
                                                  :remote-ip remote-ip
                                                  :s-next 0
                                                  :r-next 0
                                                  :window-size 8192)))
             (tcp4-send-packet connection 0 0 nil
                               :ack-p nil :rst-p t)))))))

(defun %receive-packet (interface packet)
  (dolist (hook *raw-packet-hooks*)
    (funcall hook interface packet))
  (let ((ethertype (ub16ref/be packet 12)))
    (cond
      ((eql ethertype +ethertype-arp+)
       (arp-receive interface packet))
      ((eql ethertype +ethertype-ipv4+)
       ;; Should check the IP header checksum here...
       (let ((header-length (* (ldb (byte 4 0) (aref packet 14)) 4))
             (total-length (ub16ref/be packet 16))
             (protocol (aref packet (+ 14 9))))
         (cond
           ((eql protocol +ip-protocol-tcp+)
            (%tcp4-receive packet (ub32ref/be packet (+ 14 12)) (+ 14 header-length) (+ 14 total-length)))
           (t (format t "Unknown IPv4 protocol ~S ~S.~%" protocol packet)))))
      (t (format t "Unknown ethertype ~S ~S.~%" ethertype packet)))))

(define-condition drop-packet () ())

(defvar *pending-packets* '())

(defun ethernet-worker ()
  (loop (sys.int::process-wait "Ethernet worker"
                               (lambda () (not (endp *pending-packets*))))
     (with-simple-restart (abort "Ignore this packet.")
       (handler-case (apply '%receive-packet (pop *pending-packets*))
         (drop-packet ())))))

(defvar *ethernet-process* (make-instance 'sys.int::process :name "Ethernet worker"))
(sys.int::process-preset *ethernet-process* #'ethernet-worker)
(sys.int::process-enable *ethernet-process*)

(defun receive-packet (interface packet)
  (setf *pending-packets* (nconc *pending-packets* (list (list interface packet)))))

(defun detach-tcp-connection (connection)
  (setf *tcp-connections* (remove connection *tcp-connections*))
  (setf *allocated-tcp-ports* (remove (tcp-connection-local-port connection) *allocated-tcp-ports*)))

(defun tcp4-receive (connection packet &optional (start 0) end)
  (unless end (setf end (length packet)))
  (let* ((seq (ub32ref/be packet (+ start 4)))
	 (ack (ub32ref/be packet (+ start 8)))
	 (flags (aref packet (+ start 13)))
	 (header-length (* (ash (aref packet (+ start 12)) -4) 4))
	 (data-length (- end (+ start header-length))))
    (case (tcp-connection-state connection)
      (:syn-sent
       (if (and (logtest flags +tcp4-flag-ack+)
		(logtest flags +tcp4-flag-syn+)
		(eql ack (tcp-connection-s-next connection)))
	   (progn
	     (setf (tcp-connection-state connection) :established
		   (tcp-connection-r-next connection) (logand (1+ seq) #xFFFFFFFF))
	     (tcp4-send-packet connection ack (tcp-connection-r-next connection) nil))
	   (progn
	     (setf (tcp-connection-state connection) :closed)
	     (detach-tcp-connection connection)
	     (tcp4-send-packet connection 0 0 nil :ack-p nil :rst-p t)
	     (format t "TCP: got ack ~S, wanted ~S. Flags ~B~%" ack (tcp-connection-s-next connection) flags))))
      (:syn-received
       (cond ((and (eql flags +tcp4-flag-ack+)
                   (eql seq (tcp-connection-r-next connection))
                   (eql ack (tcp-connection-s-next connection)))
              (setf (tcp-connection-state connection) :established))
             (t (setf (tcp-connection-state connection) :closed)
                (detach-tcp-connection connection)
                (tcp4-send-packet connection 0 0 nil :ack-p nil :rst-p t)
                (format t "TCP: Aborting connect. Got ack ~S, wanted ~S. Got seq ~S, wanted ~S. Flags ~B~%"
                        ack (tcp-connection-s-next connection)
                        seq (tcp-connection-r-next connection)
                        flags))))
      (:established
       ;; Ignore out-of-order packets.
       (when (eql seq (tcp-connection-r-next connection))
	 (unless (eql data-length 0)
	   ;; Send data to the user layer
	   (if (tcp-connection-rx-data connection)
	       (setf (cdr (last (tcp-connection-rx-data connection))) (list (list packet (+ start header-length) end)))
	       (setf (tcp-connection-rx-data connection) (list (list packet (+ start header-length) end))))
	   (setf (tcp-connection-r-next connection)
		 (logand (+ (tcp-connection-r-next connection) data-length)
			 #xFFFFFFFF)))
	 (cond
	   ((logtest flags +tcp4-flag-fin+)
	    ;; Always ack FIN packets.
	    (setf (tcp-connection-state connection) :closing
		  (tcp-connection-r-next connection)
		  (logand (+ (tcp-connection-r-next connection) 1)
			  #xFFFFFFFF))
	    (tcp4-send-packet connection
			      (tcp-connection-s-next connection)
			      (tcp-connection-r-next connection)
			      nil
			      :fin-p t))
	   ((not (eql data-length 0))
	    (tcp4-send-packet connection
			      (tcp-connection-s-next connection)
			      (tcp-connection-r-next connection)
			      nil)))))
      (:closing
       (cond ((logtest flags +tcp4-flag-ack+))
             ((logtest flags +tcp4-flag-fin+)
              (tcp4-send-packet connection
                                (tcp-connection-s-next connection)
                                (tcp-connection-r-next connection)
                                nil
                                :ack-p t
                                :fin-p t)))
       (detach-tcp-connection connection)
       (setf (tcp-connection-state connection) :closed))
      (:closed
       (detach-tcp-connection connection))
      (t (tcp4-send-packet connection 0 0 nil :ack-p nil :rst-p t)
	 (format t "TCP: Unknown connection state ~S ~S ~S.~%" (tcp-connection-state connection) start packet)
	 (detach-tcp-connection connection)
	 (setf (tcp-connection-state connection) :closed)))))

(defun tcp4-send-packet (connection seq ack data &key (ack-p t) psh-p rst-p syn-p fin-p)
  (multiple-value-bind (ethernet-mac interface)
      (ipv4-route (tcp-connection-remote-ip connection))
    (when (and ethernet-mac interface)
      (let* ((source (ipv4-interface-address interface))
	     (source-port (tcp-connection-local-port connection))
	     (packet (assemble-tcp4-packet source source-port
					   (tcp-connection-remote-ip connection)
					   (tcp-connection-remote-port connection)
					   seq ack
					   (tcp-connection-window-size connection)
					   data
					   :ack-p ack-p
					   :psh-p psh-p
					   :rst-p rst-p
					   :syn-p syn-p
					   :fin-p fin-p)))
	(transmit-ethernet-packet interface ethernet-mac +ethertype-ipv4+ packet)))))

(defun ipv4-route (destination)
  "Return the interface and destination mac for the destination IP address."
  (let ((default-route nil))
    (dolist (route *routing-table*)
      (cond ((null (first route))
	     (setf default-route route))
	    ((eql (logand destination (third route)) (first route))
	     (return-from ipv4-route
	       (values (arp-lookup (fourth route) +ethertype-ipv4+ destination)
		       (fourth route))))))
    (when default-route
      (values (arp-lookup (fourth default-route) +ethertype-ipv4+ (second default-route))
	      (fourth default-route)))))

(defun make-ipv4-address (a b c d)
  (logior (ash a 24)
	  (ash b 16)
	  (ash c 8)
	  d))

(defun compute-ip-partial-checksum (buffer &optional (start 0) end (initial 0))
  ;; From RFC 1071.
  (let ((total initial))
    (setf end (or end (length buffer)))<commit_msg>Signal an error if there is no route to an IPv4 host.<commit_after>(defpackage #:system.networking
  (:use #:cl #:sys.int)
  (:nicknames #:sys.net)
  (:export register-nic
           ethernet-mac
           transmit-packet
           receive-packet
           arp-lookup
           copy-packet packet-length))

(in-package #:sys.net)

(defvar *cards* '())

(defun register-nic (nic)
  (push nic *cards*))

(defgeneric ethernet-mac (nic))

(defun reduce (function list)
  (cond ((null list) (funcall function))
        ((null (rest list)) (first list))
        (t (let ((x (funcall function (first list) (second list))))
             (dolist (i (cddr list) x)
               (setf x (funcall function x i)))))))

(defun packet-length (packet)
  (reduce '+ (mapcar 'length packet)))

(defun copy-packet (buffer packet &optional (buffer-start 0))
  (dolist (p packet)
    (dotimes (i (length p))
      (setf (aref buffer buffer-start) (aref p i))
      (incf buffer-start))))

(defun ub16ref/be (vector index)
  (logior (ash (aref vector index) 8)
	  (aref vector (1+ index))))
(defun (setf ub16ref/be) (value vector index)
  (setf (aref vector index) (ash value -8)
	(aref vector (1+ index)) (logand value #xFF))
  value)

(defun ub16ref/le (vector index)
  (logior (aref vector index)
	  (ash (aref vector (1+ index)) 8)))
(defun (setf ub16ref/le) (value vector index)
  (setf (aref vector index) (logand value #xFF)
	(aref vector (1+ index)) (ash value -8))
  value)

(defun ub32ref/be (vector index)
  (logior (ash (aref vector index) 24)
	  (ash (aref vector (+ index 1)) 16)
	  (ash (aref vector (+ index 2)) 8)
	  (aref vector (+ index 3))))
(defun (setf ub32ref/be) (value vector index)
  (setf (aref vector index) (ash value -24)
	(aref vector (+ index 1)) (logand (ash value -16) #xFF)
	(aref vector (+ index 2)) (logand (ash value -8) #xFF)
	(aref vector (+ index 3)) (logand value #xFF))
  value)

(defun ub32ref/le (vector index)
  (logior (aref vector index)
	  (ash (aref vector (+ index 1)) 8)
	  (ash (aref vector (+ index 2)) 16)
	  (ash (aref vector (+ index 3)) 24)))
(defun (setf ub32ref/le) (value vector index)
  (setf (aref vector index) (logand value #xFF)
	(aref vector (+ index 1)) (logand (ash value -8) #xFF)
	(aref vector (+ index 2)) (logand (ash value -16) #xFF)
	(aref vector (+ index 3)) (ash value -24))
  value)

(defconstant +ethertype-ipv4+ #x0800)
(defconstant +ethertype-arp+  #x0806)
(defconstant +ethertype-ipv6+ #x86DD)

(defconstant +arp-op-request+ 1)
(defconstant +arp-op-reply+ 2)

(defconstant +arp-hrd-ethernet+ 1)

(defconstant +ip-protocol-icmp+ 1)
(defconstant +ip-protocol-igmp+ 2)
(defconstant +ip-protocol-tcp+ 6)
(defconstant +ip-protocol-udp+ 17)

(defconstant +tcp4-flag-fin+ #b00000001)
(defconstant +tcp4-flag-syn+ #b00000010)
(defconstant +tcp4-flag-rst+ #b00000100)
(defconstant +tcp4-flag-psh+ #b00001000)
(defconstant +tcp4-flag-ack+ #b00010000)

(defconstant +icmp-echo-reply+ 0)
(defconstant +icmp-echo-request+ 8)
(defconstant +icmp-destination-unreachable+ 3)
(defconstant +icmp-time-exceeded+ 11)
(defconstant +icmp-parameter-problem+ 12)

;;; Destination unreachable codes.
(defconstant +icmp-code-net-unreachable+ 0)
(defconstant +icmp-code-host-unreachable+ 1)
(defconstant +icmp-code-protocol-unreachable+ 2)
(defconstant +icmp-code-port-unreachable+ 3)
(defconstant +icmp-code-fragmentation-needed+ 4)
(defconstant +icmp-code-source-route-failed+ 5)

;; Time exceeded codes.
(defconstant +icmp-code-ttl-exceeded+ 0)
(defconstant +icmp-code-fragment-timeout+ 1)

(defparameter *ethernet-broadcast* (make-array 6 :element-type '(unsigned-byte 8)
                                               :initial-element #xFF))

(defparameter *ipv4-interfaces* '())

(defun ifup (nic address)
  (setf (getf *ipv4-interfaces* nic) address))

(defun ifdown (nic)
  (setf (getf *ipv4-interfaces* nic) nil))

(defun ipv4-interface-address (nic &optional (errorp t))
  (or (getf *ipv4-interfaces* nic)
      (and errorp
           (error "No IPv4 address for interface ~S." nic))))

;;; The ARP table is a list of lists. Each list holds:
;;; (protocol-type protocol-address network-address age)
(defvar *arp-table* nil)

(defun arp-receive (interface packet)
  (let* ((htype (ub16ref/be packet 14))
	 (ptype (ub16ref/be packet 16))
	 (hlen (aref packet 18))
	 (plen (aref packet 19))
	 (oper (ub16ref/be packet 20))
	 (sha-start 22)
	 (spa-start (+ sha-start hlen))
	 (tha-start (+ spa-start plen))
	 (tpa-start (+ tha-start hlen))
	 (packet-end (+ tpa-start plen))
	 (merge-flag nil)
         (address (ipv4-interface-address interface nil)))
    ;; Ethernet hardware type and IPv4.
    (when (and (eql htype +arp-hrd-ethernet+) (eql hlen 6)
	       (eql ptype +ethertype-ipv4+) (eql plen 4))
      (let ((spa (ub32ref/be packet spa-start))
	    (tpa (ub32ref/be packet tpa-start)))
	;; If the pair <protocol type, sender protocol address> is
	;; already in my translation table, update the sender
	;; hardware address field of the entry with the new
	;; information in the packet and set Merge_flag to true.
	(dolist (e *arp-table*)
	  (when (and (eql (first e) ptype)
		     (eql (second e) spa))
	    (setf (third e) (subseq packet sha-start spa-start)
		  merge-flag t)
	    (return)))
	(when (and address (eql tpa address))
	  (unless merge-flag
	    (push (list ptype spa (subseq packet sha-start spa-start) 0) *arp-table*))
	  (when (eql oper +arp-op-request+)
	    ;; Copy source hardware address to dest MAC and target h/w address.
	    (dotimes (i 6)
	      (setf (aref packet i) (aref packet (+ sha-start i))
		    (aref packet (+ tha-start i)) (aref packet (+ sha-start i))))
	    ;; Copy source protocol address to target protocol address.
	    (dotimes (i plen)
	      (setf (aref packet (+ tpa-start i)) (aref packet (+ spa-start i))))
	    ;; Set source hardware address and source MAC to the interface's MAC.
	    (let ((mac (ethernet-mac interface)))
	      (dotimes (i 6)
		(setf (aref packet (+ 6 i)) (aref mac i)
		      (aref packet (+ sha-start i)) (aref mac i))))
	    (setf (ub32ref/be packet spa-start) address
		  (ub16ref/be packet 20) +arp-op-reply+)
	    (transmit-packet interface (list packet))))))))

(defun send-arp (interface ptype address)
  "Send an ARP packet out onto the wire."
  (unless (eql ptype +ethertype-ipv4+)
    (error "Unsupported protocol type ~S" ptype))
  (let ((packet (make-array 42 :element-type '(unsigned-byte 8)))
	(mac (ethernet-mac interface)))
    ;; Fill in various hardware address fields.
    (dotimes (i 6)
      ;; Ethernet destination.
      (setf (aref packet i) #xFF
	    ;; Ethernet source.
	    (aref packet (+ 6 i)) (aref mac i)
	    ;; ARP source hardware address.
	    (aref packet (+ 22 i)) (aref mac i)))
    ;; Set the source and target protocol addresses.
    (setf (ub32ref/be packet 28) (ipv4-interface-address interface)
	  (ub32ref/be packet 38) address
	  ;; Various other fields.
	  (ub16ref/be packet 12) +ethertype-arp+
	  (ub16ref/be packet 14) +arp-hrd-ethernet+
	  (ub16ref/be packet 16) +ethertype-ipv4+
	  (aref packet 18) 6
	  (aref packet 19) 4
	  (ub16ref/be packet 20) +arp-op-request+)
    (transmit-packet interface (list packet))))

(defun arp-lookup (interface ptype address)
  "Convert ADDRESS to an Ethernet address."
  ;; Scan the ARP table.
  (dolist (e *arp-table*)
    (when (and (eql (first e) ptype)
	       (eql (second e) address))
      (return-from arp-lookup (third e))))
  (dotimes (attempt 3)
    (send-arp interface ptype address)
    ;; FIXME: better timeout.
    (sys.int::process-wait-with-timeout "ARP Lookup" 200
			       (lambda ()
				 (dolist (e *arp-table* nil)
				   (when (and (eql (first e) ptype)
					      (eql (second e) address))
				     (return t)))))
    (dolist (e *arp-table*)
      (when (and (eql (first e) ptype)
		 (eql (second e) address))
	(return-from arp-lookup (third e))))))

(defstruct tcp-connection
  state
  local-port
  remote-port
  remote-ip
  s-next
  r-next
  window-size
  (max-seg-size 1000)
  rx-data)

(defvar *raw-packet-hooks* nil)
(defvar *tcp-connections* nil)
(defvar *allocated-tcp-ports* nil)
(defvar *server-alist* '())

(defun get-tcp-connection (remote-ip remote-port local-port)
  (dolist (connection *tcp-connections*)
    (when (and (eql (tcp-connection-remote-ip connection) remote-ip)
               (eql (tcp-connection-remote-port connection) remote-port)
               (eql (tcp-connection-local-port connection) local-port))
      (return connection))))

(defun %tcp4-receive (packet remote-ip start end)
  (let* ((remote-port (ub16ref/be packet start))
         (local-port (ub16ref/be packet (+ start 2)))
         (flags (aref packet (+ start 13)))
         (connection (get-tcp-connection remote-ip remote-port local-port)))
    (cond
      (connection
       (tcp4-receive connection packet start end))
      ((eql flags +tcp4-flag-syn+)
       (format t "Establishing TCP connection. l ~D  r ~D  from ~X.~%" local-port remote-port remote-ip)
       (let* ((seq (ub32ref/be packet (+ start 4)))
              (blah (random #x100000000))
              (connection (make-tcp-connection :state :syn-received
                                               :local-port local-port
                                               :remote-port remote-port
                                               :remote-ip remote-ip
                                               :s-next (logand #xFFFFFFFF (1+ blah))
                                               :r-next (logand #xFFFFFFFF (1+ seq))
                                               :window-size 8192)))
         (let ((server (assoc local-port *server-alist*)))
           (cond (server
                  (push connection *tcp-connections*)
                  (tcp4-send-packet connection blah (logand #xFFFFFFFF (1+ seq)) nil
                                    :ack-p t :syn-p t)
                  (funcall (second server) connection))
                 (t (tcp4-send-packet connection blah (logand #xFFFFFFFF (1+ seq)) nil
                                      :ack-p t :rst-p t))))))
      (t (unless (logtest flags +tcp4-flag-rst+)
           (let ((connection (make-tcp-connection :state :syn-received
                                                  :local-port local-port
                                                  :remote-port remote-port
                                                  :remote-ip remote-ip
                                                  :s-next 0
                                                  :r-next 0
                                                  :window-size 8192)))
             (tcp4-send-packet connection 0 0 nil
                               :ack-p nil :rst-p t)))))))

(defun %receive-packet (interface packet)
  (dolist (hook *raw-packet-hooks*)
    (funcall hook interface packet))
  (let ((ethertype (ub16ref/be packet 12)))
    (cond
      ((eql ethertype +ethertype-arp+)
       (arp-receive interface packet))
      ((eql ethertype +ethertype-ipv4+)
       ;; Should check the IP header checksum here...
       (let ((header-length (* (ldb (byte 4 0) (aref packet 14)) 4))
             (total-length (ub16ref/be packet 16))
             (protocol (aref packet (+ 14 9))))
         (cond
           ((eql protocol +ip-protocol-tcp+)
            (%tcp4-receive packet (ub32ref/be packet (+ 14 12)) (+ 14 header-length) (+ 14 total-length)))
           (t (format t "Unknown IPv4 protocol ~S ~S.~%" protocol packet)))))
      (t (format t "Unknown ethertype ~S ~S.~%" ethertype packet)))))

(define-condition drop-packet () ())

(defvar *pending-packets* '())

(defun ethernet-worker ()
  (loop (sys.int::process-wait "Ethernet worker"
                               (lambda () (not (endp *pending-packets*))))
     (with-simple-restart (abort "Ignore this packet.")
       (handler-case (apply '%receive-packet (pop *pending-packets*))
         (drop-packet ())))))

(defvar *ethernet-process* (make-instance 'sys.int::process :name "Ethernet worker"))
(sys.int::process-preset *ethernet-process* #'ethernet-worker)
(sys.int::process-enable *ethernet-process*)

(defun receive-packet (interface packet)
  (setf *pending-packets* (nconc *pending-packets* (list (list interface packet)))))

(defun detach-tcp-connection (connection)
  (setf *tcp-connections* (remove connection *tcp-connections*))
  (setf *allocated-tcp-ports* (remove (tcp-connection-local-port connection) *allocated-tcp-ports*)))

(defun tcp4-receive (connection packet &optional (start 0) end)
  (unless end (setf end (length packet)))
  (let* ((seq (ub32ref/be packet (+ start 4)))
	 (ack (ub32ref/be packet (+ start 8)))
	 (flags (aref packet (+ start 13)))
	 (header-length (* (ash (aref packet (+ start 12)) -4) 4))
	 (data-length (- end (+ start header-length))))
    (case (tcp-connection-state connection)
      (:syn-sent
       (if (and (logtest flags +tcp4-flag-ack+)
		(logtest flags +tcp4-flag-syn+)
		(eql ack (tcp-connection-s-next connection)))
	   (progn
	     (setf (tcp-connection-state connection) :established
		   (tcp-connection-r-next connection) (logand (1+ seq) #xFFFFFFFF))
	     (tcp4-send-packet connection ack (tcp-connection-r-next connection) nil))
	   (progn
	     (setf (tcp-connection-state connection) :closed)
	     (detach-tcp-connection connection)
	     (tcp4-send-packet connection 0 0 nil :ack-p nil :rst-p t)
	     (format t "TCP: got ack ~S, wanted ~S. Flags ~B~%" ack (tcp-connection-s-next connection) flags))))
      (:syn-received
       (cond ((and (eql flags +tcp4-flag-ack+)
                   (eql seq (tcp-connection-r-next connection))
                   (eql ack (tcp-connection-s-next connection)))
              (setf (tcp-connection-state connection) :established))
             (t (setf (tcp-connection-state connection) :closed)
                (detach-tcp-connection connection)
                (tcp4-send-packet connection 0 0 nil :ack-p nil :rst-p t)
                (format t "TCP: Aborting connect. Got ack ~S, wanted ~S. Got seq ~S, wanted ~S. Flags ~B~%"
                        ack (tcp-connection-s-next connection)
                        seq (tcp-connection-r-next connection)
                        flags))))
      (:established
       ;; Ignore out-of-order packets.
       (when (eql seq (tcp-connection-r-next connection))
	 (unless (eql data-length 0)
	   ;; Send data to the user layer
	   (if (tcp-connection-rx-data connection)
	       (setf (cdr (last (tcp-connection-rx-data connection))) (list (list packet (+ start header-length) end)))
	       (setf (tcp-connection-rx-data connection) (list (list packet (+ start header-length) end))))
	   (setf (tcp-connection-r-next connection)
		 (logand (+ (tcp-connection-r-next connection) data-length)
			 #xFFFFFFFF)))
	 (cond
	   ((logtest flags +tcp4-flag-fin+)
	    ;; Always ack FIN packets.
	    (setf (tcp-connection-state connection) :closing
		  (tcp-connection-r-next connection)
		  (logand (+ (tcp-connection-r-next connection) 1)
			  #xFFFFFFFF))
	    (tcp4-send-packet connection
			      (tcp-connection-s-next connection)
			      (tcp-connection-r-next connection)
			      nil
			      :fin-p t))
	   ((not (eql data-length 0))
	    (tcp4-send-packet connection
			      (tcp-connection-s-next connection)
			      (tcp-connection-r-next connection)
			      nil)))))
      (:closing
       (cond ((logtest flags +tcp4-flag-ack+))
             ((logtest flags +tcp4-flag-fin+)
              (tcp4-send-packet connection
                                (tcp-connection-s-next connection)
                                (tcp-connection-r-next connection)
                                nil
                                :ack-p t
                                :fin-p t)))
       (detach-tcp-connection connection)
       (setf (tcp-connection-state connection) :closed))
      (:closed
       (detach-tcp-connection connection))
      (t (tcp4-send-packet connection 0 0 nil :ack-p nil :rst-p t)
	 (format t "TCP: Unknown connection state ~S ~S ~S.~%" (tcp-connection-state connection) start packet)
	 (detach-tcp-connection connection)
	 (setf (tcp-connection-state connection) :closed)))))

(defun tcp4-send-packet (connection seq ack data &key (ack-p t) psh-p rst-p syn-p fin-p)
  (multiple-value-bind (ethernet-mac interface)
      (ipv4-route (tcp-connection-remote-ip connection))
    (when (and ethernet-mac interface)
      (let* ((source (ipv4-interface-address interface))
	     (source-port (tcp-connection-local-port connection))
	     (packet (assemble-tcp4-packet source source-port
					   (tcp-connection-remote-ip connection)
					   (tcp-connection-remote-port connection)
					   seq ack
					   (tcp-connection-window-size connection)
					   data
					   :ack-p ack-p
					   :psh-p psh-p
					   :rst-p rst-p
					   :syn-p syn-p
					   :fin-p fin-p)))
	(transmit-ethernet-packet interface ethernet-mac +ethertype-ipv4+ packet)))))

(defun ipv4-route (destination)
  "Return the interface and destination mac for the destination IP address."
  (let ((default-route nil))
    (dolist (route *routing-table*)
      (cond ((null (first route))
	     (setf default-route route))
	    ((eql (logand destination (third route)) (first route))
	     (return-from ipv4-route
	       (values (arp-lookup (fourth route) +ethertype-ipv4+ destination)
		       (fourth route))))))
    (if default-route
        (values (arp-lookup (fourth default-route) +ethertype-ipv4+ (second default-route))
                (fourth default-route))
        (error "No route to host."))))

(defun make-ipv4-address (a b c d)
  (logior (ash a 24)
	  (ash b 16)
	  (ash c 8)
	  d))

(defun compute-ip-partial-checksum (buffer &optional (start 0) end (initial 0))
  ;; From RFC 1071.
  (let ((total initial))
    (setf end (or end (length buffer)))
{'fraction_non_alphanumeric': 0.1397652753933185, 'fraction_numerical': 0.02023585038417157, 'mean_word_length': 2.5062166962699823, 'pattern_counts': {'":': 0, '<': 5, '<?xml version=': 0, '>': 5, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 18, 'word_list_counts': {'cursed_substrings.json': 56, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '7097442', 'n_tokens_mistral': 12492, 'n_tokens_neox': 11326, 'n_words': 3415}