summaryrefslogtreecommitdiffstats
path: root/src/server/db.scm
blob: 417207da753aa7595991972a190663f1d55b274f (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
(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-remove-user-game user-id game-id)
  (with-db (db)
    (exec (sql db "delete from user_games where user_id=? and game_id=?;")
          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")))