upnp-client.rkt
#lang racket/base

#|

   UPnP Client Library for Racket
   upnp-client.rkt

   This file is part of rkt-upnp.
   This file is subject to the terms of a MIT-style license, please
   refer to LICENSE.txt for details.

   How it works:

   (define d (upnp-discovery))
   (define s (upnp-search-service-srvid d "urn:upnp-org:serviceId:WANIPConn1"))
   (define c (upnp-make-service-wrapper s))
   (define get-external-ip  (c "GetExternalIPAddress" '("NewExternalIPAddress")))
   (define add-port-mapping (c "AddPortMapping" '() "NewRemoteHost" "NewExternalPort" "NewProtocol" "NewInternalPort" "NewInternalClient" "NewEnabled" "NewPortMappingDescription" "NewLeaseDuration"))
  
   And then use (get-external-ip) to get the external ip, or use (add-port-mapping ...) with the parameters
  
|#

(require racket/match
         racket/list
         racket/bool
         racket/udp
         racket/port
         net/url
         xml
         "soap.rkt"
         )

(provide upnp-discovery
         upnp-discovery-stop
         upnp-search-service-proc
         upnp-search-service-proc/one-url
         upnp-search-service-srvid
         upnp-search-service-udnsrvid
         upnp-search-service-devsrvtype
         upnp-search-service-srvtype
         upnp-make-service-wrapper
         )

(define DEFAULT_USER_AGENT "rkt-upnp UPnP Client")

#|
   Submodule to try out the UPnP client library.
|#
(module+ main
  (define d (upnp-discovery))
  (define s (upnp-search-service-srvid d "urn:upnp-org:serviceId:WANIPConn1"))
  (define c (upnp-make-service-wrapper s))
  (define get-external-ip  (c "GetExternalIPAddress" '("NewExternalIPAddress")))
  (printf "Your IP Address: ~s\n" (get-external-ip)) )

#|
   Structs for this library
|#
(struct rkt-upnp-discoverer
  ( func ))

(struct rkt-upnp-service
  ( func ))

#|
   parse-httpu
   Parse UDP-HTTP into 3 values:
   * Service URL
   * Unique Service Name (USN)
   * Search Target (ST)
|#
(define (parse-httpu cnt)
  (let* ([sp  (open-input-string (bytes->string/utf-8 cnt))]
         [rpc (read-line sp 'any)]
         [f-loc #f]
         [f-usn #f]
         [f-st  #f])
    (match rpc
      [[regexp #rx"^(?i:HTTP/[0-9.]+) +200([^0-9].*)$" [list _ _]]
       (let loop ([a (read-line sp 'any)])
         (unless (eof-object? a)
           (match a
             ["" (void)]
             [[regexp #rx"^([^: ]+): *(.*)$" [list _ mf mv]]
              (match (list (string-upcase mf) mv)
                [`["AL" ,y] (void)]
                [`["ST" ,y]
                 (set! f-st y)
                 ]
                [`["01-NLS" ,y] (void)]
                [`["LOCATION" ,y]
                 (match y
                   [[regexp "http://.+" (list _)]
                    (set! f-loc y)]
                   [[regexp "^[0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+:?[0-9]*$" (list _)]
                    (set! f-loc (format "http://~a/" y))]
                   [_ (void)]
                   )
                 ]
                [`["CACHE-CONTROL" ,y] (void)]
                [`["USN" ,y]
                 (set! f-usn y)
                 ]
                [`["SERVER" ,y] (void)]
                [`["EXT" ,y] (void)]
                [`["OPT" ,y] (void)]
                [`["DATE" ,y] (void)]
                [`["X-USER-AGENT" ,y] (void)]
                [_ (void)] )])
           (loop (read-line sp 'any)) ))]
      [_ (void)] )
    (values f-loc f-usn f-st) )
  )

#|
   upnp-discovery
   Perform UPnP Discovery
|#
(define (upnp-discovery #:wait [waitsec 10] )
  (let ([us (udp-open-socket)] ; UDP port
        [hshset (make-hash)]  ; key: url-location value: #t
        [hshst  (make-hash)]  ; key: url-location value: list of Search Targets (ST)
        [hshusn (make-hash)]) ; key: url-location value: list of Unique Service Names (USN)
    (define thrd
      (thread
       (λ ()
         (define (storeresponse rip rpo cnt)
           (let-values ([(f-loc f-usn f-st) (parse-httpu cnt)])
             (when (not (equal? #f f-loc))
               (hash-set! hshset f-loc #t)
               (hash-set! hshusn f-loc (cons f-usn (hash-ref hshusn f-loc '())))
               (hash-set! hshst  f-loc (cons f-st  (hash-ref hshst f-loc '()))) ))
           )
         (let*([ssdpip   "239.255.255.250"]
               [ssdpport 1900]
               [randport (+ 10000 (random 40000))] ; TODO: Make random port
               [bf (make-bytes 2048)]
               [ssdpqry (string->bytes/utf-8
                         (string-append
                          "M-SEARCH * HTTP/1.1\r\n"
                          "HOST: " ssdpip ":" (number->string ssdpport) "\r\n"
                          "MAN: \"ssdp:discover\"\r\n"
                          "MX: 10\r\n"
                          "ST: ssdp:all\r\n"
                          "\r\n"))])
           (udp-bind! us "0.0.0.0" randport) ; make random port number
           (udp-send-to us ssdpip ssdpport ssdpqry)
           (let loop ()
             (let-values ([(l rip rpo) (udp-receive! us bf)])
               (storeresponse rip rpo (subbytes bf 0 l))
               )
             (loop) )))))
    (sleep waitsec)
    (rkt-upnp-discoverer
     (λ (cmd)
       (case cmd
         ['stop
          (kill-thread thrd)
          (with-handlers ([exn:fail? void])
            (udp-close us))
          #t]
         ['list
          (map (λ (u0)
                 (let ([u (car u0)])
                   (list u (hash-ref hshst u '()) (hash-ref hshusn u '()))))
               (hash->list hshset))
          ]))))
  )

(define (upnp-discovery-stop dfn)
  ((rkt-upnp-discoverer-func dfn) 'stop))


#|
   upnp-search-service-proc
   Search incoming service announcements using proc as predicate.
|#
; (define s (upnp-search-service-srvtype d "service:WANIPConnection:1"))
; TODO: Change d0 to handle list of discovered devices
(define (upnp-search-service-proc d filtproc #:user-agent [usragnt DEFAULT_USER_AGENT])
  (let ([lst ((rkt-upnp-discoverer-func d) 'list)])
    (let loop ([l lst])
      (if (equal? '() l)
          #f
          (let ([r (upnp-search-service-proc/one-url (first (first l)) filtproc #:user-agent usragnt)])
            (if (rkt-upnp-service? r)
                r
                (if (equal? '() (rest l))
                    #f
                    (loop (rest l))))))))
  )

#|
   upnp-search-service-proc/one-url
   Search service announcements available from one service listing URL.
|#
(define (upnp-search-service-proc/one-url urlreq filtproc #:user-agent [usragnt DEFAULT_USER_AGENT])
  (with-handlers ([exn:fail? (λ (e) #f)])
    (call/cc
     (λ (return)
       (let* ( [hdrs `(,(format "User-Agent: ~a" usragnt)
                       "Connection: close"
                       "Accept: text/html, text/xml; q=.2, */*; q=.2"
                       "Content-type: application/x-www-form-urlencoded")]
               [inp (get-pure-port (string->url urlreq) hdrs)]
               [d   (xml->xexpr (document-element (read-xml inp)))]
               [location urlreq] )
         (define (decode-desc-dvlst a)
           (let ( [devtype #f] [frdname #f]
                               [mfg     #f] [mfgurl  #f] [mfgdesc #f]
                               [mdlname #f] [udn     #f] [prsurl  #f]
                               [srvs   '()] )
             (match a
               [`((xmlns ,y)) (match y ["urn:schemas-upnp-org:device-1-0" #f])]
               [`(specVersion () ,specversion ...) 
                (for ([t specversion])
                  (match t
                    [`(major () ,maj) (void)]
                    [`(minor () ,min) (void)]
                    [_ (void)]
                    ))
                #f
                ]
               [`(device () ,devinfo ...)
                (for ([b devinfo]) 
                  (define (decode-desc-srvlst c)
                    (let ( [srvtype #f] [srvid   #f]
                                        [ctlurl  #f] [evturl  #f] [scpdurl #f] )
                      (match c
                        [`(service () ,srvinf ...)
                         (for ([e srvinf]) 
                           (match e
                             [`(serviceType () ,y)
                              (set! srvtype y) ; e.g. "urn:schemas-upnp-org:service:WANIPConnection:1"
                              ]
                             [`(serviceId () ,y)
                              (set! srvid y) ; e.g. "urn:upnp-org:serviceId:WANIPConnection"
                              ]
                             [`(controlURL () ,y)
                              (set! ctlurl y) ; e.g. "/upnp/control1"
                              ]
                             [`(eventSubURL () ,y)
                              (set! evturl y) ; e.g. "/WANIPConnection"
                              ]
                             [`(SCPDURL () ,y)
                              (set! scpdurl y) ; e.g. "http://192.168.0.1:80/serv3.xml"
                              ]
                             [_ (void)]
                             )
                           )
                         (list srvtype srvid ctlurl evturl scpdurl)
                         ]
                        [_ #f]
                        )
                      )
                    )
                  (match b
                    [`(deviceType () ,y)
                     (set! devtype y) ; e.g. "urn:schemas-upnp-org:device:WANConnectionDevice:1"
                     ]
                    [`(friendlyName () ,y)
                     (set! frdname y) ; e.g. "WAN Connection Device"
                     ]
                    [`(manufacturer () ,y)
                     (set! mfg y) ; e.g. "D-Link"
                     ]
                    [`(manufacturerURL () ,y)
                     (set! mfgurl y) ; e.g. "http://www.dlink.com"
                     ]
                    [`(modelDescription () ,y)
                     (set! mfgdesc y) ; e.g. "Residential Gateway"
                     ]
                    [`(modelName () ,y)
                     (set! mdlname y) ; e.g. "Residential Gateway Device"
                     ]
                    [`(UDN () ,y)
                     (set! udn y) ; e.g. "uuid:000F3D19-AF81-0000-0000-0002C0A80001"
                     ]
                    [`(presentationURL () ,y)
                     (set! prsurl y) ; e.g. "http://192.168.0.1:80/"
                     ]
                    [`(serviceList () ,srvlst ...)
                     (set! srvs (filter-not false? (map decode-desc-srvlst srvlst)))
                     ]
                    [`(deviceList () ,dvlst ...)
                     (for-each decode-desc-dvlst dvlst)
                     ]
                    [_ (void)]
                    )
                  )
                (for/list ([j srvs])
                  (match j
                    [`[,srvtype ,srvid ,ctlurl ,evturl ,scpdurl]
                     (when (filtproc location devtype srvtype srvid udn frdname
                                     scpdurl ctlurl evturl prsurl
                                     mfg mfgurl mfgdesc mdlname)
                       (return
                        (rkt-upnp-service
                         (λ ()
                           (values location devtype srvtype srvid udn frdname
                                   scpdurl ctlurl evturl prsurl
                                   mfg mfgurl mfgdesc mdlname)))))
                     ]))
                ]
               [_ #f])
             )
           )
         ;(printf "~s~n~n" d)
         (for-each decode-desc-dvlst d)
         ))))
  )

(define (upnp-search-service-srvid d svu #:user-agent [usragnt DEFAULT_USER_AGENT])
  (let ([srx (regexp (string-append svu "$"))])
    (upnp-search-service-proc
     d (λ (location devtype srvtype srvid udn frdname scpdurl ctlurl evturl prsurl mfg mfgurl mfgdesc mdlname)
         ;(printf "~s ?= ~s -> ~s~n" srx srvid (regexp-match srx srvid))
         (if (regexp-match srx srvid)
             #t
             #f ))
     #:user-agent usragnt))
  )

(define (upnp-search-service-udnsrvid d ud svu #:user-agent [usragnt DEFAULT_USER_AGENT])
  (let ([srx (regexp (string-append svu "$"))])
    (upnp-search-service-proc
     d (λ (location devtype srvtype srvid udn frdname scpdurl ctlurl evturl prsurl mfg mfgurl mfgdesc mdlname)
         (if (and (equal? ud udn) (regexp-match srx srvid))
             #t
             #f ))
     #:user-agent usragnt)
    )
  )
(define (upnp-search-service-devsrvtype d dev srv #:user-agent [usragnt DEFAULT_USER_AGENT])
  (let ([drx (regexp (string-append dev "$"))]
        [srx (regexp (string-append srv "$"))])
    (upnp-search-service-proc
     d (λ (location devtype srvtype srvid udn frdname scpdurl ctlurl evturl prsurl mfg mfgurl mfgdesc mdlname)
         (if (and (regexp-match drx devtype) (regexp-match srx srvtype))
             #t
             #f ))
     #:user-agent usragnt))
  )

(define (upnp-search-service-srvtype d srv #:user-agent [usragnt DEFAULT_USER_AGENT])
  (let ([srx (regexp (string-append srv "$"))])
    (upnp-search-service-proc
     d (λ (location devtype srvtype srvid udn frdname scpdurl ctlurl evturl prsurl mfg mfgurl mfgdesc mdlname)
         (if (regexp-match srx srvtype)
             #t
             #f ))
     #:user-agent usragnt))
  )

#|
   upnp-make-service-wrapper
   Create a new procedure-creating procedure from a specific service
|#
(define (upnp-make-service-wrapper s #:user-agent [usragnt DEFAULT_USER_AGENT])
  (let-values ([(location devtype srvtype srvid udn frdname
                          rel*scpdurl rel*ctlurl rel*evturl prsurl
                          mfg mfgurl mfgdesc mdlname) ((rkt-upnp-service-func s))])
    (let* ([abs*scpdurl  (combine-url/relative (string->url location) rel*scpdurl)]
           [abs*ctlurl   (combine-url/relative (string->url location) rel*ctlurl)]
           [abs*evturl   (combine-url/relative (string->url location) rel*evturl)]
           [hdrs `(,(format "User-Agent: ~a" usragnt)
                   "Connection: close"
                   "Accept: text/html, text/xml; q=.2, */*; q=.2"
                   "Content-type: application/x-www-form-urlencoded")]
           ;[_tmp (let () (printf "~s" (url->string abs*scpdurl)))]
           [inp (get-pure-port abs*scpdurl hdrs)]
           [d (xml->xexpr (document-element (read-xml inp)))]
           [hshact (make-hash)]
           [hshvar (make-hash)] )
      (for ([a  d])
        (define (decode-scpd-aclst b)
          (let ([e-nam #f]
                [e-als #f])
            (match b
              [`(action () ,actinflst ...)
               (for ([e actinflst])
                 (define (decode-scpd-aclst-act-arglist f)
                   (let ([g-stv #f]
                         [g-nam #f]
                         [g-dir #f])
                     (match f
                       [`(argument () ,arg ...)
                        (for ([g arg])
                          (match g
                            [`(relatedStateVariable () ,y) (set! g-stv y)]
                            [`(name () ,y) (set! g-nam y)]
                            [`(direction () ,y)
                             (set! g-dir (match y
                                           ["in"  'in]
                                           ["out" 'out]
                                           ))
                             ]
                            [_ (void)]
                            )
                          )
                        (list g-dir g-nam g-stv)
                        ]
                       [_ #f])
                     )
                   )
                 (match e
                   [`(argumentList () ,arglst ...)
                    (set! e-als (filter-not false? (map decode-scpd-aclst-act-arglist arglst)))
                    ]
                   [`(name () ,y) (set! e-nam y)]
                   [_ (void)]
                   )
                 )
               (hash-set! hshact e-nam e-als)
               ]
              [_ (void)])))
        
        (define (decode-scpd-stttbl b)
          (let ([c-dvl #f]
                [c-vls #f]
                [c-nam #f]
                [c-typ #f])
            (match b
              [`(stateVariable ((sendEvents ,se)) ,sttvarinf ...)
               (for ([c sttvarinf]) 
                 (define (decode-scpd-stttbl-var-vallst d)
                   (match d
                     [`(allowedValue () ,y) y]
                     [_ #f]
                     )
                   )
                 (match c
                   [`(defaultValue () ,y)
                    (set! c-dvl y)
                    ]
                   [`(allowedValueList () ,vallst ...)
                    (set! c-vls (filter-not false? (map decode-scpd-stttbl-var-vallst vallst)))
                    ]
                   [`(name () ,y)
                    (set! c-nam y)
                    ]
                   [`(dataType () ,y)
                    (set! c-typ (match y
                                  ["boolean" 'bool]
                                  ["string" 'string]
                                  ["ui2" 'ui2]
                                  ["ui4" 'ui4] ))
                    ]
                   [_ (void)]
                   )
                 )
               (hash-set! hshvar c-nam (list c-typ c-dvl c-vls))
               ]
              [_ (void)]
              )
            )
          )
        (match a
          [`((xmlns ,y)) (match y ["urn:schemas-upnp-org:service-1-0" (void)])]
          [`(specVersion () ,specversion)
           (for ([t specversion])
             (match t
               [`(major () ,maj) (void)]
               [`(minor () ,min) (void)]
               [_ (void)]
               ))
           ]
          [`(actionList () ,aclst ...)
           (for-each decode-scpd-aclst aclst)]
          [`(serviceStateTable () ,stttbl ...)
           (for-each decode-scpd-stttbl stttbl)]
          [_ (void)]
          )
        )
      (λ (arg0 . args)
        ; TODO: Generate lambdas of UPnP actions:
        ; (define scpd (decode-scpd ... ))
        (match (cons arg0 args)
          ; (scpd "AddPortMapping" '(OutArguments ...) InArguments ...)
          [`[,act (,r ...) ,a ...]
           (let* ([ha (hash-ref hshact act)]
                  [ai (map (λ (z)
                             (let loop ([hha ha])
                               (if (and (equal? 'in (first  (first hha)))
                                        (equal? z   (second (first hha))))
                                   (second (first hha))
                                   (if (empty? hha)
                                       (raise "Could not find In argument")
                                       (loop (rest hha)))))
                             ) a)]
                  [ar (map (λ (z)
                             (let loop ([hha ha])
                               (if (and (equal? 'out (first  (first hha)))
                                        (equal? z    (second (first hha))))
                                   (second (first hha))
                                   (if (empty? hha)
                                       (raise "Could not find Out argument")
                                       (loop (rest hha)))))
                             ) r)])
             (λ args/in
               (when (not (eq? (length args/in) (length ai)))
                 (raise "Input argument mismatch")
                 )
               (let* ([saargs (map (λ (a b) `(,(string->symbol a) () ,b)) ai args/in)]
                      [soapac (format "~a#~a" srvtype act)]
                      [saenvb `(,(string->symbol (format "u:~a" act)) ((xmlns:u ,srvtype)) ,@saargs)]
                      [soapnv (soap-encode `(,saenvb) #f 
                                           "http://schemas.xmlsoap.org/soap/envelope/"
                                           "http://schemas.xmlsoap.org/soap/encoding/")]
                      )
                 (define (handle-fault fcode fstr factor fdetl)
                   (printf "Fault happened: ~s~n~s~n~s~n~s~n" fcode fstr factor fdetl))
                 
                 
                 
                 (let ([fresp
                        (port->string
                         (post-pure-port
                          (combine-url/relative (string->url location) rel*ctlurl) soapnv 
                          `(,(format "SOAPAction: ~s" soapac)
                            "Connection: close"
                            "Accept: text/html, text/xml; q=.2, */*; q=.2"
                            "Content-Type: text/xml; charset=\"utf-8\""
                            ,(format "User-Agent: ~a" usragnt))))])
                   
                   ;(printf "Response: ~s\n" fresp)
                   (let-values ([(rb rh ns en) (soap-decode fresp handle-fault)])
                     (let ([respargs (cddr (first rb))]
                           [argoutset (make-hash)])
                       (for ([z respargs])
                         (match z
                           [`[,argo () ,argval]
                            (hash-set! argoutset (symbol->string argo) argval)
                            ]
                           [_ (void)]
                           ))
                       (apply values (map (λ (z)
                                            (hash-ref argoutset z #f))
                                          ar))))))))]
          ; (scpd 'event "ConnectionType" (λ (v) (void)))
          [`[event ,var ,proc]
           (printf "c: ~s evt ~s ~s -- ~s~n" abs*evturl var proc (hash-ref hshvar var))]))))
  )

#|
; Some example possible commands
((c "SetConnectionType" '() "NewConnectionType") "")
((c "GetConnectionTypeInfo" '("NewConnectionType" "NewPossibleConnectionTypes")))
((c "ForceTermination" '()))
((c "RequestConnection" '()))
((c "GetStatusInfo" '("NewConnectionStatus" "NewLastConnectionError" "NewUptime")))
((c "GetNATRSIPStatus" '("NewRSIPAvailable" "NewNATEnabled")))
((c "GetGenericPortMappingEntry" '("NewRemoteHost" "NewExternalPort" "NewProtocol" "NewInternalPort" "NewInternalClient" "NewEnabled" "NewPortMappingDescription" "NewLeaseDuration") "NewPortMappingIndex") "")
((c "GetSpecificPortMappingEntry" '("NewInternalPort" "NewInternalClient" "NewEnabled" "NewPortMappingDescription" "NewLeaseDuration") "NewRemoteHost" "NewExternalPort" "NewProtocol") "NewRemoteHost" "NewExternalPort" "NewProtocol")
((c "AddPortMapping" '() "NewRemoteHost" "NewExternalPort" "NewProtocol" "NewInternalPort" "NewInternalClient" "NewEnabled" "NewPortMappingDescription" "NewLeaseDuration") "NewRemoteHost" "NewExternalPort" "NewProtocol" "NewInternalPort" "NewInternalClient" "NewEnabled" "NewPortMappingDescription" "NewLeaseDuration")
((c "DeletePortMapping" '() "NewRemoteHost" "NewExternalPort" "NewProtocol") "NewRemoteHost" "NewExternalPort" "NewProtocol")
((c "GetExternalIPAddress" '("NewExternalIPAddress")))

; TODO: Maybe later implement events
(c 'event "ConnectionType" (λ(v) (void)))
(c 'event "PossibleConnectionTypes" (λ(v) (void)))
(c 'event "ConnectionStatus" (λ(v) (void)))
(c 'event "Uptime" (λ(v) (void)))
(c 'event "LastConnectionError" (λ(v) (void)))
(c 'event "RSIPAvailable" (λ(v) (void)))
(c 'event "NATEnabled" (λ(v) (void)))
(c 'event "ExternalIPAddress" (λ(v) (void)))
(c 'event "PortMappingNumberOfEntries" (λ(v) (void)))
(c 'event "PortMappingEnabled" (λ(v) (void)))
(c 'event "PortMappingLeaseDuration" (λ(v) (void)))
(c 'event "RemoteHost" (λ(v) (void)))
(c 'event "ExternalPort" (λ(v) (void)))
(c 'event "InternalPort" (λ(v) (void)))
(c 'event "PortMappingProtocol" (λ(v) (void)))
(c 'event "InternalClient" (λ(v) (void)))
(c 'event "PortMappingDescription" (λ(v) (void)))
|#

; Services:
; "urn:upnp-org:serviceId:WANIPConnection"
; "urn:upnp-org:serviceId:WANIPConn1"
; "urn:upnp-org:serviceId:WANPPPConn1"
; "urn:upnp-org:serviceId:WANCommonIFC1"
; "urn:upnp-org:serviceId:Layer3Forwarding:11"