[Unetwork-cvs] CVS update: unetwork/src/socket.lisp unetwork/src/base-cmu.lisp unetwork/src/base-sbcl.lisp unetwork/src/http.lisp unetwork/src/nntp.lisp unetwork/src/package.lisp unetwork/src/pop3.lisp unetwork/src/smtp.lisp unetwork/src/unetwork.asd unetwork/src/uri-streams.lisp
Matthieu Villeneuve
mvilleneuve at common-lisp.net
Tue Mar 23 13:02:22 UTC 2004
Update of /project/unetwork/cvsroot/unetwork/src
In directory common-lisp.net:/tmp/cvs-serv1760
Modified Files:
base-cmu.lisp base-sbcl.lisp http.lisp nntp.lisp package.lisp
pop3.lisp smtp.lisp unetwork.asd uri-streams.lisp
Added Files:
socket.lisp
Log Message:
Cleaned up socket and connection classes
Date: Tue Mar 23 08:02:21 2004
Author: mvilleneuve
Index: unetwork/src/base-cmu.lisp
diff -u unetwork/src/base-cmu.lisp:1.1 unetwork/src/base-cmu.lisp:1.2
--- unetwork/src/base-cmu.lisp:1.1 Fri Mar 12 09:46:38 2004
+++ unetwork/src/base-cmu.lisp Tue Mar 23 08:02:21 2004
@@ -12,8 +12,6 @@
(in-package :unetwork)
-;;; Name service
-
(defun resolve-host-ip (hostname)
"Return the IP address of a host."
(let ((host (ext:lookup-host-entry hostname)))
@@ -21,13 +19,7 @@
(error 'unknown-host-error :host hostname))
(first (ext:host-entry-addr-list host))))
-;;; Sockets
-
-(defclass socket ()
- ((sock :initarg :sock :reader socket-sock)
- (stream :initarg :stream :reader socket-stream)))
-
-(defun socket-open (host port &key (type :text))
+(defun open-socket (host port &key (type :text))
"Open a socket on specified host and port. Keyword argument TYPE
can be either :TEXT or :BINARY (defaults to :TEXT)."
(handler-case
@@ -41,15 +33,13 @@
(make-instance 'socket :sock sock :stream stream))
(simple-error () (error 'connection-error :host host))))
-(defun socket-close (socket)
+(defun close-socket (socket)
"Close a socket."
(ext:close-socket (socket-sock socket)))
-;;; Server sockets
-
-(defun server-socket-open (port)
+(defun open-server-socket (port)
"Open a server socket on localhost on specified port."
- (ext:create-inet-listener port ))
+ (ext:create-inet-listener port))
(defun server-socket-accept (server-socket &key timeout)
"Accept a connection on a server socket. Return the
@@ -61,6 +51,6 @@
:element-type '(unsigned-byte 8))))
(make-instance 'socket :sock sock :stream stream))))
-(defun server-socket-close (server-socket)
+(defun close-server-socket (server-socket)
"Close a server socket."
(unix:unix-close server-socket))
Index: unetwork/src/base-sbcl.lisp
diff -u unetwork/src/base-sbcl.lisp:1.2 unetwork/src/base-sbcl.lisp:1.3
--- unetwork/src/base-sbcl.lisp:1.2 Fri Mar 12 12:09:34 2004
+++ unetwork/src/base-sbcl.lisp Tue Mar 23 08:02:21 2004
@@ -19,11 +19,7 @@
(error 'unknown-host-error :host hostname))
(sb-bsd-sockets:host-ent-address host)))
-(defclass socket ()
- ((sock :initarg :sock :reader socket-sock)
- (stream :initarg :stream :reader socket-stream)))
-
-(defun socket-open (host port &key (type :text))
+(defun open-socket (host port &key (type :text))
"Open a socket on specified host and port. Keyword argument TYPE
can be either :TEXT or :BINARY (defaults to :TEXT)."
(handler-case
@@ -39,11 +35,11 @@
(make-instance 'socket :sock sock :stream stream)))
(simple-error () (error 'connection-error :host host))))
-(defun socket-close (socket)
+(defun close-socket (socket)
"Close a socket."
(sb-bsd-sockets:socket-close (socket-sock socket)))
-(defun server-socket-open (port)
+(defun open-server-socket (port)
"Open a server socket on localhost on specified port."
(error "Not implemented yet."))
@@ -52,6 +48,6 @@
resulting socket."
(error "Not implemented yet."))
-(defun server-socket-close (server-socket)
+(defun close-server-socket (server-socket)
"Close a server socket."
(error "Not implemented yet."))
Index: unetwork/src/http.lisp
diff -u unetwork/src/http.lisp:1.2 unetwork/src/http.lisp:1.3
--- unetwork/src/http.lisp:1.2 Fri Mar 12 12:12:04 2004
+++ unetwork/src/http.lisp Tue Mar 23 08:02:21 2004
@@ -35,7 +35,7 @@
three values: the response code as an integer, the resource
properties (headers) as an assoc list, and the connection socket."
(assert (eq (uri-scheme uri) :http))
- (let* ((socket (socket-open (uri-host uri)
+ (let* ((socket (open-socket (uri-host uri)
(or (uri-port uri) +http-default-port+)))
(stream (socket-stream socket)))
(format stream "~A ~A~@[?~A~] HTTP/1.0~%"
@@ -59,7 +59,7 @@
(make-instance 'document
:text content
:properties properties)))
- (socket-close socket))))
+ (close-socket socket))))
(defun http-read-response (socket)
(let* ((stream (socket-stream socket))
@@ -83,8 +83,24 @@
do (vector-push-extend byte content)
finally (return content))))
+(defclass http-connection (connection)
+ ())
+
+(defmethod open-protocol-connection ((uri uri) (protocol (eql :http)))
+ (multiple-value-bind (response-code properties socket)
+ (http-open-connection uri "GET")
+ (make-instance 'http-connection
+ :socket socket
+ :status response-code
+ :properties properties)))
+
+(defmethod close-connection ((connection http-connection))
+ (close-socket (connection-socket connection)))
+
+#|
(register-uri-input-stream-handler :http
(lambda (uri)
(http-open-connection uri "GET"))
(lambda (socket)
(socket-close socket)))
+|#
\ No newline at end of file
Index: unetwork/src/nntp.lisp
diff -u unetwork/src/nntp.lisp:1.2 unetwork/src/nntp.lisp:1.3
--- unetwork/src/nntp.lisp:1.2 Fri Mar 12 12:12:04 2004
+++ unetwork/src/nntp.lisp Tue Mar 23 08:02:21 2004
@@ -12,13 +12,13 @@
(in-package :unetwork)
-(unless (boundp '+nntp-default-port)
- (defconstant +nntp-default-port 119))
+(unless (boundp '+nntp-default-port+)
+ (defconstant +nntp-default-port+ 119))
(defun nntp-open-connection (server user password
&optional (port +nntp-default-port))
"Open a connection to a NNTP server. Returns the connection socket."
- (let ((socket (socket-open server port :type :text)))
+ (let ((socket (open-socket server port :type :text)))
(unless (null user)
(nntp-handle-command socket "AUTHINFO USER" (list user)
:expect '("281" "381")))
@@ -31,7 +31,7 @@
"Close a connection to a NNTP server."
(let ((stream (socket-stream socket)))
(format stream "CLOSE~%"))
- (socket-close socket))
+ (close-socket socket))
(defun nntp-get-groups (socket)
"Get the list of all groups on the server. Returns a list of lists
Index: unetwork/src/package.lisp
diff -u unetwork/src/package.lisp:1.2 unetwork/src/package.lisp:1.3
--- unetwork/src/package.lisp:1.2 Fri Mar 12 12:11:03 2004
+++ unetwork/src/package.lisp Tue Mar 23 08:02:21 2004
@@ -20,6 +20,28 @@
#:authenticate-error
#:protocol-error
+ #:socket
+ #:socket-sock
+ #:socket-stream
+
+ #:connection
+ #:connection-socket
+ #:connection-status
+ #:connection-properties
+ #:open-connection
+
+ #:document
+ #:document-properties
+ #:document-text
+
+ #:resolve-host-ip
+ #:socket
+ #:open-socket
+ #:close-socket
+ #:open-server-socket
+ #:close-server-socket
+ #:server-socket-accept
+
#:uri
#:uri-scheme
#:uri-host
@@ -36,24 +58,12 @@
#:with-uri-input-stream
- #:resolve-host-ip
- #:socket
- #:socket-open
- #:socket-close
- #:server-socket-open
- #:server-socket-close
- #:server-socket-accept
-
- #:document
- #:document-properties
- #:document-text
-
#:+http-default-port+
#:http-ensure-url-port-path
#:http-get
#:http-head
- #:+pop3-default-port
+ #:+pop3-default-port+
#:pop3-open-connection
#:pop3-close-connection
#:pop3-authenticate
Index: unetwork/src/pop3.lisp
diff -u unetwork/src/pop3.lisp:1.2 unetwork/src/pop3.lisp:1.3
--- unetwork/src/pop3.lisp:1.2 Fri Mar 12 12:12:04 2004
+++ unetwork/src/pop3.lisp Tue Mar 23 08:02:21 2004
@@ -23,7 +23,7 @@
(defun pop3-open-connection (server &optional (port +pop3-default-port+))
"Open a connection to a POP3 server. Returns the connection socket."
- (let* ((socket (socket-open server port :type :text))
+ (let* ((socket (open-socket server port :type :text))
(stream (socket-stream socket)))
(loop as line = (trim-line (read-line stream nil nil))
until (or (null line)
@@ -73,7 +73,7 @@
(pop3-authenticate ,socket ,user ,password)
, at body
(ignore-errors (pop3-close-connection ,socket)))
- (socket-close ,socket))))
+ (close-socket ,socket))))
(defun pop3-handle-command (socket command &rest params)
(handle-simple-command "POP3" socket command params
Index: unetwork/src/smtp.lisp
diff -u unetwork/src/smtp.lisp:1.2 unetwork/src/smtp.lisp:1.3
--- unetwork/src/smtp.lisp:1.2 Fri Mar 12 12:12:04 2004
+++ unetwork/src/smtp.lisp Tue Mar 23 08:02:21 2004
@@ -17,7 +17,7 @@
(defun smtp-open-connection (server &optional (port +smtp-default-port+))
"Open a connection to a SMTP server. Returns the connection socket."
- (let* ((socket (socket-open server port :type :text))
+ (let* ((socket (open-socket server port :type :text))
(stream (socket-stream socket)))
(read-line stream)
socket))
@@ -27,7 +27,7 @@
(let ((stream (socket-stream socket)))
(format stream "QUIT~%")
(finish-output stream))
- (socket-close socket))
+ (close-socket socket))
(defun smtp-send-mail (socket sender recipients subject data)
"Send a mail from SENDER (an email address) to RECIPIENTS (a list
Index: unetwork/src/unetwork.asd
diff -u unetwork/src/unetwork.asd:1.3 unetwork/src/unetwork.asd:1.4
--- unetwork/src/unetwork.asd:1.3 Thu Mar 18 07:30:14 2004
+++ unetwork/src/unetwork.asd Tue Mar 23 08:02:21 2004
@@ -17,7 +17,10 @@
(defsystem unetwork-base
:components ((:file "package")
- (:file "errors")))
+ (:file "errors")
+ (:file "utilities")
+ (:file "document" :depends-on ("utilities"))
+ (:file "socket")))
(defsystem unetwork-cmu
:depends-on (:unetwork-base)
@@ -32,10 +35,8 @@
:depends-on (:puri
#+cmu :unetwork-cmu
#+sbcl :unetwork-sbcl)
- :components ((:file "utilities")
- (:file "url")
+ :components ((:file "url")
(:file "uri-streams")
- (:file "document" :depends-on ("utilities"))
(:file "http" :depends-on ("uri-streams"))
(:file "pop3")
(:file "smtp")
Index: unetwork/src/uri-streams.lisp
diff -u unetwork/src/uri-streams.lisp:1.1 unetwork/src/uri-streams.lisp:1.2
--- unetwork/src/uri-streams.lisp:1.1 Fri Mar 12 09:46:38 2004
+++ unetwork/src/uri-streams.lisp Tue Mar 23 08:02:21 2004
@@ -14,32 +14,19 @@
(defparameter *uri-input-stream-handlers* '())
-(defun register-uri-input-stream-handler (scheme opener closer)
- "Registers input stream handler functions for a protocol (SCHEME).
-OPENER must take an URI as argument and return two functions:
-stream properties as an assoc list, and socket.
-CLOSER must take a socket as argument and take necessary
-actions in order to terminate the session."
- (push (cons scheme (list opener closer)) *uri-input-stream-handlers*))
-
-(defmacro with-uri-input-stream ((stream uri-string
- &optional response-code properties)
+(defmacro with-uri-input-stream ((stream uri-string &optional status properties)
&body body)
- "Opens an input stream to the resource at a given uri. Resource properties
-are bound to the variable PROPERTIES, if provided. Evaluates the BODY
-forms in an implicit PROGN, then closes the stream."
- (with-gensyms (uri socket scheme functions)
+ "Opens an input stream to the resource at a given uri. Initial connection
+status and resource properties are bound to the variables STATUS and
+PROPERTIES, if provided. Evaluates the BODY forms in an implicit PROGN,
+then closes the stream."
+ (with-gensyms (uri socket connection)
`(let* ((,uri (parse-uri ,uri-string))
- (,scheme (uri-scheme ,uri))
- (,functions (cdr (assoc ,scheme *uri-input-stream-handlers*))))
- (assert (not (null ,functions)))
- (let ((socket-opener (first ,functions))
- (socket-closer (second ,functions)))
- (multiple-value-bind (,(or response-code (gensym))
- ,(or properties (gensym))
- ,socket)
- (funcall socket-opener ,uri)
- (unwind-protect
- (let ((,stream (socket-stream ,socket)))
- , at body)
- (funcall socket-closer ,socket)))))))
+ (,connection (open-connection ,uri))
+ (,(or status (gensym)) (connection-status ,connection))
+ (,(or properties (gensym)) (connection-properties ,connection))
+ (,socket (connection-socket ,connection)))
+ (unwind-protect
+ (let ((,stream (socket-stream ,socket)))
+ , at body)
+ (close-connection ,connection)))))
More information about the Unetwork-cvs
mailing list