eutro: 2 Prototype HTTP frontend Generalize backend, improve HTTP frontend UI 8 files changed, 471 insertions(+), 128 deletions(-)
r16/patches/linux_buildtest.yml: SUCCESS in 1m49s [Prototype HTTP frontend][0] v2 from [eutro][1] [0]: https://lists.sr.ht/~williewillus/public-inbox/patches/28865 [1]: mailto:benedek.szilvasy@gmail.com ✓ #684120 SUCCESS r16/patches/linux_buildtest.yml https://builds.sr.ht/~williewillus/job/684120
Copy & paste the following snippet into your terminal to import this patchset into git:
curl -s https://lists.sr.ht/~williewillus/public-inbox/patches/28865/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
--- backend.rkt | 12 +- frontends/discord.rkt | 23 ++- frontends/http.rkt | 336 ++++++++++++++++++++++++++++++------------ interface.rkt | 14 +- result.rkt | 23 +++ 5 files changed, 287 insertions(+), 121 deletions(-) create mode 100644 result.rkt diff --git a/backend.rkt b/backend.rkt index d7bb465..0e67637 100644 --- a/backend.rkt @@ -70,7 +70,7 @@ enrich-context (current-context-id) #f "" "" #f)) - (ev:run code ev-ctx response?)) + (cons 'ok (ev:run code ev-ctx response?))) (define/public (call name args) (define ctx-id (current-context-id)) @@ -89,9 +89,9 @@ (current-context-id) trick-obj name args #f)) (define code (trick-body trick-obj)) - (ev:run code ev-ctx response?)] + (cons 'ok (ev:run code ev-ctx response?))] [else - (~a "Trick " name " doesn't exist!")])) + (cons 'err (~a "Trick " name " doesn't exist!"))])) (define/public (delete name) (define ctx-id (current-context-id)) @@ -99,13 +99,13 @@ (define frontend (current-frontend)) (cond [(not trick-obj) - (~a "Trick " name " doesn't exist!")] + (cons 'err (~a "Trick " name " doesn't exist!"))] [(db:remove-trick! db ctx-id name (lambda (t) (send frontend can-modify? t))) - (~a "Successfully removed trick " name "!")] + (cons 'ok (~a "Successfully removed trick " name "!"))] [else - (~a "You cannot modify trick " name "!")])) + (cons 'err (~a "You cannot modify trick " name "!"))])) (define/public (register name code author timestamp) (cond diff --git a/frontends/discord.rkt b/frontends/discord.rkt index ad27cdd..960942f 100644 --- a/frontends/discord.rkt +++ b/frontends/discord.rkt @@ -394,9 +394,7 @@ (thunk (define result (send (current-backend) evaluate (strip-backticks text))) - (if (ev:run-result? result) - (format-run-result result) - (list result))))) + (result-case format-run-result list result)))) (define/command/trick (call-trick name body) " [_name_] ...: invoke the trick [_name_], evaluating its source code in a fresh sandbox" @@ -404,17 +402,16 @@ (thunk (define result (send (current-backend) call name body)) - (if (ev:run-result? result) - (format-run-result result) - (list result))))) + (result-case format-run-result list result)))) (define/command/trick (register-trick name body) " [_name_] [_code_]: register [_code_] as a trick with name [_name_]" - (list - (send (current-backend) register - name (strip-backticks body) - (message-author-id (current-message)) - (hash-ref (current-message) 'timestamp)))) + (define result + (send (current-backend) register + name (strip-backticks body) + (message-author-id (current-message)) + (hash-ref (current-message) 'timestamp))) + (list (cdr result))) (define/command/trick (show-trick name _body) " [_name_]: show metadata and source for the trick [_name_]" @@ -435,11 +432,11 @@ (define/command/trick (update-trick name body) " [_name_] [_code_]: change the source of the trick [_name_]; requires ownership or administrator" - (list (send (current-backend) update name (strip-backticks body)))) + (list (cdr (send (current-backend) update name (strip-backticks body))))) (define/command/trick (delete-trick name _body) " [_name_]: delete the trick [_name_]; requires ownership or administrator and cannot be undone!" - (list (send (current-backend) delete name))) + (list (cdr (send (current-backend) delete name)))) (define/command (popular text) ": show a leaderboard of popular tricks" diff --git a/frontends/http.rkt b/frontends/http.rkt index 5374066..74b6f11 100644 --- a/frontends/http.rkt +++ b/frontends/http.rkt @@ -8,10 +8,11 @@ racket/string "../common.rkt" "../config.rkt" + "../log.rkt" (prefix-in ev: "../evaluator.rkt") "../interface.rkt" - base64 + net/base64 file/sha1 net/url-structs web-server/web-server @@ -24,6 +25,78 @@ (struct image (bytes)) +(define (simple-response code msg body) + (response/full + code msg + (current-seconds) TEXT/HTML-MIME-TYPE + null + (list body))) + +(define (format-for-html str) + (define url-regex #px"(([^:/?#]+):)(//([^/?#]*))([^?#]*)(\\?([^#]*))?(#(.*))?") + `(div + ((class "content")) + ,@(for/list ([line (in-list (string-split str "\n"))]) + (define urls (regexp-match-positions* url-regex line #:match-select car)) + `(div + ((class "block")) + ,@(cond + [(null? urls) (list line)] + [else + (define positions + (append* + (for/list ([url-pos (in-list urls)]) + (list (car url-pos) (cdr url-pos))))) + (for/list ([start (in-list `(0 ,@positions))] + [end (in-list `(,@positions ,(string-length line)))] + [is-link? (in-cycle (in-list '(#f #t)))]) + (define v (substring line start end)) + (if is-link? + `(a ((href ,v)) ,v) + v))]))))) + +(define HTML-DOCTYPE #"<!DOCTYPE html>") + +(define (response/html + #:title title + #:navbar? [navbar? #f] + . body) + (response/xexpr + #:preamble HTML-DOCTYPE + `(html (head + (meta ((charset "utf-8"))) + (meta ((name "viewport") (content "width=device-width, initial-scale=1"))) + (title ,title) + (link ((rel "stylesheet") (href "https://cdn.jsdelivr.net/npm/bulma@0.9.3/css/bulma.min.css"))) + (link ((rel "stylesheet") (href "https://fonts.googleapis.com/icon?family=Material+Icons"))) + (style + ".code-input { font-family: mono; }" + ".toggled .togglable { display: none; }" + ".togglable-inverse { display: none; }" + ".toggled .togglable-inverse { display: inline; }")) + (body + ,@(if navbar? + `((navbar + ((class "navbar is-dark") + (role "navigation") + (aria-label "main navigation")) + (div + ((class "navbar-menu")) + (div + ((class "navbar-start")) + (a ((class "navbar-item") (href "/")) "Home") + (a ((class "navbar-item") (href "/tricks")) "Tricks")) + (div + ((class "navbar-end")) + (a ((class "navbar-item") (href "https://sr.ht/~williewillus/r16")) "Source"))))) + null) + (div ((class "container")) ,@body) + (footer + ((class "footer")) + (div + ((class "container has-text-centered")) + ,(format-for-html (send (current-backend) about)))))))) + (define http-frontend (class* object% [r16-frontend<%>] (init-field port) @@ -42,7 +115,13 @@ (define/public (can-modify? trick) (equal? (trick-author trick) (current-hashed))) (define/public (start) - (define (handle-request req) + (log-r16-debug "Starting server on port ~a" port) + (serve + #:dispatch (dispatch/servlet handle-request) + #:port port) + (do-not-return)) + + (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] @@ -62,111 +141,176 @@ 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)))])))] + (parameterize ([current-hashed hashed]) + (cond + [(zero? (string-length code)) + (match (send (current-backend) delete name) + [(cons 'ok msg) (simple-response 200 #"OK" (string->bytes/utf-8 msg))] + [(cons 'err msg) (simple-response 400 #"Bad Request" (string->bytes/utf-8 msg))])] + [else + (match (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) + (simple-response 400 #"Bad Request" (string->bytes/utf-8 msg))])]))))] [[_ _ _] - (response/full - 400 #"Bad Request" - (current-seconds) TEXT/HTML-MIME-TYPE - null - (list #"400 Bad Request"))])] + (simple-response 400 #"Bad Request" #"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")))))))))))] + (response/html + #:title "Tricks" + #:navbar? #t + `(div + ((class "section")) + (h1 ((class "title")) "Add trick") + (form + ((action "/tricks/submit") + (method "post") + (target "_blank") + (enctype "multipart/form-data")) + + (div + ((class "field is-grouped")) + (div + ((class "control")) + (label ((class "label") (for "name")) "Trick Name") + (div + ((class "control")) + (input ((class "input") (type "text") (id "name") (name "name"))))) + (div + ((class "control")) + (label ((class "label") (for "password")) "Password") + (div + ((class "control")) + (input ((class "input") (type "password") (id "password") (name "password")))))) + (div + ((class "field")) + (label ((class "label") (for "code")) "Code") + (div + ((class "control")) + (textarea + ((class "textarea code-input") + (id "code") + (name "code") + (rows "5") + (cols "60") + (placeholder "Enter code") + (spellcheck "false"))))) + (div + ((class "field")) + (input ((class "button is-success") (type "submit") (value "Add")))))) + `(div + ((class "section")) + (h1 ((class "title")) "Registered tricks") + ,@(for/list ([trick-pair (in-list popular)]) + (define name (car trick-pair)) + (define trick-v (cdr trick-pair)) + `(div + ((class "block")) + (div + ((class "card toggled")) + (header + ((class "card-header has-background-dark has-text-white") + (onclick "toggle(this.parentElement)") + (title ,(format "Invocations: ~a" (trick-invocations trick-v)))) + (p ((class "card-header-title has-text-white")) ,name) + (button + ((class "card-header-icon") + (aria-label "more options")) + (span + ((class "material-icons togglable-inverse") (aria-hidden "true")) + "arrow_drop_down") + (span + ((class "material-icons togglable") (aria-hidden "true")) + "arrow_drop_up"))) + (div + ((class "card-content togglable")) + (form + ((action ,(format "/tricks/~a" name)) + (target "_blank") + (method "get")) + (div + ((class "field")) + (textarea ((class "textarea code-input") + (name "args") + (spellcheck "false") + (rows "1") + (placeholder "Enter arguments")))) + (input ((class "button is-primary") (type "submit") (value "Call"))))) + (footer + ((class "card-footer togglable")) + (a ((class "card-footer-item") (href ,(format "/tricks/~a.rkt" name)) (target "_blank")) "Source")))))) + `(script #<<EOF +function toggle(el) { + let toggled = el.classList.contains("toggled"); + if (toggled) { + el.classList.remove("toggled"); + } else { + el.classList.add("toggled"); + } +} +EOF + ))] + [[#"GET" (list (path/param "tricks" _) - (path/param (pregexp "^([a-zA-Z_\\-0-9]+)\\.rkt$" (list trick-file-name trick-name)) _))] + (path/param (pregexp "^([a-zA-Z_\\-0-9]+)\\.rkt$" (list _ 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)))))] + (response/full + 200 #"OK" + (current-seconds) #"text/plain; charset=utf-8" + null + (list (string->bytes/utf-8 (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) + (match (send (current-backend) call trick-name (if args (cdr args) "")) + [(cons 'ok 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)))])] + (define results (ev:run-result-results res)) + (match* [stderr stdout results] + [[#f "" (list (image raw-bytes))] + (response/full + 200 #"OK" + (current-seconds) #"image/png" + null + (list raw-bytes))] + [[_ _ _] + (response/xexpr + #:preamble HTML-DOCTYPE + `(html + (head (title ,trick-name)) + (body + ,@(if stderr `((pre ,stderr)) null) + ,@(if (zero? (string-length stdout)) null `((pre ,stdout))) + ,@(for/list ([r results]) + (cond + [(image? r) + `(img + ((src ,(format "data:image/png;base64,~a" (base64-encode (image-bytes r))))))] + [else + `(pre ,r)])))))])] + [(cons 'err msg) + (simple-response 400 #"Bad Request" (string->bytes/utf-8 msg))])] + + [[#"GET" (list)] + (response/html + #:title "r16" + #:navbar? #t + `(div + ((class "section")) + (h1 ((class "title")) "Stats") + ,(format-for-html (send (current-backend) stats))))] + [[#"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)) + (simple-response 404 #"Not Found" #"404 Not Found")])) + (super-new))) (define (r16-make-frontend raw-config) diff --git a/interface.rkt b/interface.rkt index 67a9e36..772bcea 100644 --- a/interface.rkt +++ b/interface.rkt @@ -3,13 +3,15 @@ (require racket/class racket/contract + "result.rkt" (only-in "evaluator.rkt" definitions? run-result?) "common.rkt") (provide r16-backend? r16-frontend? r16-backend<%> r16-frontend<%> current-backend current-frontend - current-context-id) + current-context-id + (all-from-out "result.rkt")) ;; an r16 frontend (define r16-frontend<%> @@ -38,21 +40,21 @@ (define r16-backend<%> (interface () ;; evaluate a code snippet, returning either an error message or a run result - [evaluate (#;code string? . ->m . (or/c string? run-result?))] + [evaluate (#;code string? . ->m . (result/c run-result? string?))] ;; call a trick with arguments, returning either an error message or a run result - [call (#;trick string? #;args string? . ->m . (or/c string? run-result?))] + [call (#;trick string? #;args string? . ->m . (result/c run-result? string?))] ;; delete a trick, returning an error or success message - [delete (#;trick string? . ->m . string?)] + [delete (#;trick string? . ->m . (result/c string? string?))] ;; register a trick, returning an error or success message [register (#;trick string? #;code string? #;author string? #;timestamp string? - . ->m . (cons/c (or/c 'err 'ok) string?))] + . ->m . (result/c string? string?))] ;; update a trick, returning an error or success message - [update (#;trick string? #;code string? . ->m . (cons/c (or/c 'err 'ok) string?))] + [update (#;trick string? #;code string? . ->m . (result/c string? string?))] ;; look up a trick by name [lookup (#;trick string? . ->m . (or/c trick? #f))] diff --git a/result.rkt b/result.rkt new file mode 100644 index 0000000..2f4f8d0 --- /dev/null +++ b/result.rkt @@ -0,0 +1,23 @@ +#lang racket/base + +(require racket/contract (for-syntax racket/base syntax/parse)) + +(provide result/c ok? err? result-case) + +;; represents a fallible computation +;; (cons 'ok ok-value) on success +;; (cons 'err err-value) on failure +(define-syntax (result/c stx) + (syntax-parse stx + [(_ ok-ctc:expr err-ctc:expr) + (with-syntax ([name stx]) + (syntax/loc stx + (rename-contract + (or/c (cons/c 'ok ok-ctc) + (cons/c 'err err-ctc)) + 'name)))])) + +(define (ok? x) (eq? 'ok (car x))) +(define (err? x) (eq? 'err (car x))) +(define (result-case if-ok if-err x) + ((if (ok? x) if-ok if-err) (cdr x))) -- 2.34.1
builds.sr.ht <builds@sr.ht>r16/patches/linux_buildtest.yml: SUCCESS in 1m49s [Prototype HTTP frontend][0] v2 from [eutro][1] [0]: https://lists.sr.ht/~williewillus/public-inbox/patches/28865 [1]: mailto:benedek.szilvasy@gmail.com ✓ #684120 SUCCESS r16/patches/linux_buildtest.yml https://builds.sr.ht/~williewillus/job/684120