#lang racket/base

;; Generic UPnP service inspection and SOAP invocation.
;;
;; Known service modules build small typed interfaces on top of
;; upnp-service-call.  The generic call remains available for vendor-specific
;; services and actions.

(require net/http-client
         net/url
         racket/list
         racket/port
         racket/string
         xml
         "private/model.rkt"
         "private/xml.rkt")

(provide upnp-service?
         upnp-service-kind
         upnp-service-type
         upnp-service-id
         upnp-service-kinds
         upnp-device-service
         upnp-service-actions
         upnp-service-supports-action?
         upnp-service-call
         exn:fail:upnp?
         exn:fail:upnp-code
         exn:fail:upnp-description)

(struct exn:fail:upnp exn:fail
  (code description action service)
  #:transparent)

(define service-kind-table
  '((av-transport
     "AVTransport"
     "Playback transport: URI, play, pause, stop and seek")
    (rendering-control
     "RenderingControl"
     "Rendering properties such as volume and mute")
    (connection-manager
     "ConnectionManager"
     "Supported transfer protocols and active connections")
    (content-directory
     "ContentDirectory"
     "Browsing and searching media offered by a media server")
    (scheduled-recording
     "ScheduledRecording"
     "Scheduling and managing recordings")
    (print-basic
     "PrintBasic"
     "Submitting and managing basic print jobs")
    (print-enhanced-layout
     "PrintEnhancedLayout"
     "Submitting print jobs with enhanced layout options")
    (scan
     "Scan"
     "Starting scan jobs and retrieving scanned images")
    (feeder
     "Feeder"
     "Controlling document feeders for scanners and similar devices")
    (external-activity
     "ExternalActivity"
     "Registering for front-panel activity on scanner devices")
    (wan-ip-connection
     "WANIPConnection"
     "Internet gateway IP connection and port mappings")
    (wan-ppp-connection
     "WANPPPConnection"
     "Internet gateway PPP connection and port mappings")
    (layer-3-forwarding
     "Layer3Forwarding"
     "Internet gateway default connection selection")
    (switch-power
     "SwitchPower"
     "Binary power switching")
    (dimming
     "Dimming"
     "Light dimming control")))

(define action-cache (make-weak-hasheq))
(define action-cache-lock (make-semaphore 1))

(define (upnp-service-kinds)
  (for/list ([entry (in-list service-kind-table)])
    (cons (car entry) (caddr entry))))

(define (upnp-type-name type category)
  (and type
       (let ([match
              (regexp-match
               (pregexp
                (format "(?i:^urn:[^:]+:~a:([^:]+):[0-9]+$)" category))
               type)])
         (and match (cadr match)))))

(define (upnp-type-version type category)
  (if type
      (let ([match
             (regexp-match
              (pregexp
               (format "(?i:^urn:[^:]+:~a:[^:]+:([0-9]+)$)" category))
              type)])
        (if match
            (string->number (cadr match))
            0))
      0))

