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

private/users.rkt

@@ -0,0 +1,334 @@
+#lang racket/base
+
+(require crypto
+         crypto/argon2
+         net/private/ip
+         racket/list
+         racket/random
+         racket/string
+         web-server/http
+         web-server/http/cookie-parse)
+
+(provide make-password-hash
+         password-hash-valid?
+         make-auth-manager
+         auth-manager?
+         auth-enabled?
+         auth-request-local?
+         auth-request-user
+         auth-login!
+         auth-logout!
+         auth-session-cookie
+         auth-expired-cookie)
+
+(struct ip-network (address prefix) #:transparent)
+(struct session (username [last-seen #:mutable]) #:transparent)
+(struct failures ([attempts #:mutable] [started #:mutable]) #:transparent)
+(struct auth-manager
+  (users local-networks trusted-proxies session-seconds sessions failed lock)
+  #:transparent)
+
+(define password-kdf
+  (or (get-kdf 'argon2id argon2-factory)
+      (error 'rkt-web-player/users "Argon2id is unavailable")))
+
+(define password-parameters
+  '((m 19456) (t 2) (p 1)))
+
+;; Used to make an unknown username take the same expensive verification path.
+(define dummy-password-hash
+  "$argon2id$v=19$m=19456,t=2,p=1$WrJi0t7NsbD3adX8kxrT/g$yCIf2Ork8G8PRdIcA0bEIYIdMwzunrTou/BKcM4cO/0")
+
+(define session-cookie-name "rkt-web-player-session")
+(define failure-window-seconds 300)
+(define maximum-failures 5)
+
+(define (make-password-hash password)
+  (unless (and (string? password)
+               (>= (string-length password) 12))
+    (raise-argument-error
+     'make-password-hash
+     "string containing at least 12 characters"
+     password))
+  (pwhash password-kdf
+          (string->bytes/utf-8 password)
+          password-parameters))
+
+(define (password-hash-valid? password encoded)
+  (and (string? password)
+       (string? encoded)
+       (with-handlers ((exn:fail? (lambda (_) #f)))
+         (pwhash-verify password-kdf
+                        (string->bytes/utf-8 password)
+                        encoded))))
+
+(define (normal-ip-bytes value)
+  (define raw
+    (ip-address->bytes (make-ip-address value)))
+  ;; Normalize IPv4-mapped IPv6 addresses to four bytes.
+  (if (and (= (bytes-length raw) 16)
+           (for/and ((index (in-range 10)))
+             (zero? (bytes-ref raw index)))
+           (= (bytes-ref raw 10) #xff)
+           (= (bytes-ref raw 11) #xff))
+      (subbytes raw 12)
+      raw))
+
+(define (parse-network value)
+  (define parts (string-split (string-trim value) "/"))
+  (unless (member (length parts) '(1 2))
+    (raise-argument-error 'make-auth-manager "IP address or CIDR network" value))
+  (define address
+    (with-handlers ((exn:fail?
+                     (lambda (_)
+                       (raise-argument-error
+                        'make-auth-manager
+                        "IP address or CIDR network"
+                        value))))
+      (normal-ip-bytes (car parts))))
+  (define maximum (* 8 (bytes-length address)))
+  (define prefix
+    (if (= (length parts) 2)
+        (string->number (cadr parts))
+        maximum))
+  (unless (and (exact-nonnegative-integer? prefix)
+               (<= prefix maximum))
+    (raise-argument-error 'make-auth-manager "IP address or CIDR network" value))
+  (ip-network address prefix))
+
+(define (network-contains? network address-string)
+  (with-handlers ((exn:fail? (lambda (_) #f)))
+    (define candidate (normal-ip-bytes address-string))
+    (define expected (ip-network-address network))
+    (and (= (bytes-length candidate) (bytes-length expected))
+         (let-values (((whole remainder)
+                       (quotient/remainder (ip-network-prefix network) 8)))
+           (and (for/and ((index (in-range whole)))
+                  (= (bytes-ref candidate index)
+                     (bytes-ref expected index)))
+                (or (zero? remainder)
+                    (let ((mask
+                           (bitwise-and #xff
+                                        (arithmetic-shift #xff (- remainder 8)))))
+                      (= (bitwise-and (bytes-ref candidate whole) mask)
+                         (bitwise-and (bytes-ref expected whole) mask)))))))))
+
+(define (header-string request name)
+  (let ((value (headers-assq* name (request-headers/raw request))))
+    (and value
+         (bytes->string/utf-8 (header-value value)))))
+
+(define (trusted-proxy? manager address)
+  (ormap (lambda (network) (network-contains? network address))
+         (auth-manager-trusted-proxies manager)))
+
+(define (request-address manager request)
+  (define peer (request-client-ip request))
+  (define forwarded
+    (and (trusted-proxy? manager peer)
+         (header-string request #"X-Forwarded-For")))
+  (if forwarded
+      ;; A trusted reverse proxy appends the address it observed. Earlier
+      ;; values can have been supplied by the untrusted client.
+      (string-trim (last (string-split forwarded ",")))
+      peer))
+
+(define (auth-enabled? manager)
+  (positive? (hash-count (auth-manager-users manager))))
+
+(define (auth-request-local? manager request)
+  (ormap (lambda (network)
+           (network-contains? network (request-address manager request)))
+         (auth-manager-local-networks manager)))
+
+(define (request-session-token request)
+  (for/or ((cookie (in-list (request-cookies request))))
+    (and (string=? (client-cookie-name cookie) session-cookie-name)
+         (client-cookie-value cookie))))
+
+(define (prune-sessions! manager now)
+  (for ((token (in-list (hash-keys (auth-manager-sessions manager)))))
+    (let ((value (hash-ref (auth-manager-sessions manager) token)))
+      (when (> (- now (session-last-seen value))
+               (auth-manager-session-seconds manager))
+        (hash-remove! (auth-manager-sessions manager) token)))))
+
+(define (auth-request-user manager request)
+  (cond
+    ((not (auth-enabled? manager)) "anonymous")
+    ((auth-request-local? manager request) "local")
+    (else
+     (let ((token (request-session-token request))
+           (now (current-seconds)))
+       (and token
+            (call-with-semaphore
+             (auth-manager-lock manager)
+             (lambda ()
+               (prune-sessions! manager now)
+               (let ((value (hash-ref (auth-manager-sessions manager)
+                                      token
+                                      #f)))
+                 (and value
+                      (begin
+                        (set-session-last-seen! value now)
+                        (session-username value)))))))))))
+
+(define (failure-blocked? manager address now)
+  (define value (hash-ref (auth-manager-failed manager) address #f))
+  (and value
+       (if (> (- now (failures-started value)) failure-window-seconds)
+           (begin
+             (hash-remove! (auth-manager-failed manager) address)
+             #f)
+           (>= (failures-attempts value) maximum-failures))))
+
+(define (record-failure! manager address now)
+  (define value (hash-ref (auth-manager-failed manager) address #f))
+  (if (and value
+           (<= (- now (failures-started value)) failure-window-seconds))
+      (set-failures-attempts! value (+ 1 (failures-attempts value)))
+      (hash-set! (auth-manager-failed manager)
+                 address
+                 (failures 1 now))))
+
+;; Returns a new token, #f for invalid credentials, or 'rate-limited.
+(define (auth-login! manager request username password)
+  (define address (request-address manager request))
+  (define now (current-seconds))
+  (define normalized (string-downcase (string-trim username)))
+  (call-with-semaphore
+   (auth-manager-lock manager)
+   (lambda ()
+     (if (failure-blocked? manager address now)
+         'rate-limited
+         (let* ((stored (hash-ref (auth-manager-users manager)
+                                  normalized
+                                  #f))
+                (valid?
+                 (password-hash-valid?
+                  password
+                  (or stored dummy-password-hash))))
+           (if (and stored valid?)
+               (let ((token
+                      (bytes->hex-string (crypto-random-bytes 32))))
+                 (hash-remove! (auth-manager-failed manager) address)
+                 (prune-sessions! manager now)
+                 (hash-set! (auth-manager-sessions manager)
+                            token
+                            (session normalized now))
+                 token)
+               (begin
+                 (record-failure! manager address now)
+                 #f)))))))
+
+(define (auth-logout! manager request)
+  (let ((token (request-session-token request)))
+    (when token
+      (call-with-semaphore
+       (auth-manager-lock manager)
+       (lambda ()
+         (hash-remove! (auth-manager-sessions manager) token))))))
+
+(define (auth-session-cookie manager token)
+  (string->bytes/utf-8
+   (format
+    "~a=~a; Path=/; Max-Age=~a; Secure; HttpOnly; SameSite=Strict"
+    session-cookie-name
+    token
+    (auth-manager-session-seconds manager))))
+
+(define (auth-expired-cookie)
+  (string->bytes/utf-8
+   (format
+    "~a=; Path=/; Max-Age=0; Secure; HttpOnly; SameSite=Strict"
+    session-cookie-name)))
+
+(define (make-auth-manager user-pairs
+                           #:local-networks
+                           [local-network-values
+                            '("127.0.0.0/8" "::1/128"
+                              "10.0.0.0/8" "172.16.0.0/12"
+                              "192.168.0.0/16")]
+                           #:trusted-proxies
+                           [trusted-proxy-values '("127.0.0.0/8" "::1/128")]
+                           #:session-seconds [session-seconds 43200])
+  (unless (exact-positive-integer? session-seconds)
+    (raise-argument-error 'make-auth-manager "exact-positive-integer?"
+                          session-seconds))
+  (define users (make-hash))
+  (for ((entry (in-list user-pairs)))
+    (unless (and (pair? entry)
+                 (string? (car entry))
+                 (string? (cdr entry)))
+      (raise-argument-error
+       'make-auth-manager
+       "(listof (cons/c string? string?))"
+       user-pairs))
+    (when (string=? (string-trim (car entry)) "")
+      (raise-arguments-error
+       'make-auth-manager
+       "username must not be empty"
+       "username" (car entry)))
+    (unless (regexp-match? #px"^[$]argon2id[$]" (cdr entry))
+      (raise-arguments-error
+       'make-auth-manager
+       "user password is not an Argon2id hash"
+       "username" (car entry)))
+    (hash-set! users (string-downcase (string-trim (car entry)))
+               (cdr entry)))
+  (auth-manager users
+                (map parse-network local-network-values)
+                (map parse-network trusted-proxy-values)
+                session-seconds
+                (make-hash)
+                (make-hash)
+                (make-semaphore 1)))
+
+(module+ test
+  (require net/url
+           rackunit
+           racket/promise
+           web-server/http/request-structs)
+
+  (define test-hash (make-password-hash "correct horse battery staple"))
+  (check-true (password-hash-valid? "correct horse battery staple" test-hash))
+  (check-false (password-hash-valid? "incorrect password" test-hash))
+
+  (define manager
+    (make-auth-manager
+     (list (cons "Hans" test-hash))
+     #:local-networks '("192.168.1.0/24")
+     #:trusted-proxies '("127.0.0.1/32")))
+
+  (define (test-request peer [headers '()])
+    (request #"GET" (string->url "http://example.test/api/state")
+             headers (delay '()) #f "127.0.0.1" 80 peer))
+
+  (check-true (auth-request-local? manager (test-request "192.168.1.42")))
+  (check-false (auth-request-local? manager (test-request "192.168.2.42")))
+  (check-true
+   (auth-request-local?
+    manager
+    (test-request "127.0.0.1"
+                  (list (header #"X-Forwarded-For" #"198.51.100.2, 192.168.1.8")))))
+  (check-false
+   (auth-request-local?
+    manager
+    (test-request "198.51.100.2"
+                  (list (header #"X-Forwarded-For" #"192.168.1.8")))))
+
+  (define remote (test-request "198.51.100.2"))
+  (define token
+    (auth-login! manager remote "hans" "correct horse battery staple"))
+  (check-true (string? token))
+  (define authenticated
+    (test-request
+     "198.51.100.2"
+     (list
+      (header #"Cookie"
+              (string->bytes/utf-8
+               (format "~a=~a" session-cookie-name token))))))
+  (check-equal? (auth-request-user manager authenticated) "hans")
+  (auth-logout! manager authenticated)
+  (check-false (auth-request-user manager authenticated))
+  (check-false (auth-login! manager remote "hans" "wrong password")))