summaryrefslogtreecommitdiffstats
path: root/src/server/db.scm
diff options
context:
space:
mode:
authorThomas Hintz <t@thintz.com>2020-04-09 22:52:44 -0700
committerThomas Hintz <t@thintz.com>2020-04-09 22:52:44 -0700
commit6ff6387fef921e0d0673bba89d0000a9f582dde9 (patch)
tree1ca45554d5eca92628e344798a94467f892ce7e5 /src/server/db.scm
parentb34a66f697aa72d4d772a84502cc9c5071141f0e (diff)
downloadfarm-6ff6387fef921e0d0673bba89d0000a9f582dde9.tar.gz
Using sqlite database, mt proctor animation.
Diffstat (limited to 'src/server/db.scm')
-rw-r--r--src/server/db.scm134
1 files changed, 134 insertions, 0 deletions
diff --git a/src/server/db.scm b/src/server/db.scm
new file mode 100644
index 0000000..f461447
--- /dev/null
+++ b/src/server/db.scm
@@ -0,0 +1,134 @@
+(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);"))
+ (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) values (?, ?);")
+ status (alist->string object))
+ (last-insert-rowid db)))
+
+(define (db-update-game id status object)
+ (with-db (db)
+ (exec (sql db "replace into games(id, status, object) values (?, ?, ?);")
+ id status (alist->string object))))
+
+(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=?;")
+ "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 where user_id=?;")
+ user-id)))