changeset 1:465aac549a11

add some code for writing slurp packets on a socket
author John Leuner <jewel@subvert-the-dominant-paradigm.net>
date Fri, 25 Apr 2008 03:01:14 +0530
parents 95785e4bcc1b
children 0fb98b96b2c1
files lisp/slurp-socket.lisp
diffstat 1 files changed, 72 insertions(+), 0 deletions(-) [+]
line wrap: on
line diff
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/slurp-socket.lisp	Fri Apr 25 03:01:14 2008 +0530
@@ -0,0 +1,72 @@
+(defpackage #:slurp-socket
+  (:use #:cl #:sb-bsd-sockets #:slurp))
+(in-package :slurp-socket)
+(define-condition slurp-read-packet-length-failure (error) ( (msg :initarg :msg)))
+
+(defun read-packet-length (socket)
+  (let* ((buffer (make-array 1 :element-type '(unsigned-byte 8)))
+	 (datum-code (multiple-value-bind (buf len addr)
+			 (socket-receive socket buffer 1)
+					;		       (format t "got datum code ~A~%" (aref buffer 0))
+		       len))
+	 read-byte)
+    (when (not (eq datum-code 1))
+      (error 'slurp-read-packet-length-failure :msg (format nil "receive returned ~A" datum-code)))
+    (when (not (eq (aref buffer 0) 2))
+      (error (format nil "bad type ~A~%" (aref buffer 0))))
+    (labels ((read-next-byte (multiplier)
+	       (multiple-value-bind (buf len addr)
+		   (socket-receive socket buffer 1)
+		 (progn
+		   (when (not (eq len 1)) 
+		     (error (format nil "bad recv length in read-packet-length ~A" len ) ))
+		   )
+		 (setf read-byte (aref buffer 0))
+					; (format t "read ~A~%" read-byte)
+		 (if (>= read-byte 128)
+		     (+ (* (- read-byte 128) multiplier)
+			(read-next-byte (* multiplier 128)))
+		     (* read-byte multiplier)))))
+      
+      (read-next-byte 1))))
+  
+(defun read-packet (socket length)
+  (loop with packet = (make-array length :element-type '(unsigned-byte 8))
+	with buffer-length = (min length 4096)
+	with buffer = (make-array buffer-length  :element-type '(unsigned-byte 8) :displaced-to packet :displaced-index-offset 0)
+	with bytes-written = 0
+	with bytes-remaining = length
+	do (let ((bytes-read (multiple-value-bind (buf len addr)
+				 (socket-receive socket buffer buffer-length)
+			       len
+			       )))
+	     (setf bytes-remaining (- bytes-remaining bytes-read))
+	     (setf bytes-written (+ bytes-written bytes-read))
+	    ;	     (format t "bytes-remaining ~A bytes-written ~A length ~A" bytes-remaining bytes-written length)
+	     (when (eq bytes-remaining 0)
+	       (return-from read-packet packet)
+	       )
+	     (adjust-array buffer (min bytes-remaining buffer-length)  :displaced-to packet :displaced-index-offset bytes-written)
+	     (setf buffer-length (min bytes-remaining buffer-length))
+	     )))
+
+(defun send-packet-with-socket (socket packet)
+  (let ((length-header (slurp:encode (length packet))))
+    (loop for byte across length-header do
+	  (if (not (eq (socket-send socket (make-array 1 :element-type '(unsigned-byte 8) :initial-contents (vector byte)) 1)
+		       1))
+	      (return-from send-packet-with-socket nil)))
+    (send-fully socket packet)))
+
+(defun send-fully (socket original-buffer)
+  (loop with bytes-sent = 0
+	with bytes-remaining = (length original-buffer)
+	with buffer = original-buffer
+	do (progn
+	     (let ((sent (socket-send socket buffer (length buffer))))
+	       ;	       (format t "sent is ~A~%" sent)
+	       (setf bytes-sent (+ bytes-sent sent))
+	       (setf bytes-remaining (- bytes-remaining sent))
+	       (if (> bytes-remaining 0)
+		   (setf buffer (adjust-array buffer bytes-remaining :displaced-to buffer :displaced-index-offset sent))
+		   (return t))))))
\ No newline at end of file