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
|
;;; 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 (captcha)
#:use-module (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 (srfi srfi-1)
#:use-module (srfi srfi-19)
#:export (new-captcha))
(define proc-mutex (make-mutex))
(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-uuid)
(with-mutex proc-mutex
(let* ((port (open-input-pipe "uuidgen"))
(str (read-line port)))
(close-pipe port)
str)))
(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)))))
(values (new-uuid)
(- (local-eval expression (let ((x upper-bound)) (the-environment)))
(local-eval expression (let ((x lower-bound)) (the-environment))))
(latex->image (format #f "\\int_{~a}^{~a} ~a \\, dx"
lower-bound
upper-bound
latex-src)))))
;; 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")))))
|
