blob: 1bb69cf2e6d576bed85634e5bb239ab35acce6b9 (
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
140
141
142
|
;;; Copyright © 2019 - 2023 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/>.
(use-modules (ice-9 match)
(jakob dynamic blacklist)
(jakob dynamic captcha)
(jakob dynamic config)
(jakob dynamic capabilities comment-form)
(jakob dynamic capabilities comments)
(jakob dynamic capabilities gallery)
(jakob dynamic capabilities rsvp)
(jakob dynamic errors)
(jakob dynamic logging)
(jakob dynamic rate-limiter)
(jakob dynamic util)
(json)
(rnrs conditions)
(rnrs exceptions)
(srfi srfi-1)
(srfi srfi-19)
(web request)
(web response)
(web server)
(web uri))
(define (not-found request)
"Build a (somewhat) descriptive response for a non-existent resource."
(values (build-response #:code 404)
(string-append "Resource not found: "
(uri->string (request-uri request)))))
(define (format-error-response condition)
"Format CONDITION, a &reportable-condition, as an HTTP response"
(values (build-response #:code (reportable-condition-code condition))
(scm->json-string
`((success . #f)
(error . ,(reportable-condition-message condition))))))
(define-syntax values->list
(syntax-rules ()
((values-list exp)
(call-with-values (lambda () exp) list))))
(define (clearnet-only handler)
(lambda (request body)
(if (and (not (%debug-enabled)) (from-darknet? request))
(panic "This API is only available on the clearnet." #:code 403)
(handler request body))))
(define (dump-error request body endpoint)
(define file-name (date->string (current-date) "/tmp/jakob-api-crash-report-~4.txt"))
(log-append! 'error (format #f "Unhandled error! Crash report written to ~a" file-name))
(call-with-output-file file-name
(lambda (port)
(format port "Error caused by endpoint `~a'~%~%" endpoint)
(format port "Full dump of `request':")
(write request port)
(format port "~%~%")
(format port "Full dump of `body':")
(write body port)
(format port "~%~%")
(display-backtrace (make-stack #t) port))))
(define (handle-api-request request body endpoint)
"Route handler for the API server."
(let ((method (request-method request))
(originating-ip (if (%debug-enabled)
"127.0.0.1"
(assoc-ref (request-headers request) 'x-forwarded-for)))
(args (uri-query (request-uri request))))
(log-append! 'info (if args
(format #f "~a ~a (~a) (~a)" method endpoint args originating-ip)
(format #f "~a ~a (~a)" method endpoint originating-ip)))
;; Somewhat painful wrap/unwrap of values because there isn't support for
;; returning multiple values from a `guard' clause.
(apply values
(guard (ex ((reportable-condition? ex)
(values->list (format-error-response ex)))
((and (equal? "application/json" (assoc-ref (request-headers request) 'accept))
(not (%debug-enabled)))
(dump-error request body endpoint)
(list (build-response #:code 500)
(scm->json-string
'((success . #f) (error . "Internal error.")))))
((not (%debug-enabled))
(dump-error request body endpoint)
(list (build-response #:code 500) "Internal server error.")))
(fail-when-ip-blacklisted originating-ip)
(values->list
(((if (%debug-enabled) identity rate-limit-wrap)
(match (cons (request-method request) endpoint)
(('GET "apps" "comment-form" _) get-comment-form)
('(GET "api" "challenge" "proof-of-work") make-pow-challenge!)
('(GET "api" "challenge" "captcha") make-captcha-challenge!)
('(GET "api" "all-comments") get-all-comments)
('(GET "api" "comments") get-comments)
(('POST "api" "comment") put-comment)
(('POST "api" "comment" "react") put-reaction)
(('GET "apps" "gallery") (clearnet-only get-gallery))
(('GET "apps" "rsvp" "event-info") (clearnet-only get-event-info))
(('POST "apps" "rsvp") (clearnet-only post-event-rsvp))
(_ (lambda (. args) (not-found request)))))
request body))))))
(define (main-request-handler request body)
"Server entry-point; parse `request' and defer to routing system."
(define (wrap-response response)
;; This is either a response, or an alist of headers. The latter case is
;; simple to handle, but the former requires us to do a (rather unweildy)
;; copy of the response to inject our headers.
(if (response? response)
(build-response
#:version (response-version response)
#:code (response-code response)
#:reason-phrase (response-reason-phrase response)
#:headers (cons '(Access-Control-Allow-Origin . "*")
(response-headers response))
#:port (response-port response)
#:validate-headers? #t)
(cons '(Access-Control-Allow-Origin . "*") response)))
(let* ((path-encoded (uri-path (request-uri request)))
(path (split-and-decode-uri-path path-encoded)))
(define-values (response resp-body)
(handle-api-request request body path))
(values (wrap-response response) resp-body)))
(format #t "Server started.~%")
(run-server main-request-handler 'http `(#:addr ,INADDR_ANY #:port ,(%api-server-port)))
|
