net.sockets/namedb/services.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; services.lisp --- Service lookup.
   4 ;;;
   5
   6 (in-package :net.sockets)
   7
   8 (defvar *services-file* "/etc/services")
   9
  10 (defclass service ()
  11   ((name :initarg :name :reader service-name
  12          :documentation "The service name.")
  13    (port :initarg :port :reader service-port
  14          :documentation "The service's default port.")
  15    (protocol :initarg :protocol :reader service-protocol
  16              :documentation "The service's protocol, :TCP or :UDP."))
  17   (:documentation "Class representing a service."))
  18
  19 (defun make-service (name port protocol)
  20   "Constructor for SERVICE objects."
  21   (let ((port (cond ((numberp port) port)
  22                     ((string  port) (parse-integer port))))
  23         (protocol (cond ((keywordp protocol) protocol)
  24                         ((stringp protocol)  (make-keyword
  25                                               (string-upcase protocol))))))
  26     (make-instance 'service :name name :port port :protocol protocol)))
  27
  28 (defmethod print-object ((service service) stream)
  29   (print-unreadable-object (service stream :type t :identity nil)
  30     (with-slots (name port protocol) service
  31       (format stream "Name: ~A Port: ~A Protocol: ~A" name port protocol))))
  32
  33 (defun split-port/proto (port/proto)
  34   (let ((pos (position #\/ port/proto)))
  35     (unless pos (error 'parse-error))
  36     (values (subseq port/proto 0 pos)
  37             (subseq port/proto (1+ pos)))))
  38
  39 (defun protocol-compatible-p (protocol thing)
  40   (case protocol
  41     (:any t)
  42     (:tcp (eq :tcp (make-keyword (string-upcase thing))))
  43     (:udp (eq :udp (make-keyword (string-upcase thing))))))
  44
  45 (defun find-service-in-parsed-lines (tokens predicate)
  46   (when (< (length tokens) 2) (error 'parse-error))
  47   (destructuring-bind (name port/proto &rest aliases) tokens
  48     (multiple-value-bind (port proto) (split-port/proto port/proto)
  49       (when (funcall predicate name port proto aliases)
  50         (make-service name port proto)))))
  51
  52 (defun lookup-service-on-disk-by-number (file service protocol)
  53   (flet ((good-proto-p (name port proto aliases)
  54            (declare (ignore name aliases))
  55            (let ((pnum (parse-integer port)))
  56              (and (protocol-compatible-p protocol proto)
  57                   (= pnum service)))))
  58     (iterate ((tokens (serialize-etc-file file)))
  59       (ignore-parse-errors
  60         (let ((proto (find-service-in-parsed-lines tokens #'good-proto-p)))
  61           (when proto (return-from lookup-service-on-disk-by-number
  62                         proto)))))))
  63
  64 (defun lookup-service-on-disk-by-name (file service protocol)
  65   (flet ((good-proto-p (name port proto aliases)
  66            (declare (ignore port))
  67            (and (protocol-compatible-p protocol proto)
  68                 (or (string= service name)
  69                     (member service aliases :test #'string=)))))
  70     (iterate ((tokens (serialize-etc-file file)))
  71       (ignore-parse-errors
  72         (let ((proto (find-service-in-parsed-lines tokens #'good-proto-p)))
  73           (when proto (return-from lookup-service-on-disk-by-name
  74                         proto)))))))
  75
  76 (define-condition unknown-service ()
  77   ((datum :initarg :datum :initform nil :reader unknown-service-datum))
  78   (:report (lambda (condition stream)
  79              (format stream "Unknown service: ~S" (unknown-service-datum condition))))
  80   (:documentation "Condition raised when a network service is not found."))
  81 (setf (documentation 'unknown-service-datum 'function)
  82       "Return the datum that caused the signalling of an UNKNOWN-SERVICE condition.")
  83
  84 (defvar *tcp-services-cache-by-name*   (make-hash-table :test #'equal))
  85 (defvar *tcp-services-cache-by-number* (make-hash-table :test #'eql))
  86 (defvar *udp-services-cache-by-name*   (make-hash-table :test #'equal))
  87 (defvar *udp-services-cache-by-number* (make-hash-table :test #'eql))
  88 (defvar *services-cache-lock* (bt:make-lock "/etc/services cache lock"))
  89
  90 (defun find-service-name-in-cache (thing protocol)
  91   (ecase protocol
  92     (:tcp (gethash thing *tcp-services-cache-by-name*))
  93     (:udp (gethash thing *udp-services-cache-by-name*))
  94     (:any (or (gethash thing *tcp-services-cache-by-name*)
  95               (gethash thing *udp-services-cache-by-name*)))))
  96
  97 (defun find-service-number-in-cache (thing protocol)
  98   (ecase protocol
  99     (:tcp (gethash thing *tcp-services-cache-by-number*))
 100     (:udp (gethash thing *udp-services-cache-by-number*))
 101     (:any (or (gethash thing *tcp-services-cache-by-number*)
 102               (gethash thing *udp-services-cache-by-number*)))))
 103
 104 (defun find-service (thing protocol cache-fn disk-fn)
 105   (or (funcall cache-fn thing protocol)
 106       (let ((service (funcall disk-fn *services-file* thing protocol)))
 107         (flet ((get-cache (type)
 108                  (ecase type
 109                    (:name (ecase (service-protocol service)
 110                             (:tcp *tcp-services-cache-by-name*)
 111                             (:udp *udp-services-cache-by-name*)))
 112                    (:number (ecase (service-protocol service)
 113                               (:tcp *tcp-services-cache-by-number*)
 114                               (:udp *udp-services-cache-by-number*))))))
 115           (when service
 116             (setf (gethash (service-name service) (get-cache :name))
 117                   service)
 118             (setf (gethash (service-port service) (get-cache :number))
 119                   service)
 120             (values service))))))
 121
 122 (defun lookup-service-by-name (thing protocol)
 123   (bt:with-lock-held (*services-cache-lock*)
 124     (find-service thing protocol
 125                   #'find-service-name-in-cache
 126                   #'lookup-service-on-disk-by-name)))
 127
 128 (defun lookup-service-by-number (thing protocol)
 129   (bt:with-lock-held (*services-cache-lock*)
 130     (find-service thing protocol
 131                   #'find-service-number-in-cache
 132                   #'lookup-service-on-disk-by-number)))
 133
 134 (defun purge-services-cache (&optional file)
 135   (declare (ignore file))
 136   (map 'nil #'clrhash (list *tcp-services-cache-by-name*
 137                             *tcp-services-cache-by-number*
 138                             *udp-services-cache-by-name*
 139                             *udp-services-cache-by-number*)))
 140
 141 (defvar *services-monitor*
 142   (make-instance 'file-monitor
 143                  :file *services-file*
 144                  :update-fn 'purge-services-cache
 145                  :lock *services-cache-lock*))
 146
 147 (deftype tcp-port ()
 148   '(unsigned-byte 16))
 149
 150 (defun lookup-service (service &optional (protocol :tcp))
 151   "Lookup a service by port or name.  PROTOCOL should be one
 152 of :TCP, :UDP or :ANY."
 153   (check-type service (or tcp-port string symbol) "a valid port number, a string or a symbol")
 154   (check-type protocol (member :tcp :udp :any) "one of :TCP, :UDP or :ANY")
 155   (update-monitor *services-monitor*)
 156   (let* ((parsed (ensure-string-or-unsigned-byte service :type 'tcp-port :errorp t))
 157          (serv (typecase parsed
 158                  (tcp-port (lookup-service-by-number parsed protocol))
 159                  (string   (lookup-service-by-name parsed protocol)))))
 160     (if serv
 161         (values (service-port serv)
 162                 (service-name serv)
 163                 (service-protocol serv))
 164         (error 'unknown-service :datum service))))
 165
 166 (defun ensure-numerical-service (service &optional (protocol :tcp))
 167   (typecase service
 168     (tcp-port service)
 169     (t        (nth-value 0 (lookup-service service protocol)))))