db.scm (7176B)
1 (define-module (db) 2 #:export (decrypt-user 3 select-user 4 select-all-users 5 insert-user 6 login-user 7 select-answers 8 select-answers-content 9 insert-answers 10 insert-results 11 insert-score 12 select-results)) 13 (use-modules (ice-9 binary-ports) 14 (rnrs bytevectors) 15 (srfi srfi-1) 16 (srfi srfi-9) 17 (srfi srfi-26) 18 (sodium) 19 (sqlite3)) 20 21 (define keyfile ".SECRET") 22 (define SECRET_KEY 23 (catch #t 24 (lambda () (call-with-input-file keyfile get-bytevector-all)) 25 (lambda (key . args) (generate-key)))) 26 ;(call-with-output-file keyfile (cut put-bytevector <> SECRET_KEY)) 27 28 (define db (sqlite-open "meta.sqlite")) 29 30 (define-record-type <user> 31 (make-user name email password) 32 user? 33 (name user-name) 34 (email user-email) 35 (password user-password)) 36 37 (define (err->msg key who code errmsg) 38 (list #f (case code 39 ((1299) "Niektoré povinné polia chýbajú") 40 ((2067) "Užívateľ s týmito údajmi už existuje") 41 (else (begin (display code (current-error-port)) 42 (display errmsg (current-error-port)) 43 "Niečo sa pokazilo v útrobách metaserveru! Skúste znovu"))))) 44 45 (define (select-user name) 46 (let* ((stmt (sqlite-prepare db "select * from users where 'name' = ?")) 47 (result (sqlite-map make-user stmt))) 48 (sqlite-bind stmt 1 name) 49 (sqlite-finalize stmt) 50 result)) 51 52 (define (select-all-users) 53 (let* ((stmt (sqlite-prepare db "select name from users")) 54 (result (sqlite-map (cut vector-ref <> 0) stmt))) 55 (sqlite-finalize stmt) 56 result)) 57 58 (define (encrypt-user user) 59 (base64-encode (encrypt (string->utf8 user) SECRET_KEY))) 60 61 (define (decrypt-user user) 62 (let ((decrypted (decrypt (base64-decode user) SECRET_KEY))) 63 (if decrypted (utf8->string decrypted) #f))) 64 65 (define (insert-user name email password) 66 (catch 'sqlite-error 67 (lambda () 68 (let ((stmt (sqlite-prepare db "insert into users values(?, ?, ?)"))) 69 (sqlite-bind stmt 1 name) 70 (sqlite-bind stmt 2 email) 71 (sqlite-bind stmt 3 (if (string? password) 72 (hash-password password) 73 #f)) 74 (sqlite-step stmt) 75 (sqlite-finalize stmt) 76 (list #t (encrypt-user name)))) 77 err->msg)) 78 79 (define (login-user name password) 80 (catch 'sqlite-error 81 (lambda () 82 (let ((stmt (sqlite-prepare db "select password from users where name = ?"))) 83 (sqlite-bind stmt 1 name) 84 (let ((row (sqlite-step stmt))) 85 (sqlite-finalize stmt) 86 (if (and row (verify-password password (vector-ref row 0))) 87 (list #t (encrypt-user name)) 88 (list #f "Meno alebo heslo nie je správne"))))) 89 err->msg)) 90 91 (define (insert-answers answers user round) 92 (catch 'sqlite-error 93 (lambda () 94 (let* ((stmt-text (string-append (fold (lambda (i so-far) 95 (string-append so-far ", (?,?,?,?)")) 96 "insert into answers (name, round, problem, content) values(?,?,?,?)" 97 (iota (- (length answers) 1))) 98 " on conflict (name, round, problem) do update set content=excluded.content")) 99 (stmt (sqlite-prepare db stmt-text))) 100 (for-each (lambda (a i) (begin (sqlite-bind stmt (+ (* i 4) 1) user) 101 (sqlite-bind stmt (+ (* i 4) 2) round) 102 (sqlite-bind stmt (+ (* i 4) 3) (+ i 1)) 103 (sqlite-bind stmt (+ (* i 4) 4) a))) 104 answers 105 (iota (length answers))) 106 (sqlite-step stmt) 107 (sqlite-finalize stmt) 108 (list #t))) 109 err->msg)) 110 111 (define (insert-results results user round) 112 (catch 'sqlite-error 113 (lambda () 114 (let* ((stmt-text (string-append (fold (lambda (i so-far) 115 (string-append so-far ", (?,?,?,?)")) 116 "insert into answers (name, round, problem, correct) values(?,?,?,?)" 117 (iota (- (length results) 1))) 118 " on conflict (name, round, problem) do update set correct=excluded.correct")) 119 (stmt (sqlite-prepare db stmt-text))) 120 (for-each (lambda (a i) (begin (sqlite-bind stmt (+ (* i 4) 1) user) 121 (sqlite-bind stmt (+ (* i 4) 2) round) 122 (sqlite-bind stmt (+ (* i 4) 3) (+ i 1)) 123 (sqlite-bind stmt (+ (* i 4) 4) a))) 124 results 125 (iota (length results))) 126 (sqlite-step stmt) 127 (sqlite-finalize stmt) 128 (list #t))) 129 err->msg)) 130 131 (define (select-answers user round) 132 (catch 'sqlite-error 133 (lambda () 134 (let* ((stmt-text "select content, correct from answers where name=? and round=? order by problem") 135 (stmt (sqlite-prepare db stmt-text))) 136 (sqlite-bind stmt 1 user) 137 (sqlite-bind stmt 2 round) 138 (let ((res (sqlite-map identity stmt))) 139 (sqlite-finalize stmt) 140 (if (null? res) #f res)))) 141 (lambda (key who code msg) (begin (display msg (current-error-port)) #f)))) 142 143 (define (select-answers-content user round) 144 (catch 'sqlite-error 145 (lambda () 146 (let* ((stmt-text "select content from answers where name=? and round=? order by problem") 147 (stmt (sqlite-prepare db stmt-text))) 148 (sqlite-bind stmt 1 user) 149 (sqlite-bind stmt 2 round) 150 (let ((res (sqlite-map (cut vector-ref <> 0) stmt))) 151 (sqlite-finalize stmt) 152 (if (null? res) #f res)))) 153 (lambda (key who code msg) (begin (display msg (current-error-port)) #f)))) 154 155 (define (select-results round) 156 (catch 'sqlite-error 157 (lambda () 158 (let* ((stmt-text "select name, score from results where round=? order by score desc") 159 (stmt (sqlite-prepare db stmt-text))) 160 (sqlite-bind stmt 1 round) 161 (let ((res (sqlite-map identity stmt))) 162 (sqlite-finalize stmt) 163 (if (null? res) #f res)))) 164 (lambda (key who code msg) (begin (display msg (current-error-port)) #f)))) 165 166 (define (insert-score name round score) 167 (catch 'sqlite-error 168 (lambda () 169 (let ((stmt (sqlite-prepare db "insert into results values(?, ?, ?) on conflict(name, round) do update set score=excluded.score"))) 170 (sqlite-bind stmt 1 name) 171 (sqlite-bind stmt 2 round) 172 (sqlite-bind stmt 3 score) 173 (sqlite-step stmt) 174 (sqlite-finalize stmt))) 175 err->msg))