UPNP 로 공유기 찾고 포트매핑 추가하기. lisp(SBCL 전용) 예제

아 시바 정말 귀찮네.
이넘들이 망할 soap 을 쓰는 바람에 C 로 짜긴 귀찮은 존재구나.
libupnp 까지 붙이고 싶지는 않고.. 내가 지금 하려는거에 굳이 soap 결과를 파싱까지 하고 싶지는 않고.. 그래서 간단히 upnp 기능만 돌려보는 테스트 스크립트를 만들어봤다. slime 상에서 여러가지 경우로 테스트 해보기 위해서 lisp 으로 만들었고 lisp 으로 udp 쏘는건 처음이라 소스를 적어둔다.

아래 소스 로딩하고 (discover-gateway) 부르면 같은 망 내의 공유기를 찾아서(하나라고 가정) control url 을 *control-url* 에 담기게 되고, 그상태에서 (test/blahblah) 함수들을 적절히 불러가면서 공유기가 무슨짓을 하는지 보면 된다.

그런데 포트매핑을 추가한상태에서 또 추가한다거나, 다른 어플리케이션이 이미 포트 뚫어논 상태에서 내가 같은 포트로 뚫으려고 한다거나.. 내 어플이 뒤지고 다시 깨서 이미 뚫린걸 다시 뚫으려고 한다거나.. 내가 뚫어논걸 다른 색히가 가로챈다거나.. 음.. 테스트할 경우의수가 좀 많구나... 아무래도 문서를 읽어봐야 할거 같군. 걍 미리 만들어둔 xml 뿅 쏘고 넘길려고 했는데 그리 쉽게는 안되겠네?? 지금 아래 구현체는 upnp 하나도 모르고 그냥 빗토런트의 upnp 구현체를 보고 따라친거 뿐인데 이정도 테스트 만으로 넘어가긴 좀 그렇구나.

문서좀 읽고 libupnp 를 검토해봐야겠구나.. 후랄.

아 그리고 당연한 말이지만 아래 코드는 테스트용으로 만든거라 여러 가정을 깔고 있고 환경이 바뀌면 안돌아갈수 있다.. 나중에 기억못할테니 적어두자면.. 로컬 IP 가 *local-ip-address* 에 상수로 박혀있고 udp 쏘고 소켓 읽는 부분이 블러킹으로 리딩하기 때문에 만약 같은 망 내에 공유기가 없으면 마냥 블러킹 되고.. find-location-blahblah 함수내의 정규식 패턴에 ^M 이 \r 제어문자 라는거.. 이맥스에서는 C-Q C-M 으로 입력이 가능한데 다른 에디터는 모르겠다. 나중에 다시 필요하면 여기서 긁어붙일텐데 이때 ^M 주의하자.

소스보기..

