You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 

123 lines
5.2 KiB

(in-package :nea/ircd)
(defun register-user (username plaintext-password email)
"Registers a user with a given USERNAME, PLAINTEXT-PASSWORD and EMAIL, returning the ID of the new user created."
(declare (type string username plaintext-password email))
(unless (scan *username-regex* username)
(error "Username contains invalid characters."))
(pomo:with-transaction ()
(let ((uid (pomo:query (:insert-into 'users
:set 'username '$1 'server 1
:returning 'id)
username :single!)))
(pomo:execute (:insert-into 'local_users
:set 'user_id '$1 'password "*" 'email '$2)
uid email)
(change-user-password uid plaintext-password)
uid)))
(defun password-to-bytes (password)
"Converts the string PASSWORD to UTF-8 bytes."
(declare (type string password))
(babel:string-to-octets password
:encoding :utf-8))
(defun change-user-password (uid password)
"Changes the password of the user with id UID to PASSWORD.
Raises an error if that user doesn't exist."
(declare (type integer uid) (type string password))
(let* ((password (password-to-bytes password))
(pw-string (ironclad:pbkdf2-hash-password-to-combined-string password)))
(execute-one (:update 'local_users
:set 'password '$1
:where (:= 'user_id '$2))
pw-string uid)))
(defun check-user-credentials (username password)
"Checks whether USERNAME and PASSWORD can be used to authenticate to a local user account.
If they authenticate successfully, returns the user ID; if they don't, returns NIL."
(declare (type string username password))
(let ((provided-pw (password-to-bytes password))
(user-info
(pomo:query (:select 'local_users.password 'users.id
:from 'users
:inner-join 'local_users :on (:= 'local_users.user_id 'users.id)
:where (:= 'users.username '$1))
username :row)))
(when user-info
(destructuring-bind (pw-string uid) user-info
(when (ironclad:pbkdf2-check-password provided-pw pw-string)
uid)))))
(defun get-user-device (uid device-name)
"Gets or creates a user device (called DEVICE-NAME) for the user with ID UID."
(declare (type integer uid) (type string device-name))
(pomo:with-logical-transaction ()
(let ((maybe-device
(pomo:query (:select 'id
:from 'local_user_devices
:where (:and
(:= 'name '$1)
(:= 'user_id '$2)))
device-name uid :single)))
(if maybe-device
maybe-device
(pomo:query (:insert-into 'local_user_devices
:set 'user_id '$1 'name '$2
:returning 'id)
uid device-name :single!)))))
(defun get-user-source (uid)
"Gets an IRC message source for the user with ID UID."
(declare (type integer uid))
(let ((info (pomo:query (:select 'users.username 'users.server 'servers.domain
:from 'users
:inner-join 'servers :on (:= 'users.server 'servers.id)
:where (:= 'users.id '$1))
uid :row)))
(if info
(destructuring-bind (username sid domain) info
(make-irc-message-source
(if (eql sid *local-server-id*) *server-name* domain)
:nick username
:user username))
(error "No user has UID ~A." uid))))
(defun query-user-target (target)
"Convert a possible TARGET expression to a user ID.
TARGET can be formatted like:
- user@domain.name (searches for `user' on server `domain.name')
- user|hex-id (where hex-id is a hexidecimal number representing a server's internal server ID; searches for `user' on that server)
- just an ordinary nickname (searches for that nickname on the local server)"
(declare (type string target))
(multiple-value-bind (nick-part host-part)
(split-string-at-first target #\@ t t)
(if (string-empty-p host-part)
(multiple-value-bind (nick-part id-part)
(split-string-at-first target #\| t t)
(let ((id (parse-integer id-part
:radix 16
:junk-allowed t)))
(if id
(pomo:query
(:select 'users.id
:from 'users 'servers
:where (:and
(:= 'servers.id '$1)
(:= 'users.username '$2)))
id nick-part :single)
(pomo:query
(:select 'id
:from :users
:where (:and
(:= 'server '$1)
(:= 'username '$2)))
*local-server-id* target :single))))
(pomo:query
(:select 'users.id
:from 'users 'servers
:where (:and
(:= 'servers.id 'users.server)
(:= 'servers.domain '$1)
(:= 'users.username '$2)))
host-part nick-part :single))))