#lang racket/base

(require json
         racket/contract
         racket/file
         racket/port
         racket/runtime-path
         racket-mimetypes
         racket/string
         net/url
         web-server/dispatch
         web-server/http
         web-server/http/json
         web-server/servlet-env
         "library.rkt"
         "player.rkt"
         "users.rkt")

(provide serve-player)

(define-runtime-path public-directory "../public")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Creates a JSON response that browsers and agents may not cache.
(define (json-response value #:code [code 200] #:headers [headers '()])
  (response/jsexpr
   value
   #:code code
   #:headers (cons (header #"Cache-Control" #"no-store") headers)))

;;; Converts an ordinary request exception to a bad-request response.
(define (error-response exception)
  (json-response
   (hasheq 'error (exn-message exception))
   #:code 400))

;;; Converts a denied playback agent exception to a forbidden response.
(define (agent-error-response exception)
  (json-response
   (hasheq 'error (exn-message exception)
           'code "agent-not-authorized")
   #:code 403))

;;; Reads a JSON request body or returns an empty object for an empty body.
(define (request-jsexpr request)
  (let ((body (request-post-data/raw request)))
    (if (and body (positive? (bytes-length body)))
        (bytes->jsexpr body)
        (hasheq))))

;;; Reports the authentication state belonging to the current request.
(define (auth-status-handler auth request)
  (let ((user (auth-request-user auth request)))
    (json-response
     (hasheq 'enabled (auth-enabled? auth)
             'authenticated (and user #t)
             'username (or user 'null)))))

;;; Authenticates a browser and returns its new session cookie.
(define (auth-login-handler auth request)
  (with-handlers ((exn:fail? error-response))
    (let* ((data (request-jsexpr request))
           (username (hash-ref data 'username #f))
           (password (hash-ref data 'password #f)))
      (unless (and (string? username) (string? password))
        (raise-arguments-error
         'login
         "username and password must be strings"))
      (let ((result (auth-login! auth request username password)))
        (cond
          ((eq? result 'rate-limited)
           (json-response
            (hasheq 'error "login-rate-limited"
                    'code "login-rate-limited")
            #:code 429))
          ((not result)
           (json-response
            (hasheq 'error "invalid-credentials"
                    'code "invalid-credentials")
            #:code 401))
          (else
           (json-response
            (hasheq 'authenticated #t
                    'username (string-downcase (string-trim username)))
            #:headers
            (list (header #"Set-Cookie"
                          (auth-session-cookie auth result))))))))))

;;; Invalidates the browser session and expires its cookie.
(define (auth-logout-handler auth request)
  (auth-logout! auth request)
  (json-response
   (hasheq 'authenticated #f)
   #:headers
   (list (header #"Set-Cookie" (auth-expired-cookie)))))

;;; Resolves the authenticated username or the anonymous playlist owner.
(define (request-username auth request)
  (or (auth-request-user auth request) "anonymous"))

;;; Returns the player state belonging to the requesting user.
(define (state-handler player auth request)
  (json-response
   (player-state->jsexpr
    player
    #:username (request-username auth request))))

;;; Starts renderer discovery and returns the updated player state.
(define (discover-handler player auth request)
  (player-discover! player)
  (json-response
   (player-state->jsexpr
    player
    #:username (request-username auth request))))

;;; Applies one player command for the requesting user.
(define (command-handler player auth request command)
  (with-handlers
      ((exn:fail? error-response))
    (json-response
     (player-command!
      player
      command
      (request-jsexpr request)
      #:username (request-username auth request)))))

;;; Returns the persisted interface preferences for the requesting user.
(define (preferences-handler player auth request)
  (json-response
   (hasheq
    'language
    (or (player-user-language
         player
         #:username (request-username auth request))
        'null))))

;;; Validates and persists the requesting user's interface language.
(define (preferences-update-handler player auth request)
  (with-handlers ((exn:fail? error-response))
    (let ((language (hash-ref (request-jsexpr request) 'language #f)))
      (player-user-language!
       player
       language
       #:username (request-username auth request))
      (json-response (hasheq 'language language)))))

;;; Registers or refreshes one allowed polling playback agent.
(define (agent-register-handler player request)
  (with-handlers
      ((exn:fail:agent-denied? agent-error-response)
       (exn:fail? error-response))
    (json-response
     (player-agent-register!
      player
      (request-jsexpr request)))))

;;; Processes one state report and command poll from a playback agent.
(define (agent-poll-handler player request)
  (with-handlers
      ((exn:fail:agent-denied? agent-error-response)
       (exn:fail? error-response))
    (json-response
     (player-agent-poll!
      player
      (request-jsexpr request)))))

;;; Streams the media file identified by an agent's opaque token.
(define (agent-media-handler player _request app-id token)
  (let ((file (player-agent-media player app-id token)))
    (if (and file (file-exists? file))
        (response/output
         (λ (output)
           (call-with-input-file
            file
            (λ (input)
              (copy-port input output))))
         #:mime-type
         (let ((mime (mimetype-for-ext file)))
           (if (string? mime)
               (string->bytes/utf-8 mime)
               #"application/octet-stream"))
         #:headers
         (list
          (header #"Content-Length"
                  (string->bytes/utf-8
                   (number->string (file-size file))))
          (header #"Cache-Control" #"no-store")))
        (json-response
         (hasheq 'error "media token is invalid or expired")
         #:code 404))))

;;; Streams cached artwork belonging to a track visible to the user.
(define (artwork-handler player auth request artwork-id)
  (let ((value (player-track-artwork
                player
                artwork-id
                #:username (request-username auth request))))
    (if value
        (let ((data (artwork-data value)))
          (response/output
           (λ (output)
             (write-bytes data output))
           #:mime-type
           (string->bytes/utf-8 (artwork-mime-type value))
           #:headers
           (list
            (header #"Content-Length"
                    (string->bytes/utf-8
                     (number->string (bytes-length data))))
            (header #"Cache-Control" #"private, max-age=3600"))))
        (json-response
         (hasheq 'error "track artwork is unavailable")
         #:code 404))))

;;; Returns the path and query string used to classify an API request.
(define (request-path request)
  (url->string (request-uri request)))

;;; Checks whether the request declares a JSON entity body.
(define (json-request? request)
  (let ((content-type
         (headers-assq* #"Content-Type" (request-headers/raw request))))
    (and content-type
         (regexp-match? #px#"(?i:^application/json(?:;|$))"
                        (header-value content-type)))))

;;; Recognizes endpoints that use authentication rules separate from browsers.
(define (public-api-request? request)
  (regexp-match? #px"^/api/(?:auth|agent)(?:/|$)"
                 (request-path request)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Add one HTTP header to an existing response.
; pre    : Value is a response and extra-header is an HTTP header.
; post   : The original response remains unchanged.
; result : A response with the same body and metadata and the additional
;          header prepended to its header list.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (response-add-header value extra-header)
  (response (response-code value)
            (response-message value)
            (response-seconds value)
            (response-mime value)
            (cons extra-header (response-headers value))
            (response-output value)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Dispatch an API request and renew an eligible browser cookie.
; pre    : Auth is an auth-manager, api-dispatch handles the configured routes,
;          and request targets an API route.
; post   : The selected handler has run. A due browser-session renewal is
;          recorded and returned as Set-Cookie; agent requests never renew it.
; result : The HTTP response produced by the API handler, optionally extended
;          with the renewed session cookie.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (dispatch-api auth api-dispatch request)
  (let* ((value (api-dispatch request))
         (agent-request?
          (regexp-match? #px"^/api/agent(?:/|$)" (request-path request)))
         (renewed-cookie
          (if agent-request?
              #f
              (auth-renewal-cookie auth request))))
    (if renewed-cookie
        (response-add-header value (header #"Set-Cookie" renewed-cookie))
        value)))

;;; Enforces JSON and authentication requirements before route dispatch.
(define (dispatch-request auth api-dispatch request)
  (cond
    ((and (bytes=? (request-method request) #"POST")
          (not (json-request? request)))
     (json-response
      (hasheq 'error "json-required"
              'code "json-required")
      #:code 415))
    ((or (public-api-request? request)
         (auth-request-user auth request))
     (dispatch-api auth api-dispatch request))
    (else
     (json-response
      (hasheq 'error "authentication-required"
              'code "authentication-required")
      #:code 401))))

;;; Binds the player and authentication manager to every declared API route.
(define (make-api-dispatch player auth)
  (let-values
      (((api-dispatch _url)
        (dispatch-rules
         [("api" "auth" "status")
          #:method "get"
          (λ (request) (auth-status-handler auth request))]
         [("api" "auth" "login")
          #:method "post"
          (λ (request) (auth-login-handler auth request))]
         [("api" "auth" "logout")
          #:method "post"
          (λ (request) (auth-logout-handler auth request))]
         [("api" "state")
          #:method "get"
          (λ (request) (state-handler player auth request))]
         [("api" "discover")
          #:method "post"
          (λ (request) (discover-handler player auth request))]
         [("api" "preferences")
          #:method "get"
          (λ (request) (preferences-handler player auth request))]
         [("api" "preferences")
          #:method "post"
          (λ (request) (preferences-update-handler player auth request))]
         [("api" "agent" "register")
          #:method "post"
          (λ (request) (agent-register-handler player request))]
         [("api" "agent" "poll")
          #:method "post"
          (λ (request) (agent-poll-handler player request))]
         [("api" "agent" "media" (string-arg) (string-arg))
          #:method "get"
          (λ (request app-id token)
            (agent-media-handler player request app-id token))]
         [("api" "artwork" (string-arg))
          #:method "get"
          (λ (request artwork-id)
            (artwork-handler player auth request artwork-id))]
         [("api" "command" (string-arg))
          #:method "post"
          (λ (request command)
            (command-handler player auth request command))])))
    api-dispatch))

;;; Creates the servlet dispatcher whose closure owns one player/auth pair.
(define (make-dispatch player auth)
  (let ((api-dispatch (make-api-dispatch player auth)))
    (λ (request)
      (dispatch-request auth api-dispatch request))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Provided functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Serve the web interface and JSON player API.
; pre    : Value is a player, listen-ip is a string, and port is valid.
; post   : Static files and API routes are served until the server stops.
; result : The result returned by serve/servlet.
; internals: make-dispatch binds value and auth-manager into one request
;            closure. make-api-dispatch connects that context to every route;
;            serve/servlet then serves the closure and public-directory.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define/contract (serve-player value
                               #:auth-manager
                               [auth-manager (make-auth-manager '())]
                               #:listen-ip [listen-ip "127.0.0.1"]
                               #:port [port 8080]
                               #:launch-browser? [launch-browser? #t])
  (->* (player?)
       (#:auth-manager auth-manager?
        #:listen-ip string?
        #:port exact-positive-integer?
        #:launch-browser? boolean?)
       any)
  (let ((dispatch (make-dispatch value auth-manager)))
    (serve/servlet
     dispatch
     #:listen-ip listen-ip
     #:port port
     #:connection-close? #t
     #:launch-browser? launch-browser?
     #:quit? #f
     #:banner? #t
     #:servlet-regexp #rx"^/api(?:/|$)"
     #:extra-files-paths (list public-directory))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tests for module server.rkt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(module+ test
  (require racket/promise
           rackunit)

  ;;; Creates an isolated request value for handler and dispatcher tests.
  (define (test-request method path
                        #:headers [headers '()]
                        #:body [body #f])
    (request method
             (string->url path)
             headers
             (delay '())
             body
             "127.0.0.1"
             8080
             "127.0.0.1"))

  ;;; Reads the JSON entity produced by a response.
  (define (response-jsexpr value)
    (let ((output (open-output-bytes)))
      ((response-output value) output)
      (bytes->jsexpr (get-output-bytes output))))

  (check-equal?
   (request-jsexpr (test-request #"POST" "/api/preferences"))
   (hasheq))
  (check-equal?
   (request-jsexpr
    (test-request #"POST"
                  "/api/preferences"
                  #:body #"{\"language\":\"nl\"}"))
   (hasheq 'language "nl"))
  (check-true
   (json-request?
    (test-request
     #"POST"
     "/api/preferences"
     #:headers (list (header #"Content-Type"
                            #"application/json; charset=utf-8")))))
  (check-false (json-request? (test-request #"POST" "/api/preferences")))
  (check-true (public-api-request? (test-request #"GET" "/api/auth/status")))
  (check-true (public-api-request? (test-request #"POST" "/api/agent/poll")))
  (check-false (public-api-request? (test-request #"GET" "/api/state")))

  (let* ((auth (make-auth-manager (list (cons "hans" "$argon2id$unused"))))
         (request (test-request #"GET" "/api/state"))
         (response
          (dispatch-request auth
                            (λ (_) (error 'test "unexpected dispatch"))
                            request)))
    (check-equal? (response-code response) 401)
    (check-equal? (hash-ref (response-jsexpr response) 'error)
                  "authentication-required"))

  (let* ((auth (make-auth-manager '()))
         (request (test-request #"POST" "/api/state"))
         (response
          (dispatch-request auth
                            (λ (_) (error 'test "unexpected dispatch"))
                            request)))
    (check-equal? (response-code response) 415)
    (check-equal? (hash-ref (response-jsexpr response) 'error)
                  "json-required"))

  (let* ((auth (make-auth-manager '()))
         (dispatch (make-dispatch 'unused-player auth))
         (response (dispatch (test-request #"GET" "/api/auth/status")))
         (data (response-jsexpr response)))
    (check-equal? (response-code response) 200)
    (check-false (hash-ref data 'enabled))
    (check-true (hash-ref data 'authenticated))
    (check-equal? (hash-ref data 'username) "anonymous")))