djavu-asus/elpa/srv-20180715.1959/srv.el

   1 ;;; srv.el --- perform SRV DNS requests
   2
   3 ;; Copyright (C) 2005, 2007, 2018  Magnus Henoch
   4
   5 ;; Author: Magnus Henoch <magnus.henoch@gmail.com>
   6 ;; Keywords: comm
   7 ;; Version: 0.2
   8 ;; Package-Requires: ((emacs "24.3"))
   9 ;; URL: https://github.com/legoscia/srv.el
  10
  11 ;; This file is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; This file is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  23 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; This code implements RFC 2782 (SRV records).  It was originally
  29 ;; written for jabber.el <http://emacs-jabber.sf.net>, but is now a
  30 ;; separate package.
  31 ;;
  32 ;; It is used to look up hostname and port for a service at a specific
  33 ;; domain.  There might be multiple results, and the caller is supposed
  34 ;; to attempt to connect to each hostname+port in turn.  For example,
  35 ;; to find the XMPP client service for the domain gmail.com:
  36 ;;
  37 ;; (srv-lookup "_xmpp-client._tcp.gmail.com")
  38 ;; -> (("xmpp.l.google.com" . 5222)
  39 ;;     ("alt3.xmpp.l.google.com" . 5222)
  40 ;;     ("alt4.xmpp.l.google.com" . 5222)
  41 ;;     ("alt1.xmpp.l.google.com" . 5222)
  42 ;;     ("alt2.xmpp.l.google.com" . 5222))
  43
  44
  45 ;;; Code:
  46
  47 (require 'dns)
  48
  49 ;;;###autoload
  50 (defun srv-lookup (target)
  51   "Perform SRV lookup of TARGET and return list of connection candidiates.
  52 TARGET is a string of the form \"_Service._Proto.Name\".
  53
  54 Returns a list with elements of the form (HOST . PORT), where HOST is
  55 a hostname and PORT is a numeric port.  The caller is supposed to
  56 make connection attempts in the order given, starting from the beginning
  57 of the list.  The list is empty if no SRV records were found."
  58   (let* ((result (srv--dns-query target))
  59          (answers (mapcar #'(lambda (a)
  60                               (cadr (assq 'data a)))
  61                           (cadr (assq 'answers result))))
  62          answers-by-priority weighted-result)
  63     (if (or (null answers)
  64             ;; Special case for "service decidedly not available"
  65             (and (eq (length answers) 1)
  66                  (string= (cadr (assq 'target (car answers))) ".")))
  67         nil
  68       ;; Sort answers into groups of same priority.
  69       (dolist (a answers)
  70         (let* ((priority (cadr (assq 'priority a)))
  71                (entry (assq priority answers-by-priority)))
  72           (if entry
  73               (push a (cdr entry))
  74             (push (cons priority (list a)) answers-by-priority))))
  75       ;; Sort by priority.
  76       (setq answers-by-priority
  77             (sort answers-by-priority
  78                   #'(lambda (a b) (< (car a) (car b)))))
  79       ;; Randomize by weight within priority groups.  See
  80       ;; algorithm in RFC 2782.
  81       (dolist (p answers-by-priority)
  82         (let ((weight-acc 0)
  83               weight-order)
  84           ;; Assign running sum of weight to each entry.
  85           (dolist (a (cdr p))
  86             (cl-incf weight-acc (cadr (assq 'weight a)))
  87             (push (cons weight-acc a) weight-order))
  88           (setq weight-order (nreverse weight-order))
  89
  90           ;; While elements remain, pick a random number between 0 and
  91           ;; weight-acc inclusive, and select the first entry whose
  92           ;; running sum is greater than or equal to this number.
  93           (while weight-order
  94             (let* ((r (random (1+ weight-acc)))
  95                    (next-entry (cl-dolist (a weight-order)
  96                                  (if (>= (car a) r)
  97                                      (cl-return a)))))
  98               (push (cdr next-entry) weighted-result)
  99               (setq weight-order
 100                     (delq next-entry weight-order))))))
 101       ;; Extract hostnames and ports
 102       (mapcar #'(lambda (a) (cons (cadr (assq 'target a))
 103                              (cadr (assq 'port a))))
 104               (nreverse weighted-result)))))
 105
 106 (defun srv--dns-query (target)
 107   "Perform DNS query for TARGET.
 108 On Windows, call `srv--nslookup'; on all other systems, call `dns-query'."
 109   ;; dns-query uses UDP, but that is not supported on Windows...
 110   (if (featurep 'make-network-process '(:type datagram))
 111       (dns-query target 'SRV t)
 112     ;; ...so let's call nslookup instead.
 113     (srv--nslookup target)))
 114
 115 (defun srv--nslookup (target)
 116   "Call the `nslookup' program to make an SRV query for TARGET."
 117   (with-temp-buffer
 118     (call-process "nslookup" nil t nil "-type=srv" target)
 119     (goto-char (point-min))
 120     (let (results)
 121       ;; This matches what nslookup prints on Windows.  It's unlikely
 122       ;; to work for other systems, but on those systems we use DNS
 123       ;; directly.
 124       (while (search-forward-regexp
 125               (concat "[\s\t]*priority += \\(.*\\)\r?\n"
 126                       "[\s\t]*weight += \\(.*\\)\r?\n"
 127                       "[\s\t]*port += \\(.*\\)\r?\n"
 128                       "[\s\t]*svr hostname += \\(.*\\)\r?\n")
 129               nil t)
 130         (push
 131          (list
 132           (list 'data
 133                 (list
 134                  (list 'priority (string-to-number (match-string 1)))
 135                  (list 'weight (string-to-number (match-string 2)))
 136                  (list 'port (string-to-number (match-string 3)))
 137                  (list 'target (match-string 4)))))
 138          results))
 139       (list (list 'answers results)))))
 140
 141 (provide 'srv)
 142 ;;; srv.el ends here