#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")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HTTP handlers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define current-player #f)
(define current-auth #f)

(define (json-response value #:code [code 200] #:headers [headers '()])
  (response/jsexpr
   value
   #:code code
   #:headers (cons (header #"Cache-Control" #"no-store") headers)))

(define (error-response exception)
  (json-response
   (hasheq 'error (exn-message exception))
   #:code 400))

(define (agent-error-response exception)
  (json-response
   (hasheq 'error (exn-message exception)
           'code "agent-not-authorized")
   #:code 403))

(define (request-jsexpr request)
  (let ((body (request-post-data/raw request)))
    (if (and body (positive? (bytes-length body)))
        (bytes->jsexpr body)
        (hasheq))))

(define (auth-status-handler request)
  (let ((user (auth-request-user current-auth request)))
    (json-response
     (hasheq 'enabled (auth-enabled? current-auth)
             'local (auth-request-local? current-auth request)
             'authenticated (and user #t)
             'username (or user 'null)))))

(define (auth-login-handler 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! current-auth request username password)))
        (cond
          ((eq? result 'rate-limited)
           (json-response
            (hasheq 'error "Te veel mislukte aanmeldpogingen; probeer het over enkele minuten opnieuw"
                    'code "login-rate-limited")
            #:code 429))
          ((not result)
           (json-response
            (hasheq 'error "Ongeldige gebruikersnaam of wachtwoord"
                    '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 current-auth result))))))))))

(define (auth-logout-handler request)
  (auth-logout! current-auth request)
  (json-response
   (hasheq 'authenticated #f)
   #:headers
   (list (header #"Set-Cookie" (auth-expired-cookie)))))

(define (state-handler _request)
  (json-response (player-state->jsexpr current-player)))

(define (discover-handler _request)
  (player-discover! current-player)
  (json-response (player-state->jsexpr current-player)))

(define (command-handler request command)
  (with-handlers
      ((exn:fail? error-response))
    (json-response
     (player-command!
      current-player
      command
      (request-jsexpr request)))))

(define (agent-register-handler request)
  (with-handlers
      ((exn:fail:agent-denied? agent-error-response)
       (exn:fail? error-response))
    (json-response
     (player-agent-register!
      current-player
      (request-jsexpr request)))))

(define (agent-poll-handler request)
  (with-handlers
      ((exn:fail:agent-denied? agent-error-response)
       (exn:fail? error-response))
    (json-response
     (player-agent-poll!
      current-player
      (request-jsexpr request)))))

(define (agent-media-handler _request app-id token)
  (let ((file (player-agent-media current-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))))

(define (artwork-handler _request artwork-id)
  (let ((value (player-track-artwork current-player artwork-id)))
    (if value
        (response/output
         (λ (output)
           (write-bytes (artwork-data value) output))
         #:mime-type
         (string->bytes/utf-8 (artwork-mime-type value))
         #:headers
         (list
          (header #"Content-Length"
                  (string->bytes/utf-8
                   (number->string
                    (bytes-length (artwork-data value)))))
          (header #"Cache-Control" #"private, max-age=3600")))
        (json-response
         (hasheq 'error "track artwork is unavailable")
         #:code 404))))

(define-values (api-dispatch _url)
  (dispatch-rules
   [("api" "auth" "status") #:method "get" auth-status-handler]
   [("api" "auth" "login") #:method "post" auth-login-handler]
   [("api" "auth" "logout") #:method "post" auth-logout-handler]
   [("api" "state") #:method "get" state-handler]
   [("api" "discover") #:method "post" discover-handler]
   [("api" "agent" "register") #:method "post" agent-register-handler]
   [("api" "agent" "poll") #:method "post" agent-poll-handler]
   [("api" "agent" "media" (string-arg) (string-arg))
    #:method "get"
    agent-media-handler]
   [("api" "artwork" (string-arg)) #:method "get" artwork-handler]
   [("api" "command" (string-arg))
    #:method "post"
    command-handler]))

(define (request-path request)
  (url->string (request-uri request)))

(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)))))

(define (public-api-request? request)
  (regexp-match? #px"^/api/(?:auth|agent)(?:/|$)"
                 (request-path request)))

(define (dispatch request)
  (cond
    ((and (bytes=? (request-method request) #"POST")
          (not (json-request? request)))
     (json-response
      (hasheq 'error "Content-Type application/json is vereist"
              'code "json-required")
      #:code 415))
    ((or (public-api-request? request)
         (auth-request-user current-auth request))
     (api-dispatch request))
    (else
     (json-response
      (hasheq 'error "Aanmelden is vereist"
              'code "authentication-required")
      #:code 401))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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])
  (->* (any/c)
       (#:auth-manager auth-manager?
        #:listen-ip string?
        #:port exact-positive-integer?
        #:launch-browser? boolean?)
       any)
  (set! current-player value)
  (set! current-auth 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)))