You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
135 lines
4.3 KiB
Scheme
135 lines
4.3 KiB
Scheme
(use sql-de-lite crypt)
|
|
|
|
(define *db* "/home/tjhintz/db")
|
|
|
|
(define-syntax with-db
|
|
(syntax-rules ()
|
|
((_ (var) body ...)
|
|
(call-with-database *db*
|
|
(lambda (var)
|
|
body ...)))))
|
|
|
|
(define (create-tables)
|
|
(with-db (db)
|
|
(exec (sql db "create table users(id INTEGER PRIMARY KEY, username TEXT, email TEXT, password TEXT, salt TEXT);"))
|
|
(exec (sql db "create table sessions(bindings TEXT, session_id TEXT PRIMARY KEY);"))
|
|
(exec (sql db "create table games(id INTEGER PRIMARY KEY, status TEXT, object TEXT, updated INTEGER);"))
|
|
(exec (sql db "create table players(id INTEGER PRIMARY KEY, object TEXT);"))
|
|
(exec (sql db "create table user_games(user_id INTEGER, game_id INTEGER);"))))
|
|
|
|
(define (db-session-set! sid bindings)
|
|
(with-db (db)
|
|
(exec (sql db "insert or replace into sessions(bindings, session_id) values (?, ?);")
|
|
(with-output-to-string (lambda () (write bindings)))
|
|
sid)))
|
|
|
|
(define (db-session-ref sid)
|
|
(with-input-from-string
|
|
(or (alist-ref
|
|
'bindings
|
|
(with-db (db)
|
|
(query fetch-alist
|
|
(sql db "select * from sessions where session_id=?;")
|
|
sid)))
|
|
"#f")
|
|
read))
|
|
|
|
(define (add-user username email password)
|
|
(let ((salt (crypt-gensalt)))
|
|
(with-db (db)
|
|
(exec (sql db "insert into users(username, password, salt, email) values(?, ?, ?, ?);")
|
|
username (crypt password salt) salt email)
|
|
(last-insert-rowid db))))
|
|
|
|
(define (fetch-user username)
|
|
(with-db (db)
|
|
(query fetch-alist
|
|
(sql db "select * from users where username=?;")
|
|
username)))
|
|
|
|
(define (fetch-user-by-id id)
|
|
(with-db (db)
|
|
(query fetch-alist
|
|
(sql db "select * from users where id=?;")
|
|
id)))
|
|
|
|
(define (valid-password? username password)
|
|
(and-let* ((user (fetch-user username))
|
|
(_ (if (null? user)
|
|
(begin (crypt password "$2a$12$OW1wyLclJvq.PIxgoHCjdu")
|
|
#f)
|
|
#t)))
|
|
(string=? (crypt password (alist-ref 'salt user))
|
|
(alist-ref 'password user))))
|
|
|
|
(define (alist->string alist)
|
|
(with-output-to-string (lambda () (write alist))))
|
|
|
|
(define (string->alist s)
|
|
(with-input-from-string s read))
|
|
|
|
(define (db-add-game status object)
|
|
(with-db (db)
|
|
(exec (sql db "insert into games(status, object, updated) values (?, ?, ?);")
|
|
status (alist->string object) (current-seconds))
|
|
(last-insert-rowid db)))
|
|
|
|
(define (db-update-game id status object)
|
|
(with-db (db)
|
|
(exec (sql db "replace into games(id, status, object, updated) values (?, ?, ?, ?);")
|
|
id status (alist->string object) (current-seconds))))
|
|
|
|
(define (db-fetch-game id)
|
|
(string->alist
|
|
(with-db (db)
|
|
(query fetch-value
|
|
(sql db "select object from games where id=?;")
|
|
id))))
|
|
|
|
(define (db-fetch-open-games)
|
|
(map
|
|
string->alist
|
|
(with-db (db)
|
|
(query fetch-column
|
|
(sql db "select object from games where status=? order by updated desc;")
|
|
"pre-game"))))
|
|
|
|
(define (db-fetch-game-row id)
|
|
(let ((res
|
|
(with-db (db)
|
|
(query fetch-alist
|
|
(sql db "select * from games where id=?;")
|
|
id))))
|
|
`((id . ,(alist-ref 'id res))
|
|
(status . ,(alist-ref 'status res))
|
|
(object . ,(string->alist (alist-ref 'object res))))))
|
|
|
|
(define (db-add-player object)
|
|
(with-db (db)
|
|
(exec (sql db "insert into players(object) values (?);")
|
|
(alist->string object))
|
|
(last-insert-rowid db)))
|
|
|
|
(define (db-update-player id object)
|
|
(with-db (db)
|
|
(exec (sql db "replace into players(id, object) values (?, ?);")
|
|
id (alist->string object))))
|
|
|
|
(define (db-fetch-player id)
|
|
(string->alist
|
|
(with-db (db)
|
|
(query fetch-value
|
|
(sql db "select object from players where id=?;")
|
|
id))))
|
|
|
|
(define (db-add-user-game user-id game-id)
|
|
(with-db (db)
|
|
(exec (sql db "insert into user_games(user_id, game_id) values (?, ?);")
|
|
user-id game-id)))
|
|
|
|
(define (db-fetch-user-games user-id)
|
|
(with-db (db)
|
|
(query fetch-column
|
|
(sql db "select game_id from user_games join games on user_games.game_id=games.id where user_games.user_id=? and not games.status=? order by updated desc;")
|
|
user-id "finished")))
|