1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
3 ;;; services.lisp --- Service lookup.
6 (in-package :iolib.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
(eql :tcp
(make-keyword (string-upcase thing
))))
39 (:udp
(eql :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 (map-etc-file (lambda (tokens)
56 (let ((proto (find-service-in-parsed-lines tokens
#'good-proto-p
)))
57 (when proto
(return* proto
)))))
60 (defun lookup-service-on-disk-by-name (file service protocol
)
61 (flet ((good-proto-p (name port proto aliases
)
62 (declare (ignore port
))
63 (and (protocol-compatible-p protocol proto
)
64 (or (string= service name
)
65 (member service aliases
:test
#'string
=)))))
66 (map-etc-file (lambda (tokens)
68 (let ((proto (find-service-in-parsed-lines tokens
#'good-proto-p
)))
69 (when proto
(return* proto
)))))
72 (define-condition unknown-service
()
73 ((datum :initarg
:datum
:initform nil
:reader unknown-service-datum
))
74 (:report
(lambda (condition stream
)
75 (format stream
"Unknown service: ~S" (unknown-service-datum condition
))))
76 (:documentation
"Condition raised when a network service is not found."))
77 (setf (documentation 'unknown-service-datum
'function
)
78 "Return the datum that caused the signalling of an UNKNOWN-SERVICE condition.")
80 (defvar *tcp-service-cache-by-name
* (make-hash-table :test
#'equal
))
81 (defvar *tcp-service-cache-by-number
* (make-hash-table :test
#'eql
))
82 (defvar *udp-service-cache-by-name
* (make-hash-table :test
#'equal
))
83 (defvar *udp-service-cache-by-number
* (make-hash-table :test
#'eql
))
84 (defvar *service-cache-lock
* (bt:make-lock
"/etc/services cache lock"))
86 (defun find-service-name-in-cache (thing protocol
)
88 (:tcp
(gethash thing
*tcp-service-cache-by-name
*))
89 (:udp
(gethash thing
*udp-service-cache-by-name
*))
90 (:any
(or (gethash thing
*tcp-service-cache-by-name
*)
91 (gethash thing
*udp-service-cache-by-name
*)))))
93 (defun find-service-number-in-cache (thing protocol
)
95 (:tcp
(gethash thing
*tcp-service-cache-by-number
*))
96 (:udp
(gethash thing
*udp-service-cache-by-number
*))
97 (:any
(or (gethash thing
*tcp-service-cache-by-number
*)
98 (gethash thing
*udp-service-cache-by-number
*)))))
100 (defun find-service (thing protocol cache-fn disk-fn
)
101 (or (funcall cache-fn thing protocol
)
102 (let ((service (funcall disk-fn
*services-file
* thing protocol
)))
103 (flet ((get-cache (type)
105 (:name
(ecase (service-protocol service
)
106 (:tcp
*tcp-service-cache-by-name
*)
107 (:udp
*udp-service-cache-by-name
*)))
108 (:number
(ecase (service-protocol service
)
109 (:tcp
*tcp-service-cache-by-number
*)
110 (:udp
*udp-service-cache-by-number
*))))))
112 (setf (gethash (service-name service
) (get-cache :name
))
114 (setf (gethash (service-port service
) (get-cache :number
))
116 (values service
))))))
118 (defun lookup-service-by-name (thing protocol
)
119 (bt:with-lock-held
(*service-cache-lock
*)
120 (find-service thing protocol
121 #'find-service-name-in-cache
122 #'lookup-service-on-disk-by-name
)))
124 (defun lookup-service-by-number (thing protocol
)
125 (bt:with-lock-held
(*service-cache-lock
*)
126 (find-service thing protocol
127 #'find-service-number-in-cache
128 #'lookup-service-on-disk-by-number
)))
130 (defun purge-service-cache (&optional file
)
131 (declare (ignore file
))
132 (clrhash *tcp-service-cache-by-name
*)
133 (clrhash *tcp-service-cache-by-number
*)
134 (clrhash *udp-service-cache-by-name
*)
135 (clrhash *udp-service-cache-by-number
*))
137 (defvar *services-monitor
*
138 (make-instance 'file-monitor
139 :file
*services-file
*
140 :update-fn
'purge-service-cache
141 :lock
*service-cache-lock
*))
146 (defun lookup-service (service &optional
(protocol :tcp
))
147 "Lookup a service by port or name. PROTOCOL should be one
148 of :TCP, :UDP or :ANY."
149 (check-type service
(or tcp-port string symbol
) "a valid port number, a string or a symbol")
150 (check-type protocol
(member :tcp
:udp
:any
) "one of :TCP, :UDP or :ANY")
151 (update-monitor *services-monitor
*)
152 (let* ((parsed (ensure-string-or-unsigned-byte service
:type
'tcp-port
:errorp t
))
153 (serv (typecase parsed
154 (tcp-port (lookup-service-by-number parsed protocol
))
155 (string (lookup-service-by-name parsed protocol
)))))
157 (values (service-port serv
)
159 (service-protocol serv
))
160 (error 'unknown-service
:datum service
))))
162 (defun ensure-numerical-service (service &optional
(protocol :tcp
))
165 (t (nth-value 0 (lookup-service service protocol
)))))