user admin

private/server.rkt

@@ -6,12 +6,15 @@
          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")
+         "player.rkt"
+         "users.rkt")
 
 (provide serve-player)
 
@@ -22,12 +25,13 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define current-player #f)
+(define current-auth #f)
 
-(define (json-response value #:code [code 200])
+(define (json-response value #:code [code 200] #:headers [headers '()])
   (response/jsexpr
    value
    #:code code
-   #:headers (list (header #"Cache-Control" #"no-store"))))
+   #:headers (cons (header #"Cache-Control" #"no-store") headers)))
 
 (define (error-response exception)
   (json-response
@@ -46,6 +50,50 @@
         (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)))
 
@@ -123,8 +171,11 @@
          (hasheq 'error "track artwork is unavailable")
          #:code 404))))
 
-(define-values (dispatch _url)
+(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]
@@ -137,6 +188,37 @@
     #: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
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -148,15 +230,19 @@
 ; 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)
-       (#:listen-ip string?
+       (#: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