1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
3 ;;; services.lisp --- Service lookup.
6 (in-package :net.sockets
)
8 (defvar *services-file
* "/etc/services")
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."))
19 (defun make-service (name port protocol
)
20 "Constructor for SERVICE objects."
21 (make-instance 'service
:name name
:port
(parse-integer port
)
22 :protocol
(make-keyword (string-upcase protocol
))))
24 (defmethod print-object ((service service
) stream
)
25 (print-unreadable-object (service stream
:type t
:identity nil
)
26 (with-slots (name port protocol
) service
27 (format stream
"Name: ~A Port: ~A Protocol: ~A" name port protocol
))))
29 (defun split-port/proto
(port/proto
)
30 (let ((pos (position #\
/ port
/proto
)))
31 (unless pos
(error 'parse-error
))
32 (values (subseq port
/proto
0 pos
)
33 (subseq port
/proto
(1+ pos
)))))
35 (defun protocol-compatible-p (protocol thing
)
38 (:tcp
(eq :tcp
(make-keyword (string-upcase thing
))))
39 (:udp
(eq :udp
(make-keyword (string-upcase thing
))))))
41 (defun find-service-in-parsed-lines (tokens predicate
)
42 (when (< (length tokens
) 2) (error 'parse-error
))
43 (destructuring-bind (name port
/proto
&rest aliases
) tokens
44 (multiple-value-bind (port proto
) (split-port/proto port
/proto
)
45 (when (funcall predicate name port proto aliases
)
46 (make-service name port proto
)))))
48 (defun lookup-service-on-disk-by-number (file service protocol
)
49 (flet ((good-proto-p (name port proto aliases
)
50 (declare (ignore name aliases
))
51 (let ((pnum (parse-integer port
)))
52 (and (protocol-compatible-p protocol proto
)
54 (iterate ((tokens (serialize-etc-file file
)))
56 (let ((proto (find-service-in-parsed-lines tokens
#'good-proto-p
)))
57 (when proto
(return* proto
)))))))
59 (defun lookup-service-on-disk-by-name (file service protocol
)
60 (flet ((good-proto-p (name port proto aliases
)
61 (declare (ignore port
))
62 (and (protocol-compatible-p protocol proto
)
63 (or (string= service name
)
64 (member service aliases
:test
#'string
=)))))
65 (iterate ((tokens (serialize-etc-file file
)))
67 (let ((proto (find-service-in-parsed-lines tokens
#'good-proto-p
)))
68 (when proto
(return* proto
)))))))
70 (define-condition unknown-service
()
71 ((datum :initarg
:datum
:initform nil
:reader unknown-service-datum
))
72 (:report
(lambda (condition stream
)
73 (format stream
"Unknown service: ~S" (unknown-service-datum condition
))))
74 (:documentation
"Condition raised when a network service is not found."))
75 (setf (documentation 'unknown-service-datum
'function
)
76 "Return the datum that caused the signalling of an UNKNOWN-SERVICE condition.")
78 (defvar *tcp-service-cache-by-name
* (make-hash-table :test
#'equal
))
79 (defvar *tcp-service-cache-by-number
* (make-hash-table :test
#'eql
))
80 (defvar *udp-service-cache-by-name
* (make-hash-table :test
#'equal
))
81 (defvar *udp-service-cache-by-number
* (make-hash-table :test
#'eql
))
82 (defvar *service-cache-lock
* (bt:make-lock
"/etc/services cache lock"))
84 (defun find-service-name-in-cache (thing protocol
)
86 (:tcp
(gethash thing
*tcp-service-cache-by-name
*))
87 (:udp
(gethash thing
*udp-service-cache-by-name
*))
88 (:any
(or (gethash thing
*tcp-service-cache-by-name
*)
89 (gethash thing
*udp-service-cache-by-name
*)))))
91 (defun find-service-number-in-cache (thing protocol
)
93 (:tcp
(gethash thing
*tcp-service-cache-by-number
*))
94 (:udp
(gethash thing
*udp-service-cache-by-number
*))
95 (:any
(or (gethash thing
*tcp-service-cache-by-number
*)
96 (gethash thing
*udp-service-cache-by-number
*)))))
98 (defun find-service (thing protocol cache-fn disk-fn
)
99 (or (funcall cache-fn thing protocol
)
100 (let ((service (funcall disk-fn
*services-file
* thing protocol
)))
101 (flet ((get-cache (type)
103 (:name
(ecase (service-protocol service
)
104 (:tcp
*tcp-service-cache-by-name
*)
105 (:udp
*udp-service-cache-by-name
*)))
106 (:number
(ecase (service-protocol service
)
107 (:tcp
*tcp-service-cache-by-number
*)
108 (:udp
*udp-service-cache-by-number
*))))))
110 (setf (gethash (service-name service
) (get-cache :name
))
112 (setf (gethash (service-port service
) (get-cache :number
))
114 (values service
))))))
116 (defun lookup-service-by-name (thing protocol
)
117 (bt:with-lock-held
(*service-cache-lock
*)
118 (find-service thing protocol
119 #'find-service-name-in-cache
120 #'lookup-service-on-disk-by-name
)))
122 (defun lookup-service-by-number (thing protocol
)
123 (bt:with-lock-held
(*service-cache-lock
*)
124 (find-service thing protocol
125 #'find-service-number-in-cache
126 #'lookup-service-on-disk-by-number
)))
128 (defun purge-service-cache (&optional file
)
129 (declare (ignore file
))
130 (clrhash *tcp-service-cache-by-name
*)
131 (clrhash *tcp-service-cache-by-number
*)
132 (clrhash *udp-service-cache-by-name
*)
133 (clrhash *udp-service-cache-by-number
*))
135 (defvar *services-monitor
*
136 (make-instance 'file-monitor
137 :file
*services-file
*
138 :update-fn
'purge-service-cache
139 :lock
*service-cache-lock
*))
144 (defun lookup-service (service &optional
(protocol :tcp
))
145 "Lookup a service by port or name. PROTOCOL should be one
146 of :TCP, :UDP or :ANY."
147 (check-type service
(or tcp-port string symbol
) "a valid port number, a string or a symbol")
148 (check-type protocol
(member :tcp
:udp
:any
) "one of :TCP, :UDP or :ANY")
149 (update-monitor *services-monitor
*)
150 (let* ((parsed (ensure-string-or-unsigned-byte service
:type
'tcp-port
:errorp t
))
151 (serv (typecase parsed
152 (tcp-port (lookup-service-by-number parsed protocol
))
153 (string (lookup-service-by-name parsed protocol
)))))
155 (values (service-port serv
)
157 (service-protocol serv
))
158 (error 'unknown-service
:datum service
))))
160 (defun ensure-numerical-service (service &optional
(protocol :tcp
))
163 (t (nth-value 0 (lookup-service service protocol
)))))