;;; UPNP 를 이용해서 같은망 내의 공유기를 찾아서 포트매핑을 요청하는
;;; 예제.
;;;
;;; C 로 코딩하기전에 테스트정도로 짠거라 에러에 대한 처리는
;;; 전무. 예를들어 디스커버리 멀티캐스팅 후 응답이 없으면 마냥
;;; 블러킹되고, soap 날렸을때 에러나는경우 처리를 못하고 등등.
;;;
;;; 몇가지 더 적어두자면
;;; 1. udp socket 을 sb-bsd-sockets 의 함수들을 썼다. 따라서 sbcl
;;;    전용.
;;; 2. 뉴라인 찾는걸.. 정규식으로 처리를 잘 못해서 ^M 을 이맥스에서
;;;    코드상으로 박아버렸다. 애초에 별거아닌 문자열 검색에
;;;    정규식쓴것도 좀 그렇군.
;;; 3. drakma 를 써서 SOAP call 을 해결했다.
;;; 4. prog1 이 절라 편하군.. 하지만 쓰고나서 읽기는 버겁더라.
;;;
;;;
;;; 테스트하려면
;;; 1. 먼저 (discover-gateway) 를 불러서 *control-url* 를 채우고
;;; 2. (test/blahblah) 류 함수들을 불러가면서 공유기 제어를 해보자.
;;;

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require 'drakma)
  (require 'cl-ppcre)
  (require 'puri))

(defpackage #:upnp
  (:use #:cl #:cl-ppcre))
(in-package #:upnp)


;;; drakma 디버깅출력을 보는게 좀더 편하겠군
(setf drakma:*header-stream* *standard-output*)

(defvar *control-url* nil "soap 을 때릴 주소. discover-gateway 함수를
부르면 채워준다.")

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun join-lines (&rest lines)
  "인자로 들어오는 문자열들을 묶어 하나의 문자열로 만드는데 이때 문자열
끝마다 crlf 를 넣어준다. 좀더 간지나게 짤수도 있을것 같은데 당장 loop
부터 떠오르더라.."
  (loop
     with r
     for x in lines
     do (setf r (concatenate 'string r x #(#\Return #\Linefeed)))
     finally (return r))))

(defvar *discovery*
  (join-lines
   "M-SEARCH * HTTP/1.1"
   "Host:239.255.255.250:1900"
   "ST:urn:schemas-upnp-org:device:InternetGatewayDevice:1"
   "Man:\"ssdp:discover\""
   "MX:3"
   ""))

(defvar *local-ip-address* "192.168.0.2" "헐 시바. 자기 ip 얻는방법을
모르겠네 소켓 만들어서 따와야 하나 고민할거 없이 걍 상수로 박았다. 이게
필요한 이유는 매핑할때 인자로 넘겨줘야 하기 때문.")


(defun multicast-discovery ()
  "우왕 복잡하고 드러운 코드네. with- 매크로를 만들기 싫어서 그냥
막짰더니 다시 못읽는 코드가 나와버렸네. prog1 도 쓸때는 졸라 편한데
읽을땐 더러워지는 구나.

어쨌건 이함수를 부르면 upnp discovery 패킷을 쏘고 응답이 있으면 그걸 받아 출력해준다.
응답이 없는 경우...는 테스트 안해봤다. 뭐 블럭되겠지..."
  (let ((sock (make-instance 'sb-bsd-sockets:inet-socket :type :datagram :protocol :udp)))
    (sb-bsd-sockets:socket-send sock *discovery* nil :address '(#(239 255 255 250) 1900))
    (multiple-value-bind (buf readed from)
        (sb-bsd-sockets:socket-receive sock nil 8192 :element-type 'character)
      (prog1 (values (make-array readed :displaced-to buf :element-type 'character)
                     readed
                     from)
        (sb-bsd-sockets:socket-close sock)))))

(defun find-location-from-discovery-response (discovery-response)
  "헐. #Return 을 없애는걸.. strip 이나 등등을 쓰지 못하고 정규식내에
^M 을 집어넣어서 해결했다. 뭐 테스트 용도이니 빨리 짜는게 장땡이지."
  (multiple-value-bind (string results)
      (cl-ppcre:scan-to-strings "LOCATION: \(.*\)^M" discovery-response)
    (declare (ignore string))
    (aref results 0)))


(defun httpcall (url)
  (drakma:http-request url))

(defun soapcall (url action body)
  (drakma:http-request url
                       :content-type "text/xml; charset=\"utf-8\""
                       :method :post
                       :content body
                       :additional-headers `(("SOAPAction" . ,action))))


(defun between (string begin end &optional &key (start 0))
  "string 안에서 begin 과 end 사이의 문자열을 찾아 리턴 에러처리 따로
안했으니 못찾으면 아마 search 함수가 에러내겠지."
  (let* ((b (search begin string :start2 start))
         (e (search end   string :start2 b)))
    (subseq string (+ b (length begin)) e)))


(defun search-before (string before target)
  "헐 영어가 후달리니 이름을 못짓겠네. 주어진 string 에서 먼저 target
을 찾고 그 앞쪽에서부터 before 를 찾아서 첫번째 나오는 위치(string 내의
인덱스)를 리턴해준다."
  (search before
          string
          :end2 (search target string)
          :from-end t))


(defun wanip-connection-service (description)
  "서비스타입이 urn:schemas-upnp-org:service:WANIPConnection: 인
서비스를 찾아 그부분만 리턴."
  (let* ((b (search-before description "<service>" "<serviceType>urn:schemas-upnp-org:service:WANIPConnection:"))
         (service (between description "<service>" "</service>" :start b)))
    service))

(defun discover-gateway ()
  "여자저차 해서 *control-url* 에 값을 채운다.

 1. 먼저 디스커버리 멀티캐스팅을 쏘고
 2. 응답중에 location 부분을 따와서
 3. http get 때려서 디스크립션을 얻고
 4. 디스크립션중 urn:schemas-upnp-org:service:WANIPConnection: 타입의 서비스 부분을 찾아서
 5. 그 서비스의 controlURL 을 얻어서
 6. *control-url* 에 담는다."
  (let* ((discovery-response (multicast-discovery))
         (gateway-location   (find-location-from-discovery-response discovery-response))
         (description        (httpcall gateway-location))
         (service            (wanip-connection-service description))
         (control-url        (between service "<controlURL>" "</controlURL>"))
         (abs-control-url    (puri:merge-uris control-url gateway-location)))
    (setf *control-url* abs-control-url)
    *control-url*))


(defun xml-get-port-mapping (index)
  (format nil "<?xml version=\"1.0\"?>
<s:Envelope xmlns:s=\"http://schemas.xmlsoap.org/soap/envelope/\" s:encodingStyle=\"http://schemas.xmlsoap.org/soap/encoding/\">
  <s:Body>
    <u:GetGenericPortMappingEntry xmlns:u=\"urn:schemas-upnp-org:service:WANIPConnection:1\">
      <NewPortMappingIndex>~D</NewPortMappingIndex>
    </u:GetGenericPortMappingEntry>
  </s:Body>
</s:Envelope>"
          index))


(defun xml-add-port-mapping (&key internal-port external-port protocol (host *local-ip-address*) service-name)
  (format nil "<?xml version=\"1.0\"?>
<s:Envelope xmlns:s=\"http://schemas.xmlsoap.org/soap/envelope/\" s:encodingStyle=\"http://schemas.xmlsoap.org/soap/encoding/\">
  <s:Body>
    <u:AddPortMapping xmlns:u=\"urn:schemas-upnp-org:service:WANIPConnection:1\">
      <NewEnabled>1</NewEnabled>
      <NewRemoteHost></NewRemoteHost>
      <NewLeaseDuration>0</NewLeaseDuration>
      <NewInternalPort>~D</NewInternalPort>
      <NewExternalPort>~D</NewExternalPort>
      <NewProtocol>~A</NewProtocol>
      <NewInternalClient>~A</NewInternalClient>
      <NewPortMappingDescription>~A</NewPortMappingDescription>
    </u:AddPortMapping>
  </s:Body>
</s:Envelope>"
          internal-port
          external-port
          protocol
          host
          service-name))

(defun xml-del-port-mapping (&key external-port protocol)
  (format nil "<?xml version=\"1.0\"?>
<s:Envelope xmlns:s=\"http://schemas.xmlsoap.org/soap/envelope/\" s:encodingStyle=\"http://schemas.xmlsoap.org/soap/encoding/\">
  <s:Body>
    <u:DeletePortMapping xmlns:u=\"urn:schemas-upnp-org:service:WANIPConnection:1\">
      <NewRemoteHost></NewRemoteHost>
      <NewExternalPort>~D</NewExternalPort>
      <NewProtocol>~A</NewProtocol>
    </u:DeletePortMapping>
  </s:Body>
</s:Envelope>"
          external-port
          protocol))


(defun test/get-external-ip ()
  "soap 이 잘되는지 테스트 하려고 만들어본놈. 그외 의미는 없다."
  (soapcall *control-url*
            "urn:schemas-upnp-org:service:WANIPConnection:1#GetExternalIPAddress"
            "<?xml version=\"1.0\"?>
<s:Envelope xmlns:s=\"http://schemas.xmlsoap.org/soap/envelope/\" s:encodingStyle=\"http://schemas.xmlsoap.org/soap/encoding/\">
  <s:Body>
    <u:GetExternalIPAddress xmlns:u=\"urn:schemas-upnp-org:service:WANIPConnection:1\">
    </u:GetExternalIPAddress>
  </s:Body>
</s:Envelope>
"))

(defun test/get-port-mapping (&optional &key (index 0))
  "인덱스를 줘야 한다는게 좀 드럽군. 전체 리스팅하는걸 찾아봐야 할까?"
  (soapcall *control-url*
            "urn:schemas-upnp-org:service:WANIPConnection:1#GetGenericPortMappingEntry"
            (xml-get-port-mapping index)))

(defun test/add-port-mapping (&optional &key (internal-port 9413) (external-port 9999) (protocol "TCP") (service-name "hehehe upnp test"))
  (soapcall *control-url*
            "urn:schemas-upnp-org:service:WANIPConnection:1#AddPortMapping"
            (xml-add-port-mapping :internal-port internal-port
                                  :external-port external-port
                                  :protocol      protocol
                                  :service-name  service-name)))

(defun test/del-port-mapping (&optional &key (external-port 9999) (protocol "TCP"))
  "지울때는 external-port 와 protocol 로 지우는구나.. 결국 이게 key
값이란 소린데 그럼 포트매핑이 쫑나면 어떻게 처리하지?"
  (soapcall *control-url*
            "urn:schemas-upnp-org:service:WANIPConnection:1#DeletePortMapping"
            (xml-del-port-mapping :external-port external-port
                                  :protocol      protocol)))



;;; 테스트는 요런식으로.. test/blahblah 류 함수들을 이용하자.
;; (test/add-port-mapping)
;; (test/get-port-mapping :index 0)
;; (test/del-port-mapping :external-port 9999 :protocol "TCP"