src/sockets/trivial-sockets.lisp

   1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Main socket methods.
   4 ;;;
   5
   6 (in-package :common-lisp-user)
   7
   8 (defpackage :iolib.trivial-sockets
   9   (:nicknames :iolib/trivial-sockets)
  10   (:use :iolib.base :iolib.sockets)
  11   (:shadow #:socket-error #:accept-connection)
  12   (:export #:open-stream #:socket-error #:socket-nested-error
  13            #:unsupported #:unsupported-feature
  14            #:open-server #:close-server #:accept-connection
  15            #:with-server))
  16
  17 (in-package :iolib.trivial-sockets)
  18
  19 ;;;;
  20 ;;;; ERRORS
  21 ;;;;
  22
  23 ;; you're using a part of the interface that the implementation doesn't do
  24 (define-condition unsupported (error)
  25   ((feature :initarg :feature :reader unsupported-feature))
  26   (:report (lambda (c s)
  27              (format s "~S does not support trivial-socket feature ~S."
  28                      (lisp-implementation-type) (unsupported-feature c)))))
  29
  30 ;; all-purpose error: host not found, host not responding,
  31 ;; no service on that port, etc
  32 (define-condition socket-error (error)
  33   ((nested-error :initarg :nested-error :reader socket-nested-error)))
  34 \f
  35 ;;;;
  36 ;;;; Main implementation
  37 ;;;;
  38
  39 (defun resolve-hostname (name)
  40   (let ((*ipv6* nil))
  41     (cond
  42       ((eql :any name) +ipv4-unspecified+)
  43       (t (nth-value 0 (ensure-hostname name))))))
  44
  45 (defun open-stream (peer-host peer-port &key
  46                     (local-host :any) (local-port 0)
  47                     (external-format :default)
  48                     (element-type 'character)
  49                     (protocol :tcp))
  50   (declare (ignore element-type))
  51   (unless (eql :tcp protocol)
  52     (error 'unsupported :feature `(:protocol ,protocol)))
  53   (let ((*ipv6* nil))
  54     (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c))))
  55       (make-socket :address-family :internet
  56                    :connect :active
  57                    :type :stream
  58                    :remote-host (resolve-hostname peer-host)
  59                    :remote-port peer-port
  60                    :local-host (resolve-hostname local-host)
  61                    :local-port local-port
  62                    :external-format external-format))))
  63
  64 (defun open-server (&key (host :any) (port 0)
  65                     (reuse-address t)
  66                     (backlog 1)
  67                     (protocol :tcp))
  68   "Returns a SERVER object and the port that was bound, as multiple values."
  69   (unless (eql :tcp protocol)
  70     (error 'unsupported :feature `(:protocol ,protocol)))
  71   (let ((*ipv6* nil))
  72     (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c))))
  73       (let* ((host (if (eql :any host) +ipv4-unspecified+ host))
  74              (socket (make-socket :address-family :internet
  75                                   :type :stream
  76                                   :connect :passive
  77                                   :local-host host
  78                                   :local-port port
  79                                   :reuse-address reuse-address
  80                                   :backlog backlog)))
  81         (values socket (local-port socket))))))
  82
  83 (defun close-server (server)
  84   (close server))
  85
  86 (defun accept-connection (socket &key
  87                           (external-format :default)
  88                           (element-type 'character))
  89   (declare (ignore element-type))       ; bivalent streams
  90   (let ((*ipv6* nil))
  91     (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c))))
  92       (iolib.sockets:accept-connection socket :external-format external-format))))
  93 \f
  94 ;;;;
  95 ;;;; Utilities
  96 ;;;;
  97
  98 (defmacro with-server ((name arguments) &body forms)
  99   `(with-open-stream (,name (open-server ,@arguments))
 100      (locally ,@forms)))