#lang racket/base

(require crypto
         crypto/libcrypto
         db
         racket/list
         racket/string
         web-server/http/cookie-parse
         "config.rkt"
         "database.rkt")

(provide (struct-out wiki-user)
         (struct-out wiki-session)
         authenticate-user
         create-session!
         delete-session!
         session-from-request
         csrf-valid?
         role-at-least?
         list-users
         administrator-exists?
         create-user!
         upsert-user!
         update-user!
         delete-user!)

(struct wiki-user (id username display-name role enabled?) #:transparent)
(struct wiki-session (user csrf-token expires-at token) #:transparent)

(crypto-factories (list libcrypto-factory))

(define role-order
  (hash 'reader 10
        'editor 20
        'admin 30))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Check whether a user has a required role level.
; pre    : required-role is reader, editor or admin; user is a wiki-user or #f.
; post   : No external state has been changed.
; result : #t when the user has the required role level, otherwise #f.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (role-at-least? user required-role)
  (and user
       (>= (hash-ref role-order (wiki-user-role user) 0)
           (hash-ref role-order required-role 100))))

(define (bytes->hex value)
  (apply string-append
         (for/list ([byte (in-bytes value)])
           (define hex (number->string byte 16))
           (if (= (string-length hex) 1)
               (string-append "0" hex)
               hex))))

(define (random-token [size 32])
  (bytes->hex (crypto-random-bytes size)))

(define (token-hash token)
  (bytes->hex (digest 'sha256 (string->bytes/utf-8 token))))

(define (password-hash password)
  (pwhash '(pbkdf2 hmac sha256)
          (string->bytes/utf-8 password)
          '((iterations 600000))))

(define (password-valid? password stored-hash)
  (with-handlers ((exn:fail? (λ (_e) #f)))
    (pwhash-verify #f (string->bytes/utf-8 password) stored-hash)))

(define (row->user row)
  (wiki-user (vector-ref row 0)
             (vector-ref row 1)
             (vector-ref row 2)
             (string->symbol (vector-ref row 3))
             (vector-ref row 4)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Authenticate an enabled wiki user.
; pre    : username and password are strings.
; post   : The user database has only been read.
; result : A wiki-user on success, otherwise #f.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (authenticate-user config username password)
  (call-with-wiki-database
   config
   (λ (db)
     (define row
       (query-maybe-row
        db
        "SELECT id, username, display_name, role, enabled, password_hash FROM users WHERE username = $1"
        username))
     (cond
       ((not row) #f)
       ((not (vector-ref row 4)) #f)
       ((not (password-valid? password (vector-ref row 5))) #f)
       (else
        (wiki-user (vector-ref row 0)
                   (vector-ref row 1)
                   (vector-ref row 2)
                   (string->symbol (vector-ref row 3))
                   #t))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Create a login session for a user.
; pre    : user is an enabled wiki-user.
; post   : A hashed session token and CSRF token have been stored in PostgreSQL.
; result : A wiki-session containing the client session token.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (create-session! config user)
  (define token (random-token))
  (define csrf-token (random-token 24))
  (define now (current-seconds))
  (define expires-at (+ now (wiki-config-session-seconds config)))
  (call-with-wiki-database
   config
   (λ (db)
     (query-exec db
                 "INSERT INTO sessions(token_hash, user_id, csrf_token, created_at, expires_at) VALUES ($1, $2, $3, $4, $5)"
                 (token-hash token)
                 (wiki-user-id user)
                 csrf-token
                 now
                 expires-at)))
  (wiki-session user csrf-token expires-at token))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Delete a login session.
; pre    : token is a session token string or #f.
; post   : The matching stored session has been deleted when token was supplied.
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (delete-session! config token)
  (when token
    (call-with-wiki-database
     config
     (λ (db)
       (query-exec db
                   "DELETE FROM sessions WHERE token_hash = $1"
                   (token-hash token))))))

(define (session-cookie-token req)
  (define cookie
    (findf (λ (candidate)
             (string=? (client-cookie-name candidate) "racket-wiki-session"))
           (request-cookies req)))
  (if cookie
      (client-cookie-value cookie)
      #f))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Resolve an authenticated session from a request cookie.
; pre    : req is a web-server request.
; post   : The user and session tables have only been read.
; result : A non-expired wiki-session for an enabled user, or #f.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (session-from-request config req)
  (define token (session-cookie-token req))
  (if token
      (call-with-wiki-database
       config
       (λ (db)
         (define row
           (query-maybe-row
            db
            #<<SQL
SELECT u.id, u.username, u.display_name, u.role, u.enabled,
       s.csrf_token, s.expires_at
FROM sessions s
JOIN users u ON u.id = s.user_id
WHERE s.token_hash = $1 AND s.expires_at > $2 AND u.enabled = TRUE
SQL
            (token-hash token)
            (current-seconds)))
         (if row
             (wiki-session
              (wiki-user (vector-ref row 0)
                         (vector-ref row 1)
                         (vector-ref row 2)
                         (string->symbol (vector-ref row 3))
                         (vector-ref row 4))
              (vector-ref row 5)
              (vector-ref row 6)
              token)
             #f)))
      #f))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Validate a CSRF token for a session.
; pre    : session is a wiki-session or #f and csrf-token is a string or #f.
; post   : No external state has been changed.
; result : #t when the supplied token belongs to the session, otherwise #f.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (csrf-valid? session csrf-token)
  (and session
       csrf-token
       (string=? csrf-token (wiki-session-csrf-token session))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : List wiki users.
; pre    : The user database is initialized.
; post   : The user table has only been read.
; result : A username-sorted list of wiki-user values.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (list-users config)
  (call-with-wiki-database
   config
   (λ (db)
     (for/list ([row (in-list (query-rows db
                                         "SELECT id, username, display_name, role, enabled FROM users ORDER BY username"))])
       (row->user row)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Check whether at least one enabled administrator exists.
; pre    : The user database is initialized.
; post   : The user table has only been read.
; result : #t when an enabled administrator exists, otherwise #f.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (administrator-exists? config)
  (call-with-wiki-database
   config
   (λ (db)
     (> (query-value db
                     "SELECT COUNT(*) FROM users WHERE role = 'admin' AND enabled = TRUE")
        0))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Create a wiki user.
; pre    : username is unused and role/status are supported symbols.
; post   : The new user and password hash have been stored.
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (create-user! config username display-name password role status)
  (define now (current-seconds))
  (define enabled (eq? status 'enabled))
  (define hash (password-hash password))
  (call-with-wiki-database
   config
   (λ (db)
     (query-exec
      db
      "INSERT INTO users(username, display_name, password_hash, role, enabled, created_at, updated_at) VALUES ($1, $2, $3, $4, $5, $6, $7)"
      username
      display-name
      hash
      (symbol->string role)
      enabled
      now
      now))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Create or reset a wiki user by username.
; pre    : role/status are supported symbols.
; post   : The named user exists with the supplied display name, password, role and status.
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (upsert-user! config username display-name password role status)
  (define now (current-seconds))
  (define enabled (eq? status 'enabled))
  (define hash (password-hash password))
  (call-with-wiki-database
   config
   (λ (db)
     (query-exec
      db
      #<<SQL
INSERT INTO users(username, display_name, password_hash, role, enabled, created_at, updated_at)
VALUES ($1, $2, $3, $4, $5, $6, $7)
ON CONFLICT(username) DO UPDATE SET
  display_name = excluded.display_name,
  password_hash = excluded.password_hash,
  role = excluded.role,
  enabled = excluded.enabled,
  updated_at = excluded.updated_at
SQL
      username display-name hash (symbol->string role) enabled now now))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Update a wiki user.
; pre    : id identifies a user and role/status are supported symbols.
; post   : Display name, role and status are updated; a non-empty password replaces the password hash.
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (update-user! config id display-name role status [password #f])
  (define enabled (eq? status 'enabled))
  (define now (current-seconds))
  (call-with-wiki-database
   config
   (λ (db)
     (if (and password (not (string=? password "")))
         (query-exec db
                     "UPDATE users SET display_name = $1, role = $2, enabled = $3, password_hash = $4, updated_at = $5 WHERE id = $6"
                     display-name
                     (symbol->string role)
                     enabled
                     (password-hash password)
                     now
                     id)
         (query-exec db
                     "UPDATE users SET display_name = $1, role = $2, enabled = $3, updated_at = $4 WHERE id = $5"
                     display-name
                     (symbol->string role)
                     enabled
                     now
                     id)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Delete a wiki user.
; pre    : id identifies a possible user.
; post   : The user and cascading sessions have been deleted when present.
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (delete-user! config id)
  (call-with-wiki-database
   config
   (λ (db)
     (query-exec db "DELETE FROM users WHERE id = $1" id))))