srv.el

   1 ;;; srv.el --- perform SRV DNS requests
   2
   3 ;; Copyright (C) 2005, 2007  Magnus Henoch
   4
   5 ;; Author: Magnus Henoch <mange@freemail.hu>
   6 ;; Keywords: comm
   7 ;; Version: 0.1
   8
   9 ;; This file is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; This file 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 General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  21 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;; This code implements RFC 2782 (SRV records).  It requires a version
  27 ;; of dns.el that supports SRV records; look in Gnus CVS if you don't
  28 ;; have one.
  29
  30 ;;; Code:
  31
  32 (condition-case nil
  33     (require 'dns)
  34   (error nil))
  35 (eval-when-compile (require 'cl))
  36
  37 (defun srv-lookup (target)
  38   "Perform SRV lookup of TARGET and return list of connection candidiates.
  39 TARGET is a string of the form \"_Service._Proto.Name\".
  40
  41 Returns a list with elements of the form (HOST . PORT), where HOST is
  42 a hostname and PORT is a numeric port.  The caller is supposed to
  43 make connection attempts in the order given, starting from the beginning
  44 of the list.  The list is empty if no SRV records were found."
  45   (unless (boundp 'dns-query-types)
  46     (error "No dns.el available"))
  47   (unless (assq 'SRV dns-query-types)
  48     (error "dns.el doesn't support SRV lookups"))
  49   ;; `dns-query' used to be `query-dns'.  Try both names for now.
  50   (let* ((result (if (fboundp 'query-dns)
  51                      (query-dns target 'SRV t)
  52                    (dns-query target 'SRV t)))
  53          (answers (mapcar #'(lambda (a)
  54                               (cadr (assq 'data a)))
  55                           (cadr (assq 'answers result))))
  56          answers-by-priority weighted-result)
  57     (if (or (null answers)
  58             ;; Special case for "service decidedly not available"
  59             (and (eq (length answers) 1)
  60                  (string= (cadr (assq 'target (car answers))) ".")))
  61         nil
  62       ;; Sort answers into groups of same priority.
  63       (dolist (a answers)
  64         (let* ((priority (cadr (assq 'priority a)))
  65                (entry (assq priority answers-by-priority)))
  66           (if entry
  67               (push a (cdr entry))
  68             (push (cons priority (list a)) answers-by-priority))))
  69       ;; Sort by priority.
  70       (setq answers-by-priority
  71             (sort answers-by-priority
  72                   #'(lambda (a b) (< (car a) (car b)))))
  73       ;; Randomize by weight within priority groups.  See
  74       ;; algorithm in RFC 2782.
  75       (dolist (p answers-by-priority)
  76         (let ((weight-acc 0)
  77               weight-order)
  78           ;; Assign running sum of weight to each entry.
  79           (dolist (a (cdr p))
  80             (incf weight-acc (cadr (assq 'weight a)))
  81             (push (cons weight-acc a) weight-order))
  82           (setq weight-order (nreverse weight-order))
  83
  84           ;; While elements remain, pick a random number between 0 and
  85           ;; weight-acc inclusive, and select the first entry whose
  86           ;; running sum is greater than or equal to this number.
  87           (while weight-order
  88             (let* ((r (random (1+ weight-acc)))
  89                    (next-entry (dolist (a weight-order)
  90                                  (if (>= (car a) r)
  91                                      (return a)))))
  92               (push (cdr next-entry) weighted-result)
  93               (setq weight-order
  94                     (delq next-entry weight-order))))))
  95       ;; Extract hostnames and ports
  96       (mapcar #'(lambda (a) (cons (cadr (assq 'target a))
  97                              (cadr (assq 'port a))))
  98               (nreverse weighted-result)))))
  99
 100 (provide 'srv)
 101 ;; arch-tag: b43358f2-d241-11da-836e-000a95c2fcd0
 102 ;;; srv.el ends here