farm/src/server/db.scm

(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")))