eutro: 1 Prototype HTTP frontend 3 files changed, 184 insertions(+), 7 deletions(-)
Copy & paste the following snippet into your terminal to import this patchset into git:
curl -s https://lists.sr.ht/~williewillus/public-inbox/patches/28854/mbox | git am -3Learn more about email & git
--- backend.rkt | 12 ++-- frontends/http.rkt | 175 +++++++++++++++++++++++++++++++++++++++++++++ interface.rkt | 4 +- 3 files changed, 184 insertions(+), 7 deletions(-) create mode 100644 frontends/http.rkt diff --git a/backend.rkt b/backend.rkt index 17ecd92..d7bb465 100644 --- a/backend.rkt @@ -110,11 +110,11 @@ (define/public (register name code author timestamp) (cond [(zero? (string-length code)) - (~a "Trick " name " needs a body!")] + (cons 'err (~a "Trick " name " needs a body!"))] [(db:add-trick! db (current-context-id) name (thunk (trick author code timestamp (make-hash) 0))) - (~a "Successfully registered trick " name "!")] + (cons 'ok (~a "Successfully registered trick " name "!"))] [else (update name code)])) (define/public (update name code) @@ -123,9 +123,9 @@ (define frontend (current-frontend)) (cond [(not trick-obj) - (~a "Trick " name " doesn't exist!")] + (cons 'err (~a "Trick " name " doesn't exist!"))] [(zero? (string-length code)) - (~a "Trick " name " needs a body!")] + (cons 'err (~a "Trick " name " needs a body!"))] [(db:update-trick! db ctx-id name (lambda (trick-obj) @@ -136,7 +136,9 @@ (trick-invocations trick-obj))) (lambda (t) (send frontend can-modify? t))) - (~a "Successfully updated trick " name "!")])) + (cons 'ok (~a "Successfully updated trick " name "!"))] + [else + (cons 'err (~a "You cannot modify trick " name "!"))])) (define/public (lookup name) (db:get-trick db (current-context-id) name)) diff --git a/frontends/http.rkt b/frontends/http.rkt new file mode 100644 index 0000000..5374066 --- /dev/null +++ b/frontends/http.rkt @@ -0,0 +1,175 @@ +#lang racket/base + +(require + racket/class + racket/list + racket/match + racket/function + racket/string + "../common.rkt" + "../config.rkt" + (prefix-in ev: "../evaluator.rkt") + "../interface.rkt" + + base64 + file/sha1 + net/url-structs + web-server/web-server + web-server/servlet-dispatch + web-server/http/xexpr + web-server/http/request-structs + web-server/http/response-structs) + +(provide r16-make-frontend) + +(struct image (bytes)) + +(define http-frontend + (class* object% [r16-frontend<%>] + (init-field port) + + (define mutex (make-semaphore 1)) + (define current-hashed (make-parameter #f)) + (define/public (response? v) (image? v)) + (define/public (get-enrich-context) + (define (enrich-context base _trick _args _parent-ctx) + (define (make-image png-bytes) + (image png-bytes)) + `(((make-image . ,make-image) + ,@(car base)) + ,@(cdr base))) + enrich-context) + (define/public (can-modify? trick) + (equal? (trick-author trick) (current-hashed))) + (define/public (start) + (define (handle-request req) + (define req-uri (request-uri req)) + (define path (takef (url-path req-uri) (compose1 non-empty-string? path/param-path))) + (match* [(request-method req) path] + [[#"POST" (list (path/param "tricks" _) + (path/param "submit" _))] + (define bindings (request-bindings/raw req)) + (match* [(bindings-assq #"name" bindings) + (bindings-assq #"code" bindings) + (bindings-assq #"password" bindings)] + [[(binding:form _ (and name-bytes + (pregexp "^[a-zA-Z_\\-0-9]+$") + (app bytes->string/utf-8 name))) + (binding:form _ (app bytes->string/utf-8 code)) + (binding:form _ password)] + ;; yeah, it's not secure at all + (call-with-semaphore + mutex + (thunk + (define hashed (bytes->hex-string (sha256-bytes (bytes-append (sha256-bytes name-bytes) password)))) + (match (parameterize ([current-hashed hashed]) + (send (current-backend) register name code hashed (number->string (current-seconds)))) + [(cons 'ok _) + (response/full + 303 #"See Other" + (current-seconds) TEXT/HTML-MIME-TYPE + (list (make-header #"Location" (string->bytes/utf-8 (format "/tricks/~a.rkt" name)))) + (list #"Redirecting..."))] + [(cons 'err msg) + (response/full + 400 #"Bad Request" + (current-seconds) TEXT/HTML-MIME-TYPE + null + (list (string->bytes/utf-8 msg)))])))] + [[_ _ _] + (response/full + 400 #"Bad Request" + (current-seconds) TEXT/HTML-MIME-TYPE + null + (list #"400 Bad Request"))])] + [[#"GET" (list (path/param "tricks" _))] + (define popular (send (current-backend) popular)) + (response/xexpr + `(html (head (title "Tricks")) + (body (div + (h2 "Add trick") + (form + ((action "/tricks/submit") + (method "post") + (enctype "multipart/form-data")) + (label ((for "name")) "Name: ") + (input ((type "text") (id "name") (name "name"))) + (br) + (label ((for "password")) "Password: ") + (input ((type "password") (id "password") (name "password"))) + (br) + (span + ((style "color:red;")) + "None of this is very secure at all, so under no circumstances should you use a password you use elsewhere.") + (br) + (label ((for "code")) "Code: ") + (textarea + ((id "code") + (name "code") + (rows "5") + (cols "60") + (placeholder "Enter text") + (spellcheck "false"))) + (br) + (input ((type "submit") (value "Add"))))) + (div + (h1 "Registered tricks") + (ol + ,@(for/list ([t (in-list popular)]) + (define n (car t)) + `(li + ,n + " (" + (a ((href ,(format "/tricks/~a.rkt" n))) "src") + ") " + (form + ((action ,(format "/tricks/~a" n)) + (method "get") + (style "display:inline;")) + (input ((type "text") (name "args"))) + (input ((type "submit") (value "Call")))))))))))] + [[#"GET" (list (path/param "tricks" _) + (path/param (pregexp "^([a-zA-Z_\\-0-9]+)\\.rkt$" (list trick-file-name trick-name)) _))] + (define trick-v (send (current-backend) lookup trick-name)) + (response/xexpr + `(html (head (title ,trick-file-name)) + (body (pre ,(trick-body trick-v)))))] + [[#"GET" (list (path/param "tricks" _) + (path/param (pregexp "^[a-zA-Z_\\-0-9]+$" (list trick-name)) _))] + (define args (assoc 'args (url-query req-uri))) + (define res (send (current-backend) call trick-name (if args (cdr args) ""))) + (cond + [(ev:run-result? res) + (define stderr (ev:run-result-stderr res)) + (define stdout (ev:run-result-stdout res)) + (response/xexpr + `(html (head (title ,trick-name)) + (body ,@(if stderr `((pre ,stderr)) null) + ,@(if (zero? (string-length stdout)) null `((pre ,stdout))) + ,@(for/list ([r (ev:run-result-results res)]) + (cond + [(image? r) + `(img + ((src ,(format "data:image/png;base64,~a" (base64-encode (image-bytes r))))))] + [else + `(pre ,r)])))))] + [(string? res) + (response/xexpr + #:code 400 + `(html (head (title "400 Bad Request")) + (body ,res)))])] + [[#"GET" _] + (response/xexpr + #:code 404 + `(html (head (title "404 Not found")) + (body "404 Not found")))])) + (serve + #:dispatch (dispatch/servlet handle-request) + #:port port) + (do-not-return)) + (super-new))) + +(define (r16-make-frontend raw-config) + (define port (check-config exact-positive-integer? (hash-ref raw-config 'port 8080))) + (new http-frontend + [port port])) diff --git a/interface.rkt b/interface.rkt index d820a62..67a9e36 100644 --- a/interface.rkt +++ b/interface.rkt @@ -49,10 +49,10 @@ ;; register a trick, returning an error or success message [register (#;trick string? #;code string? #;author string? #;timestamp string? - . ->m . string?)] + . ->m . (cons/c (or/c 'err 'ok) string?))] ;; update a trick, returning an error or success message - [update (#;trick string? #;code string? . ->m . string?)] + [update (#;trick string? #;code string? . ->m . (cons/c (or/c 'err 'ok) string?))] ;; look up a trick by name [lookup (#;trick string? . ->m . (or/c trick? #f))] -- 2.34.1
builds.sr.ht <builds@sr.ht>r16/patches/linux_buildtest.yml: FAILED in 2m3s [Prototype HTTP frontend][0] from [eutro][1] [0]: https://lists.sr.ht/~williewillus/public-inbox/patches/28854 [1]: mailto:benedek.szilvasy@gmail.com ✗ #683864 FAILED r16/patches/linux_buildtest.yml https://builds.sr.ht/~williewillus/job/683864