diff options
Diffstat (limited to 'dynamic/api.scm')
| -rw-r--r-- | dynamic/api.scm | 157 |
1 files changed, 11 insertions, 146 deletions
diff --git a/dynamic/api.scm b/dynamic/api.scm index 4a41040..b53be8a 100644 --- a/dynamic/api.scm +++ b/dynamic/api.scm @@ -14,163 +14,26 @@ ;;; along with this program. If not, see ;;; <http://www.gnu.org/licenses/>. -(add-to-load-path (dirname (current-filename))) -;; (add-to-load-path "/home/jakob/Blog/dynamic") - -(use-modules (base64) - (captcha) - (ice-9 binary-ports) - (json) +(use-modules (dynamic capabilities rsvp) + (dynamic logging) (srfi srfi-1) - (srfi srfi-11) - (srfi srfi-13) - (srfi srfi-26) - (squee) - (rnrs bytevectors) (ice-9 match) (web server) (web request) (web response) (web uri)) -;; Globals. - -(define challenges (make-hash-table)) -;; (define conn (connect-to-postgres-paramstring "dbname=jakob_comments")) -(define conn (connect-to-postgres-paramstring "dbname=jakob_rsvp")) - -;; Util. - -(define (acons-list k v alist) - "Add V to K to alist as list" - (let ((value (assoc-ref alist k))) - (if value - (let ((alist (alist-delete k alist))) - (acons k (cons v value) alist)) - (acons k (list v) alist)))) - -(define (list->alist lst) - "Build a alist of list based on a list of key and values. - - Multiple values can be associated with the same key" - (let next ((lst lst) - (out '())) - (if (null? lst) - out - (next (cdr lst) (acons-list (caar lst) (cdar lst) out))))) - -(define (decode-form bv) - "Convert BV querystring or form data to an alist" - (define string (if (string? bv) bv (utf8->string bv))) - (define pairs (map (cut string-split <> #\=) - ;; semi-colon and amp can be used as pair separator - (append-map (cut string-split <> #\;) - (string-split string #\&)))) - (list->alist (map (match-lambda - ((key value) - (cons (uri-decode key) (uri-decode value)))) pairs))) - -(define (request-path-components request) - (split-and-decode-uri-path (uri-path (request-uri request)))) - (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 (get-comments request body) - (values '((content-type . (application/json))) - (scm->json-string - '((title . "whoa buddy") - (author . "Jakob Kreuze") - (date . "2022-03-27") - (text . "bad take, bad take!"))))) - -(define (put-comment request body) - (display (decode-form body)) - (newline) - (values '((content-type . (text/plain))) "Hello hacker!")) - -(define (make-challenge request body) - (let-values (((uuid value image) (new-captcha))) - (hash-set! challenges uuid value) - (hash-for-each (lambda (x y) (display x) (newline)) challenges) - (values `((content-type . (application/base64)) - (access-control-allow-origin . "*") - (x-captcha-id . ,uuid)) - (base64-encode image)))) - -;; (define (valid-invite-code invitation) -;; (and (= (string-length)))) - -(define (generate-vanity-code) - (call-with-input-file "/dev/urandom" - (lambda (port) - (base64-encode (get-bytevector-n port 9))))) - -(define (post-event-rsvp request body) - (let* ((params (json-string->scm (utf8->string body))) - (invitation-code (assoc-ref params "id")) - (name (assoc-ref params "name")) - (email (assoc-ref params "email")) - (attending (assoc-ref params "rsvp")) - (guests (assoc-ref params "guests"))) - (cond ((not (and invitation-code name email attending guests)) - (values (build-response #:code 400 #:headers '((Access-Control-Allow-Origin . "*"))) - (scm->json-string - `((success . #f) - (error . "Invalid form data"))))) - ((> 1 (length (exec-query conn "SELECT event_id FROM invitations WHERE vanity = $1" (list invitation-code)))) - (values (build-response #:code 400 #:headers '((Access-Control-Allow-Origin . "*"))) - (scm->json-string - `((success . #f) - (error . "Invalid invitation code"))))) - (else - (let* ((receipt-code (generate-vanity-code)) - (event-id (caar (exec-query conn "SELECT event_id FROM invitations WHERE vanity = $1" (list invitation-code))))) - (exec-query conn "INSERT INTO rsvps (vanity, event_id, fullname, email, attending, guests) VALUES ($1, $2, $3, $4, $5, $6)" (list receipt-code event-id name email attending guests)) - (values '((content-type . (application/json)) - (Access-Control-Allow-Origin . "*")) - (scm->json-string - `((receipt . ,receipt-code))))))))) - -(define (get-event-info request body) - (define (format-rsvp rsvp) - (match rsvp - ((name email guests) - `((name . ,name) - (email . ,email) - (guests . ,guests))))) - (let* ((params (decode-form (uri-query (request-uri request)))) - (invitation-code (car (assoc-ref params "i"))) - (invitation (exec-query conn "SELECT event_id, capabilities FROM invitations WHERE vanity = $1" (list invitation-code)))) - (if (> 1 (length invitation)) - (values (build-response #:code 400 #:headers '((Access-Control-Allow-Origin . "*"))) - (scm->json-string - `((success . #f) - (error . "Invalid invitation code")))) - (let* ((capabilities (cadar invitation)) - (event (exec-query conn "SELECT * FROM events WHERE id = $1" (list (caar invitation)))) - (rsvps (exec-query conn "SELECT fullname, email, guests FROM rsvps WHERE event_id = $1" (list (caar invitation))))) - (match (car event) - ((i_ title description date location) - (values '((content-type . (application/json)) - (Access-Control-Allow-Origin . "*")) - (scm->json-string - `((title . ,title) - (description . ,description) - (image . #f) - (date . ,date) - (location . ,location) - ,@(if (= 1 (logand (string->number capabilities) 1)) - `((rsvps . ,(list->vector (map format-rsvp rsvps)))) - '())))))))))) - (define (handle-api-request request body endpoint) - (display (cons (request-method request) endpoint)) - (newline) + "Route handler for the API server." + (let ((method (request-method request)) + (originating-ip (assoc-ref (request-headers request) 'X-Forwarded-For))) + (log-append! 'info (format #f "~a ~a (~a)" method endpoint originating-ip))) ((match (cons (request-method request) endpoint) ;; ('(GET "challenge") make-challenge) ;; ('(GET "comments") get-comments) @@ -181,9 +44,11 @@ request body)) (define (main-request-handler request body) - (let ((path (request-path-components request))) + "Server entry-point; parse `request' and defer to routing system." + (let* ((path-encoded (uri-path (request-uri request))) + (path (split-and-decode-uri-path path-encoded))) (if (string= "api" (first path)) (handle-api-request request body (drop path 1)) (not-found request)))) -(run-server main-request-handler 'http '(#:port 8081)) +(run-server main-request-handler) |