PageRenderTime 44ms CodeModel.GetById 19ms RepoModel.GetById 0ms app.codeStats 0ms

/asdf-systems/acl-compat/clisp/acl-socket.lisp

https://bitbucket.org/mt/biobike
Lisp | 174 lines | 140 code | 28 blank | 6 comment | 4 complexity | fe3b50814adaeca17987511a8e2a8e9e MD5 | raw file
Possible License(s): LGPL-2.1, BSD-3-Clause
  1. ;; This package is designed for clisp. It implements the
  2. ;; ACL-style socket interface on top of clisp.
  3. ;;
  4. ;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt
  5. ;; for Lispworks and net.lisp in the port library of CLOCC.
  6. (in-package :acl-socket)
  7. (defclass server-socket ()
  8. ((port :type fixnum
  9. :initarg :port
  10. :reader port)
  11. (stream-type :type (member :text :binary :bivalent)
  12. :initarg :stream-type
  13. :reader stream-type
  14. :initform (error "No value supplied for stream-type"))
  15. (clisp-socket-server :initarg :clisp-socket-server
  16. :reader clisp-socket-server)))
  17. (defmethod print-object ((server-socket server-socket) stream)
  18. (print-unreadable-object (server-socket stream :type t :identity nil)
  19. (format stream "@port ~d" (port server-socket))))
  20. (defun %get-element-type (format)
  21. (ecase format
  22. (:text 'character)
  23. (:binary '(unsigned-byte 8))
  24. (:bivalent '(unsigned-byte 8))) )
  25. (defgeneric accept-connection (server-socket &key wait))
  26. (defmethod accept-connection ((server-socket server-socket)
  27. &key (wait t))
  28. "Return a bidirectional stream connected to socket, or nil if no
  29. client wanted to initiate a connection and wait is nil."
  30. (when (cond ((numberp wait)
  31. (socket-wait (clisp-socket-server server-socket) wait))
  32. (wait (socket-wait (clisp-socket-server server-socket)))
  33. (t (socket-wait (clisp-socket-server server-socket) 0)))
  34. (let ((stream (socket-accept (clisp-socket-server server-socket)
  35. :element-type (%get-element-type
  36. (stream-type server-socket))
  37. )))
  38. (if (eq (stream-type server-socket) :bivalent)
  39. (make-bivalent-stream stream)
  40. stream))))
  41. (defun make-socket (&key (remote-host "localhost")
  42. local-port
  43. remote-port
  44. (connect :active)
  45. (format :text)
  46. &allow-other-keys)
  47. "Return a stream connected to remote-host if connect is :active, or
  48. something listening on local-port that can be fed to accept-connection
  49. if connect is :passive."
  50. (check-type remote-host string)
  51. (ecase connect
  52. (:passive
  53. (make-instance 'server-socket
  54. :port local-port
  55. :clisp-socket-server (socket-server local-port)
  56. :stream-type format))
  57. (:active
  58. (let ((stream (socket-connect
  59. remote-port remote-host
  60. :element-type (%get-element-type format)
  61. )))
  62. (if (eq format :bivalent)
  63. (make-bivalent-stream stream)
  64. stream)))))
  65. (defmethod close ((server-socket server-socket) &key abort)
  66. "Kill a passive (listening) socket. (Active sockets are actually
  67. streams and handled by their close methods."
  68. (declare (ignore abort))
  69. (socket-server-close (clisp-socket-server server-socket)))
  70. (declaim (ftype (function ((unsigned-byte 32)) (values simple-string))
  71. ipaddr-to-dotted))
  72. (defun ipaddr-to-dotted (ipaddr &key values)
  73. (declare (type (unsigned-byte 32) ipaddr))
  74. (let ((a (logand #xff (ash ipaddr -24)))
  75. (b (logand #xff (ash ipaddr -16)))
  76. (c (logand #xff (ash ipaddr -8)))
  77. (d (logand #xff ipaddr)))
  78. (if values
  79. (values a b c d)
  80. (format nil "~d.~d.~d.~d" a b c d))))
  81. (defun string-tokens (string)
  82. (labels ((get-token (str pos1 acc)
  83. (let ((pos2 (position #\Space str :start pos1)))
  84. (if (not pos2)
  85. (nreverse acc)
  86. (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2))
  87. acc))))))
  88. (get-token (concatenate 'string string " ") 0 nil)))
  89. (declaim (ftype (function (string &key (:errorp t))
  90. (values (unsigned-byte 32)))
  91. dotted-to-ipaddr))
  92. (defun dotted-to-ipaddr (dotted &key (errorp t))
  93. (declare (string dotted))
  94. (if errorp
  95. (let ((ll (string-tokens (substitute #\Space #\. dotted))))
  96. (+ (ash (first ll) 24) (ash (second ll) 16)
  97. (ash (third ll) 8) (fourth ll)))
  98. (ignore-errors
  99. (let ((ll (string-tokens (substitute #\Space #\. dotted))))
  100. (+ (ash (first ll) 24) (ash (second ll) 16)
  101. (ash (third ll) 8) (fourth ll))))))
  102. (defun ipaddr-to-hostname (ipaddr &key ignore-cache)
  103. (when ignore-cache
  104. (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported."))
  105. (posix::hostent-name (posix:resolve-host-ipaddr ipaddr)))
  106. (defun lookup-hostname (host &key ignore-cache)
  107. (when ignore-cache
  108. (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
  109. (if (stringp host)
  110. (car (posix::hostent-addr-list (posix:resolve-host-ipaddr host)))
  111. (dotted-to-ipaddr (ipaddr-to-dotted host))))
  112. (defgeneric get-clisp-stream (stream))
  113. (defmethod get-clisp-stream ((stream gray-stream::native-lisp-stream-mixin))
  114. (gray-stream::native-lisp-stream stream))
  115. (defmethod get-clisp-stream ((stream t))
  116. (the stream stream))
  117. (defun remote-host (socket-stream)
  118. (dotted-to-ipaddr
  119. (nth-value 0 (socket-stream-peer (get-clisp-stream socket-stream) t))))
  120. (defun remote-port (socket-stream)
  121. (nth-value 1 (socket-stream-peer (get-clisp-stream socket-stream) t)))
  122. (defun local-host (socket-stream)
  123. (dotted-to-ipaddr
  124. (nth-value 0 (socket-stream-local (get-clisp-stream socket-stream) t))))
  125. (defun local-port (socket-stream)
  126. (nth-value 1 (socket-stream-local (get-clisp-stream socket-stream) t)))
  127. ;; Now, throw chunking in the mix
  128. (defclass chunked-stream (de.dataheaven.chunked-stream-mixin::chunked-stream-mixin
  129. gray-stream::buffered-bivalent-stream)
  130. ((plist :initarg :plist :accessor stream-plist)))
  131. (defun make-bivalent-stream (lisp-stream &key plist)
  132. (make-instance 'chunked-stream :lisp-stream lisp-stream :plist plist))
  133. (defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p))
  134. (when oc-p
  135. (when output-chunking
  136. (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream))
  137. (setf (de.dataheaven.chunked-stream-mixin::output-chunking-p stream)
  138. output-chunking))
  139. (when output-chunking-eof
  140. (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream))
  141. (when ic-p
  142. (when input-chunking
  143. (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream))
  144. (setf (de.dataheaven.chunked-stream-mixin::input-chunking-p stream)
  145. input-chunking)))
  146. (provide 'acl-socket)