(define (service-kind-by-name name)
  (let ([entry
         (and name
              (findf
               (lambda (candidate)
                 (string-ci=? (cadr candidate) name))
               service-kind-table))])
    (if entry (car entry) 'unknown)))

(define (upnp-service-kind service)
  (unless (upnp-service? service)
    (raise-argument-error 'upnp-service-kind "upnp-service?" service))
  (service-kind-by-name
   (upnp-type-name (upnp-service-service-type service) "service")))

(define (upnp-service-type service)
  (unless (upnp-service? service)
    (raise-argument-error 'upnp-service-type "upnp-service?" service))
  (upnp-service-service-type service))

(define (upnp-service-id service)
  (unless (upnp-service? service)
    (raise-argument-error 'upnp-service-id "upnp-service?" service))
  (upnp-service-service-id service))

;; Return the highest advertised version of a known service kind, or #f when
;; the device does not provide that service.
(define (upnp-device-service device kind)
  (unless (upnp-device? device)
    (raise-argument-error 'upnp-device-service "upnp-device?" device))
  (unless (symbol? kind)
    (raise-argument-error 'upnp-device-service "symbol?" kind))
  (let ([services
         (filter
          (lambda (service)
            (eq? (upnp-service-kind service) kind))
          (upnp-device-services device))])
    (and (pair? services)
         (argmax
          (lambda (service)
            (upnp-type-version (upnp-service-service-type service) "service"))
          services))))

(define (read-xml-url location)
  (call/input-url
   (string->url location)
   (lambda (url)
     (get-pure-port url '() #:redirections 3))
   (lambda (in)
     (xml->xexpr (document-element (read-xml in))))))

(define (read-service-actions service)
  (let ([location (upnp-service-scpd-url service)])
    (unless location
      (raise-arguments-error 'upnp-service-actions
                             "service has no SCPDURL"
                             "service" service))
    (let* ([description (read-xml-url location)]
           [action-list (xexpr-find-descendant description "actionList" #f)])
      (if action-list
          (filter-map
           (lambda (action)
             (xexpr-child-text action "name" #f))
           (xexpr-child-elements action-list "action"))
          '()))))

;; Read and cache the action names advertised by the service's SCPD document.
(define (upnp-service-actions service)
  (unless (upnp-service? service)
    (raise-argument-error 'upnp-service-actions "upnp-service?" service))
  (call-with-semaphore
   action-cache-lock
   (lambda ()
     (hash-ref action-cache
               service
               (lambda ()
                 (let ([actions (read-service-actions service)])
                   (hash-set! action-cache service actions)
                   actions))))))

(define (upnp-service-supports-action? service action)
  (unless (upnp-service? service)
    (raise-argument-error 'upnp-service-supports-action?
                          "upnp-service?"
                          service))
  (unless (or (string? action) (symbol? action))
    (raise-argument-error 'upnp-service-supports-action?
                          "(or/c string? symbol?)"
                          action))
  (let ([name (if (symbol? action) (symbol->string action) action)])
    (ormap (lambda (candidate) (string-ci=? candidate name))
           (upnp-service-actions service))))

(define (argument-name value)
  (cond
    [(string? value) value]
    [(symbol? value) (symbol->string value)]
    [else
     (raise-argument-error 'upnp-service-call
                           "argument name as string? or symbol?"
                           value)]))

(define (argument-value value)
  (cond
    [(string? value) value]
    [(bytes? value) (bytes->string/utf-8 value)]
    [(boolean? value) (if value "1" "0")]
    [(symbol? value) (symbol->string value)]
    [else (format "~a" value)]))

(define (soap-envelope service-type action arguments)
  (let* ([action-name (if (symbol? action) (symbol->string action) action)]
         [action-tag (string->symbol (string-append "u:" action-name))]
         [argument-elements
          (for/list ([argument (in-list arguments)])
            (unless (pair? argument)
              (raise-argument-error 'upnp-service-call
                                    "(listof pair?)"
                                    arguments))
            (list (string->symbol (argument-name (car argument)))
                  '()
                  (argument-value (cdr argument))))]
         [document
          `(s:Envelope
            ((xmlns:s "http://schemas.xmlsoap.org/soap/envelope/")
             (s:encodingStyle "http://schemas.xmlsoap.org/soap/encoding/"))
            (s:Body
             ()
             (,action-tag
              ((xmlns:u ,service-type))
              ,@argument-elements)))])
    (string->bytes/utf-8
     (string-append "<?xml version=\"1.0\" encoding=\"utf-8\"?>"
                    (xexpr->string document)))))

(define (url-request-target value)
  (let* ([relative
          (struct-copy url value
                       [scheme #f]
                       [user #f]
                       [host #f]
                       [port #f]
                       [fragment #f])]
         [target (url->string relative)])
    (if (string=? target "") "/" target)))

(define (http-status-code status)
  (let ([match
         (regexp-match #px"^HTTP/[0-9.]+[ ]+([0-9]{3})(?:[ ]|$)"
                       (bytes->string/latin-1 status))])
    (and match (string->number (cadr match)))))

(define (read-response-body in)
  (dynamic-wind
    void
    (lambda () (port->bytes in))
    (lambda () (close-input-port in))))

(define (send-soap-request service action arguments)
  (let* ([control-url (upnp-service-control-url service)]
         [service-type (upnp-service-service-type service)]
         [action-name (if (symbol? action) (symbol->string action) action)])
    (unless control-url
      (raise-arguments-error 'upnp-service-call
                             "service has no controlURL"
                             "service" service))
    (unless service-type
      (raise-arguments-error 'upnp-service-call
                             "service has no serviceType"
                             "service" service))
    (let* ([url-value (string->url control-url)]
           [scheme (or (url-scheme url-value) "http")]
           [ssl? (string-ci=? scheme "https")]
           [host (url-host url-value)]
           [port (or (url-port url-value) (if ssl? 443 80))]
           [body (soap-envelope service-type action-name arguments)]
           [headers
            (list "Content-Type: text/xml; charset=\"utf-8\""
                  (format "SOAPACTION: \"~a#~a\"" service-type action-name)
                  "Connection: close")])
      (unless host
        (raise-arguments-error 'upnp-service-call
                               "controlURL has no host"
                               "controlURL" control-url))
      (let-values ([(status response-headers in)
                    (http-sendrecv host
                                   (url-request-target url-value)
                                   #:ssl? ssl?
                                   #:port port
                                   #:method #"POST"
                                   #:headers headers
                                   #:data body)])
        (values (http-status-code status)
                response-headers
                (read-response-body in))))))

(define (bytes->xexpr body)
  (call-with-input-bytes
   body
   (lambda (in)
     (xml->xexpr (document-element (read-xml in))))))

(define (soap-fault-values response)
  (let* ([fault (xexpr-find-descendant response "Fault" #f)]
         [code-element (and fault (xexpr-find-descendant fault "errorCode" #f))]
         [description-element
          (and fault (xexpr-find-descendant fault "errorDescription" #f))])
    (values (and code-element (xexpr-text code-element #f))
            (and description-element (xexpr-text description-element #f)))))

(define (raise-upnp-error service action code description)
  (raise
   (exn:fail:upnp
    (format "UPnP action ~a failed~a: ~a"
            action
            (if code (format " with error ~a" code) "")
            (or description "unknown error"))
    (current-continuation-marks)
    code
    description
    action
    service)))

(define (element-local-name value)
  (let ([parts (string-split (symbol->string (car value)) ":")])
    (last parts)))

(define (response-result response service action)
  (let* ([body (xexpr-find-descendant response "Body" #f)]
         [elements (if body
                       (filter xexpr-element? (xexpr-children body))
                       '())]
         [result-element (and (pair? elements) (car elements))])
    (cond
      [(not result-element) (hash)]
      [(string=? (xexpr-local-name (car result-element)) "fault")
       (let-values ([(code description) (soap-fault-values response)])
         (raise-upnp-error service action code description))]
      [else
       (for/fold ([result (hash)])
                 ([value (in-list (xexpr-children result-element))]
                  #:when (xexpr-element? value))
         (hash-set result
                   (element-local-name value)
                   (or (xexpr-text value #f) "")))])))

(define (body-preview body)
  (let* ([text (string-trim (bytes->string/utf-8 body #\uFFFD))]
         [length (string-length text)])
    (if (> length 300)
        (string-append (substring text 0 300) "...")
        text)))

;; Invoke a SOAP action.  arguments is an association list whose keys are the
;; exact UPnP argument names.  The result is an immutable hash with the exact
;; output argument names as string keys.
(define (upnp-service-call service action [arguments '()])
  (unless (upnp-service? service)
    (raise-argument-error 'upnp-service-call "upnp-service?" service))
  (unless (or (string? action) (symbol? action))
    (raise-argument-error 'upnp-service-call
                          "(or/c string? symbol?)"
                          action))
  (unless (list? arguments)
    (raise-argument-error 'upnp-service-call "list?" arguments))
  (let ([action-name (if (symbol? action) (symbol->string action) action)])
    (let-values ([(status headers body)
                  (send-soap-request service action-name arguments)])
      (cond
        [(and status (<= 200 status 299))
         (if (zero? (bytes-length body))
             (hash)
             (response-result (bytes->xexpr body) service action-name))]
        [(positive? (bytes-length body))
         (let-values ([(code description)
                       (with-handlers
                           ([exn:fail? (lambda (_) (values #f #f))])
                         (soap-fault-values (bytes->xexpr body)))])
           (raise-upnp-error service
                             action-name
                             (or code status)
                             (or description (body-preview body))))]
        [else
         (raise-upnp-error service action-name status "empty HTTP response")]))))