Adding socket-get-read-timeout

ext/socket/sagittarius-socket.c

@@ -611,6 +611,11 @@ SgObject Sg_SocketSetopt(SgSocket *socket, int level, int name, SgObject value)
     long v = Sg_GetInteger(value);
     r = setsockopt(socket->socket, level, name, (const char *)&v, sizeof(int));
   } else if (SG_TIMEP(value)) {
+    if (name != SO_RCVTIMEO && name != SO_SNDTIMEO) {
+      Sg_AssertionViolation(SG_INTERN("socket-setsockopt!"),
+			    SG_MAKE_STRING("time object is required for SO_RCVTIMEO and SO_SNDTIMEO"),
+			    value);
+    }
 #ifdef _WIN32
     DWORD v;
     v = SG_TIME(value)->sec*1000 + SG_TIME(value)->nsec/1000000;
@@ -638,7 +643,9 @@ SgObject Sg_SocketGetopt(SgSocket *socket, int level, int name, int rsize)
 {
   int r = 0;
   socklen_t rrsize = rsize;
+
   CLOSE_SOCKET("socket-getsockopt", socket);
+
   if (rsize > 0) {
     SgObject bvec = Sg_MakeByteVector(rrsize, 0);
     r = getsockopt(socket->socket, level, name, 
@@ -650,6 +657,37 @@ SgObject Sg_SocketGetopt(SgSocket *socket, int level, int name, int rsize)
     }
     SG_BVECTOR_SIZE(bvec) = rrsize;
     return SG_OBJ(bvec);
+  } else if (name == SO_RCVTIMEO || name == SO_SNDTIMEO) {
+    SgTime *t;
+#ifdef _WIN32
+    DWORD v;
+    rrsize = sizeof(DWORD);
+    r = getsockopt(socket->socket, level, name, (const char *)v, &rrsize);
+#else
+    struct timeval tv;
+    rrsize = sizeof(struct timeval);
+    r = getsockopt(socket->socket, level, name, &tv, &rrsize);
+#endif
+    if (r < 0) {
+      raise_socket_error(SG_INTERN("socket-getsockopt"), 
+			 Sg_GetLastErrorMessageWithErrorCode(last_error),
+			 Sg_MakeConditionSocket(socket), SG_NIL);
+    }
+
+    t = SG_NEW(SgTime);
+    SG_SET_CLASS(t, SG_CLASS_TIME);
+    t->type = SG_INTERN("time-duration");
+    if (rrsize > 0) {
+#ifdef _WIN32
+      t->sec = v / 1000;
+      t->nsec = (v % 1000) * 1000000;
+#else
+      t->sec = tv.tv_sec;
+      t->nsec = tv.tv_usec * 1000;
+#endif
+      return SG_OBJ(t);
+    }
+    return SG_FALSE;		/*  not set */
   } else {
     int val;
     rrsize = sizeof(int);

ext/socket/sagittarius/socket.scm

@@ -69,6 +69,7 @@
 	    socket-nonblocking!
 	    socket-blocking!
 	    socket-set-read-timeout!
+	    socket-get-read-timeout
 	    nonblocking-socket?
 	    ;; addrinfo
 	    make-addrinfo
@@ -205,27 +206,30 @@
   (define-condition-accessor socket-error-port &socket-port &socket-error-port)
 
   (define-condition-type &socket-read-timeout &socket
-    make-socket-read-timeout-error socket-read-timeout-error?)
+    make-socket-read-timeout-error socket-read-timeout-error?
+    (timeout socket-read-timeout-error-timeout))
 
   (define (socket-recv! sock bv start len :optional (flags 0))
     (let ((r (%socket-recv! sock bv start len flags)))
       (when (and (< r 0) (not (nonblocking-socket? sock)))
-	(raise (condition (make-socket-read-timeout-error sock)
-			  (make-who-condition 'socket-recv!)
-			  (make-message-condition 
-			   (format "Read timeout! node: ~a, service: ~a"
-				   (socket-node sock)
-				   (socket-service sock))))))
+	(let ((to (socket-get-read-timeout sock)))
+	  (raise (condition (make-socket-read-timeout-error sock to)
+			    (make-who-condition 'socket-recv!)
+			    (make-message-condition 
+			     (format "Read timeout! node: ~a, service: ~a"
+				     (socket-node sock)
+				     (socket-service sock)))))))
       r))
   (define (socket-recv sock len :optional (flags 0))
     (let ((r (%socket-recv sock len flags)))
       (unless (or r (nonblocking-socket? sock))
-	(raise (condition (make-socket-read-timeout-error sock)
-			  (make-who-condition 'socket-recv)
-			  (make-message-condition
-			   (format "Read timeout! node: ~a, service: ~a"
-				   (socket-node sock)
-				   (socket-service sock))))))
+	(let ((to (socket-get-read-timeout sock)))
+	  (raise (condition (make-socket-read-timeout-error sock to)
+			    (make-who-condition 'socket-recv)
+			    (make-message-condition
+			     (format "Read timeout! node: ~a, service: ~a"
+				     (socket-node sock)
+				     (socket-service sock)))))))
       r))
 
   (define (socket-set-read-timeout! socket read-timeout)
@@ -240,6 +244,9 @@
 	  (else (assertion-violation 'socket-set-read-timeout!
 		  "Timeout value must be an exact integer (milliseconds) or time"
 		  read-timeout))))
+  (define (socket-get-read-timeout socket)
+    (socket-getsockopt socket SOL_SOCKET SO_RCVTIMEO -1))
+
 
   (define (call-with-socket socket proc)
     (receive args (proc socket)

ext/socket/sagittarius/tls-socket.scm

@@ -54,7 +54,8 @@
 	    (sagittarius)
 	    (only (sagittarius socket)
 		  nonblocking-socket? make-socket-read-timeout-error
-		  socket-node socket-service)
+		  socket-node socket-service
+		  socket-get-read-timeout)
 	    (sagittarius dynamic-module))
 (load-dynamic-module "sagittarius--tls-socket")
 
@@ -63,8 +64,9 @@
 (define (tls-socket-recv! sock bv start len :optional (flags 0))
   (let ((r (%tls-socket-recv! sock bv start len flags)))
     (when (and (< r 0) (not (nonblocking-socket? (slot-ref sock 'raw-socket))))
-      (let ((raw-sock (slot-ref sock 'raw-socket)))
-	(raise (condition (make-socket-read-timeout-error sock)
+      (let* ((raw-sock (slot-ref sock 'raw-socket))
+	     (to (socket-get-read-timeout raw-sock)))
+	(raise (condition (make-socket-read-timeout-error sock to)
 			  (make-who-condition 'tls-socket-recv!)
 			  (make-message-condition
 			   (format "Read timeout! node: ~a, service: ~a"
@@ -75,8 +77,9 @@
 (define (tls-socket-recv sock len :optional (flags 0))
   (let ((r (%tls-socket-recv sock len flags)))
     (unless (or r (nonblocking-socket? (slot-ref sock 'raw-socket)))
-      (let ((raw-sock (slot-ref sock 'raw-socket)))
-	(raise (condition (make-socket-read-timeout-error sock)
+      (let* ((raw-sock (slot-ref sock 'raw-socket))
+	     (to (socket-get-read-timeout raw-sock)))
+	(raise (condition (make-socket-read-timeout-error sock to)
 			  (make-who-condition 'tls-socket-recv)
 			  (make-message-condition
 			   (format "Read timeout! node: ~a, service: ~a"

sitelib/net/socket.scm

@@ -100,6 +100,7 @@
 	    socket-nonblocking!
 	    socket-blocking!
 	    socket-set-read-timeout!
+	    socket-get-read-timeout
 	    nonblocking-socket?
 
 	    make-socket-selector
@@ -511,7 +512,7 @@
 			      "Timeout must be integer (ms) or time" timeout))))
 (define (make-selector-timeout-condition sock timeout)
   (condition 
-   (make-socket-read-timeout-error sock)
+   (make-socket-read-timeout-error sock timeout)
    (make-who-condition 'socket-selector)
    (make-message-condition
     (format "Selector timeout: node: ~a, service: ~a, timeout: ~s"

sitelib/rfc/tls/socket.scm

@@ -56,6 +56,7 @@
 	    tls-socket-nonblocking!
 	    tls-socket-blocking!
 	    tls-socket-set-read-timeout!
+	    tls-socket-get-read-timeout
 	    nonblocking-tls-socket?
 	    tls-socket-client-certificate-callback-set!
 
@@ -289,6 +290,8 @@
     (nonblocking-socket? (~ socket 'raw-socket)))
   (define (tls-socket-set-read-timeout! tls-socket timeout)
     (socket-set-read-timeout! (slot-ref tls-socket 'raw-socket) timeout))
+  (define (tls-socket-get-read-timeout tls-socket)
+    (socket-get-read-timeout (slot-ref tls-socket 'raw-socket)))
 
   ;; to make call-with-socket available for tls-socket
   (define-method socket-close ((o <tls-socket>))
@@ -336,6 +339,8 @@
     (nonblocking-tls-socket? o))
   (define-method socket-set-read-timeout! ((o <tls-socket>) timeout)
     (tls-socket-set-read-timeout! o timeout))
+  (define-method socket-get-read-timeout ((o <tls-socket>))
+    (tls-socket-get-read-timeout o))
 
   (define (select-sockets selector timeout sockets)
     (define mapping (make-eq-hashtable))