refactoring
This commit is contained in:
+238
-106
@@ -21,43 +21,46 @@
|
||||
(define-runtime-path public-directory "../public")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; HTTP handlers
|
||||
;; Supporting functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define current-player #f)
|
||||
(define current-auth #f)
|
||||
|
||||
;;; 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))))
|
||||
|
||||
(define (auth-status-handler request)
|
||||
(let ((user (auth-request-user current-auth request)))
|
||||
;;; 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? current-auth)
|
||||
(hasheq 'enabled (auth-enabled? auth)
|
||||
'authenticated (and user #t)
|
||||
'username (or user 'null)))))
|
||||
|
||||
(define (auth-login-handler request)
|
||||
;;; 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))
|
||||
@@ -66,16 +69,16 @@
|
||||
(raise-arguments-error
|
||||
'login
|
||||
"username and password must be strings"))
|
||||
(let ((result (auth-login! current-auth request username password)))
|
||||
(let ((result (auth-login! auth request username password)))
|
||||
(cond
|
||||
((eq? result 'rate-limited)
|
||||
(json-response
|
||||
(hasheq 'error "Te veel mislukte aanmeldpogingen; probeer het over enkele minuten opnieuw"
|
||||
(hasheq 'error "login-rate-limited"
|
||||
'code "login-rate-limited")
|
||||
#:code 429))
|
||||
((not result)
|
||||
(json-response
|
||||
(hasheq 'error "Ongeldige gebruikersnaam of wachtwoord"
|
||||
(hasheq 'error "invalid-credentials"
|
||||
'code "invalid-credentials")
|
||||
#:code 401))
|
||||
(else
|
||||
@@ -84,79 +87,89 @@
|
||||
'username (string-downcase (string-trim username)))
|
||||
#:headers
|
||||
(list (header #"Set-Cookie"
|
||||
(auth-session-cookie current-auth result))))))))))
|
||||
(auth-session-cookie auth result))))))))))
|
||||
|
||||
(define (auth-logout-handler request)
|
||||
(auth-logout! current-auth request)
|
||||
;;; 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)))))
|
||||
|
||||
(define (request-username request)
|
||||
(or (auth-request-user current-auth request) "anonymous"))
|
||||
;;; Resolves the authenticated username or the anonymous playlist owner.
|
||||
(define (request-username auth request)
|
||||
(or (auth-request-user auth request) "anonymous"))
|
||||
|
||||
(define (state-handler request)
|
||||
;;; Returns the player state belonging to the requesting user.
|
||||
(define (state-handler player auth request)
|
||||
(json-response
|
||||
(player-state->jsexpr
|
||||
current-player
|
||||
#:username (request-username request))))
|
||||
player
|
||||
#:username (request-username auth request))))
|
||||
|
||||
(define (discover-handler request)
|
||||
(player-discover! current-player)
|
||||
;;; Starts renderer discovery and returns the updated player state.
|
||||
(define (discover-handler player auth request)
|
||||
(player-discover! player)
|
||||
(json-response
|
||||
(player-state->jsexpr
|
||||
current-player
|
||||
#:username (request-username request))))
|
||||
player
|
||||
#:username (request-username auth request))))
|
||||
|
||||
(define (command-handler request command)
|
||||
;;; 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!
|
||||
current-player
|
||||
player
|
||||
command
|
||||
(request-jsexpr request)
|
||||
#:username (request-username request)))))
|
||||
#:username (request-username auth request)))))
|
||||
|
||||
(define (preferences-handler request)
|
||||
;;; Returns the persisted interface preferences for the requesting user.
|
||||
(define (preferences-handler player auth request)
|
||||
(json-response
|
||||
(hasheq
|
||||
'language
|
||||
(or (player-user-language
|
||||
current-player
|
||||
#:username (request-username request))
|
||||
player
|
||||
#:username (request-username auth request))
|
||||
'null))))
|
||||
|
||||
(define (preferences-update-handler request)
|
||||
;;; Validates and persists the requesting user's interface language.
|
||||
(define (preferences-update-handler player auth request)
|
||||
(with-handlers ((exn:fail? error-response))
|
||||
(define language (hash-ref (request-jsexpr request) 'language #f))
|
||||
(player-user-language!
|
||||
current-player
|
||||
language
|
||||
#:username (request-username request))
|
||||
(json-response (hasheq 'language language))))
|
||||
(let ((language (hash-ref (request-jsexpr request) 'language #f)))
|
||||
(player-user-language!
|
||||
player
|
||||
language
|
||||
#:username (request-username auth request))
|
||||
(json-response (hasheq 'language language)))))
|
||||
|
||||
(define (agent-register-handler request)
|
||||
;;; 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!
|
||||
current-player
|
||||
player
|
||||
(request-jsexpr request)))))
|
||||
|
||||
(define (agent-poll-handler 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!
|
||||
current-player
|
||||
player
|
||||
(request-jsexpr request)))))
|
||||
|
||||
(define (agent-media-handler _request app-id token)
|
||||
(let ((file (player-agent-media current-player app-id token)))
|
||||
;;; 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)
|
||||
@@ -179,50 +192,34 @@
|
||||
(hasheq 'error "media token is invalid or expired")
|
||||
#:code 404))))
|
||||
|
||||
(define (artwork-handler request artwork-id)
|
||||
;;; Streams cached artwork belonging to a track visible to the user.
|
||||
(define (artwork-handler player auth request artwork-id)
|
||||
(let ((value (player-track-artwork
|
||||
current-player
|
||||
player
|
||||
artwork-id
|
||||
#:username (request-username request))))
|
||||
#:username (request-username auth request))))
|
||||
(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")))
|
||||
(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))))
|
||||
|
||||
(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" "preferences") #:method "get" preferences-handler]
|
||||
[("api" "preferences") #:method "post" preferences-update-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]))
|
||||
|
||||
;;; 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))))
|
||||
@@ -230,6 +227,7 @@
|
||||
(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)))
|
||||
@@ -251,40 +249,95 @@
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Dispatch an API request and renew an eligible browser cookie.
|
||||
; pre : Current-player and current-auth are initialized and request targets
|
||||
; an API route.
|
||||
; 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 request)
|
||||
(define value (api-dispatch request))
|
||||
(define renewed-cookie
|
||||
(and (not (regexp-match? #px"^/api/agent(?:/|$)"
|
||||
(request-path request)))
|
||||
(auth-renewal-cookie current-auth request)))
|
||||
(if renewed-cookie
|
||||
(response-add-header value (header #"Set-Cookie" renewed-cookie))
|
||||
value))
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(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)))
|
||||
|
||||
(define (dispatch request)
|
||||
;;; 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 "Content-Type application/json is vereist"
|
||||
(hasheq 'error "json-required"
|
||||
'code "json-required")
|
||||
#:code 415))
|
||||
((or (public-api-request? request)
|
||||
(auth-request-user current-auth request))
|
||||
(dispatch-api request))
|
||||
(auth-request-user auth request))
|
||||
(dispatch-api auth api-dispatch request))
|
||||
(else
|
||||
(json-response
|
||||
(hasheq 'error "Aanmelden is vereist"
|
||||
(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
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
@@ -294,6 +347,9 @@
|
||||
; 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
|
||||
@@ -301,21 +357,97 @@
|
||||
#:listen-ip [listen-ip "127.0.0.1"]
|
||||
#:port [port 8080]
|
||||
#:launch-browser? [launch-browser? #t])
|
||||
(->* (any/c)
|
||||
(->* (player?)
|
||||
(#: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)))
|
||||
(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")))
|
||||
|
||||
Reference in New Issue
Block a user