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
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
|
;;; Copyright © 2019 - 2022 Jakob L. Kreuze <zerodaysfordays@sdf.org>
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation; either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see
;;; <http://www.gnu.org/licenses/>.
(define-module (jakob dynamic captcha)
#:use-module (gcrypt base64)
#:use-module (gcrypt hash)
#:use-module (gcrypt mac)
#:use-module (gcrypt random)
#:use-module (ice-9 binary-ports)
#:use-module (ice-9 iconv)
#:use-module (ice-9 local-eval)
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 threads)
#:use-module (rnrs bytevectors)
#:use-module (rnrs base)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-19)
#:use-module (system foreign)
#:export (make-queue
id-queue-allocated
release-id!
dequeue-id!
new-captcha
validate-captcha))
(define-record-type <id-queue>
(make-id-queue mutex free-ids allocated-ids)
id-queue?
(mutex id-queue-mutex)
(free-ids id-queue-free set-id-queue-free!)
(allocated-ids id-queue-allocated set-id-queue-allocated!))
(define (make-queue n)
(make-id-queue (make-mutex) (iota n) (list)))
(define max-challenges 1024)
(define min-free-id-threshold 32)
(define time-to-live-seconds (* 20 60))
(define challenge-queue-mutex (make-mutex))
(define (release-id! id queue)
(with-mutex (id-queue-mutex queue)
(display (id-queue-allocated queue))
(newline)
(display (find (lambda (x) (equal? id (car x))) (id-queue-allocated queue)))
(newline)
(assert (find (lambda (x) (equal? id (car x))) (id-queue-allocated queue)))
(assert (not (member id (id-queue-free queue))))
(set-id-queue-free!
queue
(append! (id-queue-free queue) (list id)))
(set-id-queue-allocated!
queue
(filter! (lambda (x) (not (equal? id (car x))))
(id-queue-allocated queue)))))
(define (dequeue-id! queue)
(with-mutex (id-queue-mutex queue)
(when (< (length (id-queue-free queue)) min-free-id-threshold)
(for-each
(match-lambda
((cons id created-time)
(when (>= (- (time-second (current-time))
(time-second created-time))
time-to-live-seconds)
(assert (not (member id (id-queue-free queue))))
(set-id-queue-free!
queue
(append! (id-queue-free queue) (list id)))
(set-id-queue-allocated!
queue
(filter! (lambda (x) (not (equal? id (car x))))
(id-queue-allocated queue))))))
(list-copy (id-queue-allocated queue))))
(let* ((n (random (length (id-queue-free queue))))
(id (list-ref (id-queue-free queue) n)))
(set-id-queue-free!
queue
(delete! id (id-queue-free queue)))
(set-id-queue-allocated!
queue
(append! (id-queue-allocated queue)
(list (cons id (current-time)))))
id)))
(define proc-mutex (make-mutex))
(define tex-challenge-id-queue (iota max-challenges))
(define tex-challenge-allocated-id-queue (list))
(define tex-challenges (make-hash-table max-challenges))
(define (random-term)
(match (random 5)
(0 `(* ,(+ 1 (random 10)) x))
(1 `(* ,(+ 1 (random 10)) (expt x ,(random 10))))
(2 `(* ,(+ 1 (random 10)) (exp x)))
(3 `(* ,(+ 1 (random 10)) (cos x)))
(4 `(* ,(+ 1 (random 10)) (sin x)))))
(define (sexp->latex sexp)
(match sexp
(('+ rest ...) (string-join (map sexp->latex rest) " + "))
(('* rest ...) (string-join (map sexp->latex rest) " \\cdot "))
(('sin term) (format #f "\\sin(~a)" (sexp->latex term)))
(('cos term) (format #f "\\cos(~a)" (sexp->latex term)))
(('expt term n) (format #f "~a^{~a}" (sexp->latex term) (sexp->latex n)))
(('exp term) (format #f "e^{~a}" (sexp->latex term)))
('x "x")
(n (cond ((and (number? n) (positive? n)) (format #f "~a" n))
((and (number? n) (negative? n)) (format #f "(~a)" n))
((number? n) "0")
(else (error "Do not know how to convert to latex." n))))))
(define (differentiate-sexp sexp)
(match sexp
(('+ rest ...) `(+ ,@(map differentiate-sexp rest)))
(('* coeff term) (if (number? coeff)
`(* ,coeff ,(differentiate-sexp term))
(error "Do not know how to differentiate.")))
(('sin term) `(* ,(differentiate-sexp term) (cos ,term)))
(('cos term) `(* -1 ,(differentiate-sexp term) (sin ,term)))
(('exp term) `(* ,(differentiate-sexp term) (exp ,term)))
(('expt term n) `(* ,n (expt ,term ,(- n 1))))
('x 1)
(n (if (number? n)
0
(error "Do not know how to differentiate.")))))
(define (simplify-sexp sexp)
(match sexp
(('+ rest ...) `(+ ,@(map simplify-sexp rest)))
(('* 1 term) (simplify-sexp term))
(('* 1 rest ...) (simplify-sexp `(* ,@rest)))
(('sin term) `(sin ,(simplify-sexp term)))
(('sin term) `(cos ,(simplify-sexp term)))
(('exp term) `(exp ,(simplify-sexp term)))
(('expt term 1) (simplify-sexp term))
(('expt term n) `(expt ,(simplify-sexp term) ,(simplify-sexp n)))
(term term)))
(define (random-expression)
(let ((n-terms (+ 2 (random 3))))
`(+ ,@(map (lambda (x) (random-term)) (iota n-terms)))))
(define (latex->image src)
(chdir "/tmp")
(with-mutex proc-mutex
(call-with-output-file "formula.tex"
(lambda (port)
(format port "\\def\\formula{~a}
\\documentclass[border=2pt]{standalone}
\\usepackage{amsmath}
\\usepackage{varwidth}
\\begin{document}
\\begin{varwidth}{\\linewidth}
\\[ \\formula \\]
\\end{varwidth}
\\end{document}
" src)))
(unless (eqv? 0 (status:exit-val (system "pdflatex formula.tex")))
(error "Cannot generate PDF"))
(let* ((port (open-input-pipe "convert -density 300 formula.pdf -quality 90 png:-"))
(data (get-bytevector-all port)))
(unless (eqv? 0 (status:exit-val (close-pipe port)))
(error "Cannot generate PNG"))
data)))
(define (new-captcha!)
(let* ((lower-bound (random 10))
(upper-bound (+ lower-bound 1 (random 9)))
(expression (random-expression))
(latex-src (sexp->latex (simplify-sexp (differentiate-sexp expression))))
(solution (- (local-eval expression (let ((x upper-bound)) (the-environment)))
(local-eval expression (let ((x lower-bound)) (the-environment)))))
(id (dequeue-id! tex-challenge-id-queue tex-challenge-allocated-id-queue)))
(hash-set! tex-challenges id solution)
(values id
(latex->image (format #f "\\int_{~a}^{~a} ~a \\, dx"
lower-bound
upper-bound
latex-src)))))
(define (validate-captcha! answer id)
(define epsilon 0.1)
(let ((solution (hash-ref tex-challenges id)))
(when solution
(release-id! id tex-challenge-id-queue tex-challenge-allocated-id-queue))
(and solution
(<= (abs (- solution (string->number answer)))
epsilon))))
;; How many zeroes the SHA-256 hash has to be prefixed by to be a valid proof of work.
(define %hardness 4)
;; This is an ephemeral key. At this point, it doesn't make sense to store keys
;; locally, since the server process is singular and long-running.
(define %pow-mac-key (gen-random-bv 64))
(define (proof-of-work)
(define challenge
(call-with-input-file "/dev/urandom"
(lambda (port) (base64-encode (get-bytevector-n port 32)))))
(define expiry-timestamp
(date->string
(time-utc->date (make-time 'time-utc 0 (+ 512 (time-second (current-time)))))
"~Y-~m-~d ~H:~M:~S"))
(define challenge-signature
(sign-data-base64 %pow-mac-key challenge))
(define timestamp-signature
(sign-data-base64 %pow-mac-key expiry-timestamp))
(values challenge challenge-signature expiry-timestamp timestamp-signature))
(define (check-proof-of-work prefix
challenge challenge-signature
expiry-timestamp timestamp-signature)
(define hash-value
(chain (list prefix challenge)
(string-concatenate _)
(string->bytevector _ "utf8")
(bytevector-hash _ (lookup-hash-algorithm 'sha256))
(bytevector->base16-string _)))
(define zero-prefix (string-join (map (lambda (_) "0") (iota %hardness)) ""))
(and (= 32 (string-length prefix))
(string-prefix? zero-prefix hash-value)
(valid-base64-signature? %pow-mac-key challenge challenge-signature)
(valid-base64-signature? %pow-mac-key expiry-timestamp timestamp-signature)
(time<=? (current-time)
(date->time-utc (string->date expiry-timestamp "~Y-~m-~d ~H:~M:~S")))))
|
