sockets/namedb/services.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
   2 ;;;
   3 ;;; services.lisp --- Service lookup.
   4 ;;;
   5 ;;; Copyright (C) 2006-2007, Stelian Ionescu  <sionescu@common-lisp.net>
   6 ;;;
   7 ;;; This code is free software; you can redistribute it and/or
   8 ;;; modify it under the terms of the version 2.1 of
   9 ;;; the GNU Lesser General Public License as published by
  10 ;;; the Free Software Foundation, as clarified by the
  11 ;;; preamble found here:
  12 ;;;     http://opensource.franz.com/preamble.html
  13 ;;;
  14 ;;; This program is distributed in the hope that it will be useful,
  15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;;; GNU General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU Lesser General
  20 ;;; Public License along with this library; if not, write to the
  21 ;;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  22 ;;; Boston, MA 02110-1301, USA
  23
  24 (in-package :net.sockets)
  25
  26 (defvar *services-file* "/etc/services")
  27
  28 (defclass service ()
  29   ((name :initarg :name :reader service-name
  30          :documentation "The service name.")
  31    (port :initarg :port :reader service-port
  32          :documentation "The service's default port.")
  33    (protocol :initarg :protocol :reader service-protocol
  34              :documentation "The service's protocol, :TCP or :UDP."))
  35   (:documentation "Class representing a service."))
  36
  37 (defun make-service (name port protocol)
  38   "Constructor for SERVICE objects."
  39   (let ((port (cond ((numberp port) port)
  40                     ((string  port) (parse-integer port))))
  41         (protocol (cond ((keywordp protocol) protocol)
  42                         ((stringp protocol)  (make-keyword
  43                                               (string-upcase protocol))))))
  44     (make-instance 'service :name name :port port :protocol protocol)))
  45
  46 (defmethod print-object ((service service) stream)
  47   (print-unreadable-object (service stream :type t :identity nil)
  48     (with-slots (name port protocol) service
  49       (format stream "Name: ~A Port: ~A Protocol: ~A" name port protocol))))
  50
  51 (defun split-port/proto (port/proto)
  52   (let ((pos (position #\/ port/proto)))
  53     (unless pos (error 'parse-error))
  54     (values (subseq port/proto 0 pos)
  55             (subseq port/proto (1+ pos)))))
  56
  57 (defun protocol-compatible-p (protocol thing)
  58   (case protocol
  59     (:any t)
  60     (:tcp (eq :tcp (make-keyword (string-upcase thing))))
  61     (:udp (eq :udp (make-keyword (string-upcase thing))))))
  62
  63 (defun find-service-in-parsed-lines (tokens predicate)
  64   (when (< (length tokens) 2) (error 'parse-error))
  65   (destructuring-bind (name port/proto &rest aliases) tokens
  66     (multiple-value-bind (port proto) (split-port/proto port/proto)
  67       (when (funcall predicate name port proto aliases)
  68         (make-service name port proto)))))
  69
  70 (defun lookup-service-on-disk-by-number (file service protocol)
  71   (flet ((good-proto-p (name port proto aliases)
  72            (declare (ignore name aliases))
  73            (let ((pnum (parse-integer port)))
  74              (and (protocol-compatible-p protocol proto)
  75                   (= pnum service)))))
  76     (iterate ((tokens (serialize-etc-file file)))
  77       (ignore-parse-errors
  78         (let ((proto (find-service-in-parsed-lines tokens #'good-proto-p)))
  79           (when proto (return-from lookup-service-on-disk-by-number
  80                         proto)))))))
  81
  82 (defun lookup-service-on-disk-by-name (file service protocol)
  83   (flet ((good-proto-p (name port proto aliases)
  84            (declare (ignore port))
  85            (and (protocol-compatible-p protocol proto)
  86                 (or (string= service name)
  87                     (member service aliases :test #'string=)))))
  88     (iterate ((tokens (serialize-etc-file file)))
  89       (ignore-parse-errors
  90         (let ((proto (find-service-in-parsed-lines tokens #'good-proto-p)))
  91           (when proto (return-from lookup-service-on-disk-by-name
  92                         proto)))))))
  93
  94 (define-condition unknown-service ()
  95   ((name :initarg :name :initform nil :reader unknown-service-name))
  96   (:report (lambda (condition stream)
  97              (format stream "Unknown service: ~S" (unknown-service-name condition))))
  98   (:documentation "Condition raised when a network service is not found."))
  99
 100 (defvar *tcp-services-cache-by-name*   (make-hash-table :test #'equal))
 101 (defvar *tcp-services-cache-by-number* (make-hash-table :test #'eql))
 102 (defvar *udp-services-cache-by-name*   (make-hash-table :test #'equal))
 103 (defvar *udp-services-cache-by-number* (make-hash-table :test #'eql))
 104 (defvar *services-cache-lock* (bt:make-lock "/etc/services cache lock"))
 105
 106 (defun find-service-name-in-cache (thing protocol)
 107   (ecase protocol
 108     (:tcp (gethash thing *tcp-services-cache-by-name*))
 109     (:udp (gethash thing *udp-services-cache-by-name*))
 110     (:any (or (gethash thing *tcp-services-cache-by-name*)
 111               (gethash thing *udp-services-cache-by-name*)))))
 112
 113 (defun find-service-number-in-cache (thing protocol)
 114   (ecase protocol
 115     (:tcp (gethash thing *tcp-services-cache-by-number*))
 116     (:udp (gethash thing *udp-services-cache-by-number*))
 117     (:any (or (gethash thing *tcp-services-cache-by-number*)
 118               (gethash thing *udp-services-cache-by-number*)))))
 119
 120 (defun find-service (thing protocol cache-fn disk-fn)
 121   (or (funcall cache-fn thing protocol)
 122       (let ((service (funcall disk-fn *services-file* thing protocol)))
 123         (flet ((get-cache (type)
 124                  (ecase type
 125                    (:name (ecase (service-protocol service)
 126                             (:tcp *tcp-services-cache-by-name*)
 127                             (:udp *udp-services-cache-by-name*)))
 128                    (:number (ecase (service-protocol service)
 129                               (:tcp *tcp-services-cache-by-number*)
 130                               (:udp *udp-services-cache-by-number*))))))
 131           (when service
 132             (setf (gethash (service-name service) (get-cache :name))
 133                   service)
 134             (setf (gethash (service-port service) (get-cache :number))
 135                   service)
 136             (values service))))))
 137
 138 (defun lookup-service-by-name (thing protocol)
 139   (bt:with-lock-held (*services-cache-lock*)
 140     (find-service thing protocol
 141                   #'find-service-name-in-cache
 142                   #'lookup-service-on-disk-by-name)))
 143
 144 (defun lookup-service-by-number (thing protocol)
 145   (bt:with-lock-held (*services-cache-lock*)
 146     (find-service thing protocol
 147                   #'find-service-number-in-cache
 148                   #'lookup-service-on-disk-by-number)))
 149
 150 (defun purge-services-cache (&optional file)
 151   (declare (ignore file))
 152   (map 'nil #'clrhash (list *tcp-services-cache-by-name*
 153                             *tcp-services-cache-by-number*
 154                             *udp-services-cache-by-name*
 155                             *udp-services-cache-by-number*)))
 156
 157 (defvar *services-monitor*
 158   (make-instance 'file-monitor
 159                  :file *services-file*
 160                  :update-fn 'purge-services-cache
 161                  :lock *services-cache-lock*))
 162
 163 (deftype tcp-port ()
 164   '(unsigned-byte 16))
 165
 166 (defun lookup-service (service &optional (protocol :tcp))
 167   "Lookup a service by port or name.  PROTOCOL should be one
 168 of :TCP, :UDP or :ANY."
 169   (check-type service (or tcp-port string symbol) "an '(unsigned-byte 16), a string or a symbol")
 170   (check-type protocol (member :tcp :udp :any) "one of :TCP, :UDP or :ANY")
 171   (update-monitor *services-monitor*)
 172   (let* ((service (ensure-string-or-unsigned-byte service :ub16))
 173          (serv (etypecase service
 174                  (tcp-port (lookup-service-by-number service protocol))
 175                  (string   (lookup-service-by-name service protocol)))))
 176     (if serv (values (service-port serv)
 177                      (service-name serv)
 178                      (service-protocol serv))
 179         (error 'unknown-service :name service))))
 180
 181 (defun ensure-numerical-service (service &optional (protocol :tcp))
 182   (etypecase service
 183     (tcp-port service)
 184     (t        (nth-value 0 (lookup-service service protocol)))))