#lang racket/base

(require rackunit
         racket/port
         racket/string
         racket/tcp
	 "../main.rkt"
	 "../service.rkt")

(define av1
  (upnp-service "urn:schemas-upnp-org:service:AVTransport:1"
                "urn:upnp-org:serviceId:AVTransport"
                #f #f #f))

(define av3
  (upnp-service "urn:schemas-upnp-org:service:AVTransport:3"
                "urn:upnp-org:serviceId:AVTransport"
                #f #f #f))

(define renderer
  (upnp-device "uuid:test-renderer"
               "urn:schemas-upnp-org:device:MediaRenderer:1"
               "Test Renderer"
               "Test Manufacturer"
               "Test Model"
               "1000"
               #f
               "http://127.0.0.1/device.xml"
               "127.0.0.1"
               #f
               (list av1 av3)
               '()
               (hash "x_dlnadoc" "DMR-1.50")))

(check-eq? (upnp-device-kind renderer) 'media-renderer)
(check-equal? (upnp-device-name renderer) "Test Renderer")
(check-equal? (upnp-device-model renderer) "Test Model (1000)")
(check-eq? (upnp-device-service renderer 'av-transport) av3)
(check-true (media-renderer? renderer))
(check-true (media-renderer-dlna? renderer))
(check-not-false (assoc 'media-renderer (upnp-device-kinds)))
(check-not-false (assoc 'av-transport (upnp-service-kinds)))
(check-not-false (assoc 'scan (upnp-service-kinds)))

(define listener (tcp-listen 0 4 #t "127.0.0.1"))
(define-values (_local-host port _remote-host _remote-port)
  (tcp-addresses listener #t))
(define recorded-bodies (box '()))

(define (read-request in)
  (let* ([request-line (read-line in 'any)]
         [headers
          (let loop ([headers (hash)])
            (let ([line (read-line in 'any)])
              (cond
                [(or (eof-object? line) (string=? line "")) headers]
                [else
                 (let ([match (regexp-match #px"^([^:]+):[ \t]*(.*)$" line)])
                   (loop
                    (if match
                        (hash-set headers
                                  (string-downcase (cadr match))
                                  (caddr match))
                        headers)))])))]
         [content-length
          (string->number (hash-ref headers "content-length" "0"))]
         [body
          (if (and content-length (positive? content-length))
              (read-string content-length in)
              "")])
    (values request-line headers body)))

(define (soap-response action content)
  (string-append
   "<?xml version=\"1.0\"?>"
   "<s:Envelope xmlns:s=\"http://schemas.xmlsoap.org/soap/envelope/\">"
   "<s:Body><u:" action "Response xmlns:u=\"urn:test\">"
   content
   "</u:" action "Response></s:Body></s:Envelope>"))

(define scpd
  (string-append
   "<?xml version=\"1.0\"?>"
   "<scpd xmlns=\"urn:schemas-upnp-org:service-1-0\"><actionList>"
   "<action><name>SetAVTransportURI</name></action>"
   "<action><name>Play</name></action>"
   "<action><name>Pause</name></action>"
   "<action><name>GetTransportInfo</name></action>"
   "<action><name>GetPositionInfo</name></action>"
   "</actionList></scpd>"))

(define fault
  (string-append
   "<?xml version=\"1.0\"?>"
   "<s:Envelope xmlns:s=\"http://schemas.xmlsoap.org/soap/envelope/\">"
   "<s:Body><s:Fault><detail><UPnPError>"
   "<errorCode>701</errorCode><errorDescription>Transition not available</errorDescription>"
   "</UPnPError></detail></s:Fault></s:Body></s:Envelope>"))

(define (response-for request-line headers)
  (let ([action (hash-ref headers "soapaction" "")])
    (cond
      [(regexp-match? #rx"GET /avtransport.xml" request-line)
       (values 200 scpd)]
      [(regexp-match? #rx"GetTransportInfo" action)
       (values 200
               (soap-response
                "GetTransportInfo"
                "<CurrentTransportState>PLAYING</CurrentTransportState><CurrentTransportStatus>OK</CurrentTransportStatus><CurrentSpeed>1</CurrentSpeed>"))]
      [(regexp-match? #rx"GetPositionInfo" action)
       (values 200
               (soap-response
                "GetPositionInfo"
                "<Track>2</Track><TrackDuration>00:03:30</TrackDuration><RelTime>00:01:15.5</RelTime><TrackURI>http://example/test.flac</TrackURI>"))]
      [(regexp-match? #rx"GetVolume" action)
       (values 200 (soap-response "GetVolume" "<CurrentVolume>37</CurrentVolume>"))]
      [(regexp-match? #rx"GetProtocolInfo" action)
       (values 200
               (soap-response
                "GetProtocolInfo"
                "<Source>http-get:*:audio/flac:*</Source><Sink>http-get:*:audio/mpeg:*, http-get:*:audio/flac:*</Sink>"))]
      [(regexp-match? #rx"GetCurrentConnectionIDs" action)
       (values 200
               (soap-response
                "GetCurrentConnectionIDs"
                "<ConnectionIDs>0,2</ConnectionIDs>"))]
      [(regexp-match? #rx"Browse" action)
       (values 200
               (soap-response
                "Browse"
                "<Result>&lt;DIDL-Lite/&gt;</Result><NumberReturned>1</NumberReturned><TotalMatches>4</TotalMatches><UpdateID>9</UpdateID>"))]
      [(regexp-match? #rx"FaultAction" action)
       (values 500 fault)]
      [else
       (let ([match (regexp-match #px"#([^\"]+)\"?$" action)])
         (values 200 (soap-response (if match (cadr match) "Action") "")))])))

(define server
  (thread
   (lambda ()
     (for ([request-number (in-range 10)])
       (let-values ([(in out) (tcp-accept listener)])
         (let-values ([(request-line headers body) (read-request in)])
           (set-box! recorded-bodies (cons body (unbox recorded-bodies)))
           (let-values ([(status response) (response-for request-line headers)])
             (let ([response-bytes (string->bytes/utf-8 response)])
               (fprintf out
                        "HTTP/1.1 ~a ~a\r\nContent-Type: text/xml\r\nContent-Length: ~a\r\nConnection: close\r\n\r\n"
                        status
                        (if (= status 200) "OK" "Internal Server Error")
                        (bytes-length response-bytes))
               (write-bytes response-bytes out)
               (flush-output out))))
         (close-input-port in)
         (close-output-port out))))))

(define control-url (format "http://127.0.0.1:~a/control" port))
(define scpd-url (format "http://127.0.0.1:~a/avtransport.xml" port))
(define av
  (upnp-service "urn:schemas-upnp-org:service:AVTransport:1"
                "urn:upnp-org:serviceId:AVTransport"
                scpd-url control-url #f))
(define rendering
  (upnp-service "urn:schemas-upnp-org:service:RenderingControl:1"
                "urn:upnp-org:serviceId:RenderingControl"
                #f control-url #f))
(define connection
  (upnp-service "urn:schemas-upnp-org:service:ConnectionManager:1"
                "urn:upnp-org:serviceId:ConnectionManager"
                #f control-url #f))
(define directory
  (upnp-service "urn:schemas-upnp-org:service:ContentDirectory:1"
                "urn:upnp-org:serviceId:ContentDirectory"
                #f control-url #f))

(check-equal? (upnp-service-actions av)
              '("SetAVTransportURI" "Play" "Pause" "GetTransportInfo" "GetPositionInfo"))
(check-true (upnp-service-supports-action? av 'play))
(check-eq? (av-transport-status av) 'playing)
(let ([position (av-transport-position av)])
  (check-equal? (transport-position-track position) 2)
  (check-equal? (transport-position-seconds position) 151/2)
  (check-equal? (transport-position-duration position) 210)
  (check-equal? (transport-position-uri position) "http://example/test.flac"))
(av-transport-set-uri! av "http://127.0.0.1/test?a=1&b=2")
(check-equal? (rendering-control-volume rendering) 37)
(rendering-control-set-volume! rendering 300)
(let-values ([(source sink) (connection-manager-protocols connection)])
  (check-equal? source '("http-get:*:audio/flac:*"))
  (check-equal? sink '("http-get:*:audio/mpeg:*" "http-get:*:audio/flac:*")))
(check-equal? (connection-manager-connection-ids connection) '(0 2))
(let ([result (content-directory-browse directory "0")])
  (check-equal? (content-result-content result) "<DIDL-Lite/>")
  (check-equal? (content-result-number-returned result) 1)
  (check-equal? (content-result-total-matches result) 4)
  (check-equal? (content-result-update-id result) 9))
(check-exn
 (lambda (exception)
   (and (exn:fail:upnp? exception)
        (equal? (exn:fail:upnp-code exception) "701")
        (equal? (exn:fail:upnp-description exception) "Transition not available")))
 (lambda () (upnp-service-call av "FaultAction")))

(thread-wait server)
(tcp-close listener)

(check-true
 (ormap (lambda (body)
          (regexp-match? #rx"http://127.0.0.1/test\\?a=1&amp;b=2" body))
        (unbox recorded-bodies)))

(displayln "UPnP tests passed")