sockets.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          sockets.lisp
   6 ;;;; Purpose:       Socket functions
   7 ;;;; Programmer:    Kevin M. Rosenberg with excerpts from portableaserve
   8 ;;;; Date Started:  Jun 2003
   9 ;;;; *************************************************************************
  10
  11 (in-package #:kmrcl)
  12
  13 (eval-when (:compile-toplevel :load-toplevel :execute)
  14   #+sbcl (require :sb-bsd-sockets)
  15   #+lispworks (require "comm")
  16   #+allegro (require :socket))
  17
  18
  19 #+sbcl
  20 (defun listen-to-inet-port (&key (port 0) (kind :stream) (reuse nil))
  21   "Create, bind and listen to an inet socket on *:PORT.
  22 setsockopt SO_REUSEADDR if :reuse is not nil"
  23   (declare (ignore kind))
  24   (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
  25                                :type :stream
  26                                :protocol :tcp)))
  27     (if reuse
  28         (setf (sb-bsd-sockets:sockopt-reuse-address socket) t))
  29     (sb-bsd-sockets:socket-bind
  30      socket (sb-bsd-sockets:make-inet-address "0.0.0.0") port)
  31     (sb-bsd-sockets:socket-listen socket 15)
  32     socket))
  33
  34 (defun create-inet-listener (port &key (format :text) (reuse-address t))
  35   #+cmu (declare (ignore format reuse-address))
  36   #+cmu (ext:create-inet-listener port)
  37   #+allegro
  38   (socket:make-socket :connect :passive :local-port port :format format
  39                       :address-family
  40                       (if (stringp port)
  41                           :file
  42                         (if (or (null port) (integerp port))
  43                             :internet
  44                           (error "illegal value for port: ~s" port)))
  45                       :reuse-address reuse-address)
  46   #+sbcl (declare (ignore format))
  47   #+sbcl (listen-to-inet-port :port port :reuse reuse-address)
  48   #+clisp (declare (ignore format reuse-address))
  49   #+clisp (ext:socket-server port)
  50   #+openmcl
  51   (declare (ignore format))
  52   #+openmcl
  53   (ccl:make-socket :connect :passive :local-port port
  54                    :reuse-address reuse-address)
  55   #-(or allegro clisp cmu sbcl openmcl)
  56   (warn "create-inet-listener not supported on this implementation")
  57   )
  58
  59 (defun make-fd-stream (socket &key input output element-type)
  60   #+cmu
  61   (sys:make-fd-stream socket :input input :output output
  62                       :element-type element-type)
  63   #+sbcl
  64   (sb-bsd-sockets:socket-make-stream socket :input input :output output
  65                                      :element-type element-type)
  66   #-(or cmu sbcl) (declare (ignore input output element-type))
  67   #-(or cmu sbcl) socket
  68   )
  69
  70
  71 (defun accept-tcp-connection (listener)
  72   "Returns (VALUES stream socket)"
  73   #+allegro
  74   (let ((sock (socket:accept-connection listener)))
  75     (values sock sock))
  76   #+clisp
  77   (let ((sock (ext:socket-accept listener)))
  78     (values sock sock))
  79   #+cmu
  80   (progn
  81     (mp:process-wait-until-fd-usable listener :input)
  82     (let ((sock (nth-value 0 (ext:accept-tcp-connection listener))))
  83       (values (sys:make-fd-stream sock :input t :output t) sock)))
  84   #+sbcl
  85   (when (sb-sys:wait-until-fd-usable
  86          (sb-bsd-sockets:socket-file-descriptor listener) :input)
  87     (let ((sock (sb-bsd-sockets:socket-accept listener)))
  88       (values
  89        (sb-bsd-sockets:socket-make-stream
  90         sock :element-type :default :input t :output t)
  91        sock)))
  92   #+openmcl
  93   (let ((sock (ccl:accept-connection listener :wait t)))
  94     (values sock sock))
  95   #-(or allegro clisp cmu sbcl openmcl)
  96   (warn "accept-tcp-connection not supported on this implementation")
  97   )
  98
  99
 100 (defmacro errorset (form display)
 101   `(handler-case
 102     ,form
 103     (error (e)
 104      (declare (ignorable e))
 105      (when ,display
 106        (format t "~&Error: ~A~%" e)))))
 107
 108 (defun close-passive-socket (socket)
 109   #+allegro (close socket)
 110   #+clisp (ext:socket-server-close socket)
 111   #+cmu (unix:unix-close socket)
 112   #+sbcl (sb-unix:unix-close
 113           (sb-bsd-sockets:socket-file-descriptor socket))
 114   #+openmcl (close socket)
 115   #-(or allegro clisp cmu sbcl openmcl)
 116   (warn "close-passive-socket not supported on this implementation")
 117   )
 118
 119
 120 (defun close-active-socket (socket)
 121   #+sbcl (sb-bsd-sockets:socket-close socket)
 122   #-sbcl (close socket))
 123
 124 (defun ipaddr-to-dotted (ipaddr &key values)
 125   "Convert from 32-bit integer to dotted string."
 126   (declare (type (unsigned-byte 32) ipaddr))
 127   (let ((a (logand #xff (ash ipaddr -24)))
 128         (b (logand #xff (ash ipaddr -16)))
 129         (c (logand #xff (ash ipaddr -8)))
 130         (d (logand #xff ipaddr)))
 131     (if values
 132         (values a b c d)
 133       (format nil "~d.~d.~d.~d" a b c d))))
 134
 135 (defun dotted-to-ipaddr (dotted &key (errorp t))
 136   "Convert from dotted string to 32-bit integer."
 137   (declare (string dotted))
 138   (if errorp
 139       (let ((ll (delimited-string-to-list dotted #\.)))
 140         (+ (ash (parse-integer (first ll)) 24)
 141            (ash (parse-integer (second ll)) 16)
 142            (ash (parse-integer (third ll)) 8)
 143            (parse-integer (fourth ll))))
 144     (ignore-errors
 145       (let ((ll (delimited-string-to-list dotted #\.)))
 146         (+ (ash (parse-integer (first ll)) 24)
 147            (ash (parse-integer (second ll)) 16)
 148            (ash (parse-integer (third ll)) 8)
 149            (parse-integer (fourth ll)))))))
 150
 151 #+sbcl
 152 (defun ipaddr-to-hostname (ipaddr &key ignore-cache)
 153   (when ignore-cache
 154     (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported."))
 155   (sb-bsd-sockets:host-ent-name
 156    (sb-bsd-sockets:get-host-by-address
 157     (sb-bsd-sockets:make-inet-address ipaddr))))
 158
 159 #+sbcl
 160 (defun lookup-hostname (host &key ignore-cache)
 161   (when ignore-cache
 162     (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
 163   (if (stringp host)
 164       (sb-bsd-sockets:host-ent-address
 165        (sb-bsd-sockets:get-host-by-name host))
 166       (dotted-to-ipaddr (ipaddr-to-dotted host))))
 167
 168
 169 (defun make-active-socket (server port)
 170   "Returns (VALUES STREAM SOCKET)"
 171   #+allegro
 172   (let ((sock (socket:make-socket :remote-host server
 173                                   :remote-port port)))
 174     (values sock sock))
 175   #+lispworks
 176   (let ((sock (comm:open-tcp-stream server port)))
 177     (values sock sock))
 178   #+sbcl
 179   (let ((sock (make-instance 'sb-bsd-sockets:inet-socket
 180                              :type :stream
 181                              :protocol :tcp)))
 182     (sb-bsd-sockets:socket-connect sock (lookup-hostname server) port)
 183     (values
 184      (sb-bsd-sockets:socket-make-stream
 185       sock :input t :output t :element-type :default)
 186      sock))
 187   #+cmu
 188   (let ((sock (ext:connect-to-inet-socket server port)))
 189     (values
 190      (sys:make-fd-stream sock :input t :output t :element-type 'base-char)
 191      sock))
 192   #+clisp
 193   (let ((sock (ext:socket-connect port server)))
 194     (values sock sock))
 195   #+openmcl
 196   (let ((sock (ccl:make-socket :remote-host server :remote-port port )))
 197     (values sock sock))
 198   )
 199
 200 (defun ipaddr-array-to-dotted (array)
 201   (format nil "~{~D~^.~}" (coerce array 'list))
 202   #+ignore
 203   (format nil "~D.~D.~D.~D"
 204           (aref 0 array) (aref 1 array) (aref 2 array) (array 3 array)))
 205
 206 (defun remote-host (socket)
 207   #+allegro (socket:ipaddr-to-dotted (socket:remote-host socket))
 208   #+lispworks (nth-value 0 (comm:get-socket-peer-address socket))
 209   #+sbcl (ipaddr-array-to-dotted
 210           (nth-value 0 (sb-bsd-sockets:socket-peername socket)))
 211   #+cmu (nth-value 0 (ext:get-peer-host-and-port socket))
 212   #+clisp (let* ((peer (ext:socket-stream-peer socket t))
 213                 (stop (position #\Space peer)))
 214            ;; 2.37-2.39 had do-not-resolve-p backwards
 215            (if stop (subseq peer 0 stop) peer))
 216   #+openmcl (ccl:remote-host socket)
 217   )
 218