From 788e47db675bfc37733618a2468c45ec3094d5c9 Mon Sep 17 00:00:00 2001 From: shironeko Date: Sun, 22 Nov 2020 14:51:45 +0800 Subject: [PATCH] add mock web interface --- lotte-web.scm | 161 ++++++++++++++++++++++++++++++++++++++++++++++++ lotte/utils.scm | 54 +++++++++++++--- 2 files changed, 205 insertions(+), 10 deletions(-) create mode 100755 lotte-web.scm diff --git a/lotte-web.scm b/lotte-web.scm new file mode 100755 index 0000000..8f94637 --- /dev/null +++ b/lotte-web.scm @@ -0,0 +1,161 @@ +#! /usr/bin/env -S guile -L . -s +!# + +; lotte: The Fair Lottery Program +; Copyright 2020 shironeko +; +; This file is part of lotte. +; +; lotte is free software: you can redistribute it and/or modify +; it under the terms of the GNU Affero General Public License as published by +; the Free Software Foundation, either version 3 of the License, or +; (at your option) any later version. +; +; lotte 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 Affero General Public License for more details. +; +; You should have received a copy of the GNU Affero General Public License +; along with this program. If not, see . + +(use-modules (ice-9 rdelim) + (web server) + (web request) + (web uri) + (lotte main) + (lotte utils)) + + +(define lucky-num-max "10000") +(define winner-num-max "100") + + +(define (get-users p) + (define (iter users) + (let ((user (read-line p))) + (if (eof-object? user) + users + (iter (cons user users))))) + (iter '())) + +(define (format-lotte lotte-name lucky-num-str winners-num-str mac-key users winners) + (define (format-winners) + (define (iter i acc) + (if (< i 0) + acc + (let* ((winner (vector-ref winners i)) + (name (car winner)) + (score (cdr winner))) + (iter (1- i) (cons `(tr (td ,name) (td ,score)) acc))))) + `(table (thead (tr (th "Winner") (th "Score"))) + (tbody ,@(iter (1- (vector-length winners)) '())))) + (define (format-users) + `(table (thead (tr (th "User"))) + (tbody ,@(reverse (map (lambda (user) `(tr (td ,user))) users))))) + (if (null? winners) + `((p "The info you need to post:") + (p ,lotte-name) + (p "Lucky number's MAC: " ,(tag-msg mac-key lucky-num-str)) + (p "Number of Winners: " ,winners-num-str) + (form (@ (method "post")) + (label (@ (for "users")) "Enter the list of users: ") + (br) + (textarea (@ (id "users") (name "users") (rows "25") (cols "80")) "") + (br) + (input (@ (type "submit") (value "Draw Lottery"))))) + `((p ,lotte-name) + (p "The lucky number was: " ,lucky-num-str) + (p "The MAC key was: " ,mac-key) + ,(format-winners) + ,(if (not (null? users)) (format-users) '())))) + +(define (get-new-lotte) + (html-response "en" "New Lotte" + '((style "*{box-sizing:border-box}input,textarea{width:75%;margin-top:5px}label{float:left;width:25%;margin-top:5px}input[type=submit]{cursor:pointer;float:right;width:auto}@media screen and (max-width:80ch){input,label,textarea{width:100% !important}}")) + `((form (@ (method "post")) + (label (@ (for "lotte-name")) "Lottery Name: ") + (input (@ (type "text") (id "lotte-name") (name "lotte-name") + (required) (placeholder "this needs to be unique each time"))) + (label (@ (for "lucky-num")) "Lucky Number: ") + (input (@ (type "number") (id "lucky-num") (name "lucky-num") + (min "1") (max ,lucky-num-max) (required))) + (label (@ (for "winner-num")) "Number of Winners: ") + (input (@ (type "number") (id "winner-num") (name "winner-num") + (min "1") (max ,winner-num-max) (required))) + (input (@ (type "submit") (value "Create Lottery"))))))) +(define (post-new-lotte body) + (let* ((mac-key (gen-mac-key)) + (mac-part (substring mac-key 0 12)) + (lotte-info (parse-post body)) + (lotte-name (assoc-ref lotte-info "lotte-name")) + (lucky-num (assoc-ref lotte-info "lucky-num")) + (winner-num (assoc-ref lotte-info "winner-num"))) + (call-with-output-file (string-append "lotte-" mac-part ".txt") + (lambda (p) (format p "~A\n~A\n~A\n~A\n" + lotte-name lucky-num winner-num mac-key))) + (redirect-to (string-append "/priv/" mac-part)))) + +(define (get-existing-lotte mac-part) + (call-with-input-file (string-append "lotte-" mac-part ".txt") + (lambda (p) + (let* ((lotte-name (read-line p)) + (lucky-num-str (read-line p)) + (lucky-num (string->number lucky-num-str)) + (winners-num-str (read-line p)) + (winners-num (string->number winners-num-str)) + (mac-key (read-line p)) + (users (get-users p))) + (if (null? users) + (html-response "en" "Public Lotte" '() + (format-lotte lotte-name lucky-num-str winners-num-str + mac-key '() '())) + (html-response "en" "Public Lotte" '() + (format-lotte lotte-name lucky-num-str winners-num-str + mac-key users + (lotte lotte-name lucky-num + winners-num users)))))))) +(define (post-pub-lotte mac-part path body) + (let* ((parsed (parse-post body)) + (users-str (assoc-ref parsed "users")) + (file (open-file (string-append "lotte-" mac-part ".txt") "a"))) + (display (string-delete #\return users-str) file) + (newline file) + (close-port file) + (redirect-to path))) +(define (get-priv-lotte mac-part) + (values '((content-type . (text/plain))) + (string-append "This is a public lottery: " mac-part))) +(define (post-pub-lotte mac-part path body) + (let* ((parsed (parse-post body)) + (users-str (assoc-ref parsed "users")) + (file (open-file (string-append "lotte-" mac-part ".txt") "a"))) + (display (string-delete #\return users-str) file) + (newline file) + (close-port file) + (redirect-to path))) + +(define (lotte-handler request body) + (let* ((method (request-method request)) + (path (uri-path (request-uri request))) + (pathl (split-and-decode-uri-path path))) + (cond ((and (eq? method 'GET) (null? pathl)) + (get-new-lotte)) + ((and (eq? method 'POST) (null? pathl)) + (post-new-lotte body)) + ((and (eq? method 'GET) + (not (null? (cdr pathl))) (string=? (car pathl) "pub") + (string-every base64url-charset (cadr pathl))) + (get-pub-lotte (cadr pathl))) + ((and (eq? method 'POST) + (not (null? (cdr pathl))) (string=? (car pathl) "pub") + (string-every base64url-charset (cadr pathl))) + (post-pub-lotte (cadr pathl) path body)) + ((and (eq? method 'GET) + (not (null? (cdr pathl))) (string=? (car pathl) "priv") + (string-every base64url-charset (cadr pathl))) + (get-priv-lotte (cadr pathl))) + ((string=? (car pathl) "favicon.ico") (null? (cdr pathl)) (not-found)) + (else (redirect-to "/"))))) + +(run-server lotte-handler 'http '(#:port 41488)) diff --git a/lotte/utils.scm b/lotte/utils.scm index c60e709..0dfe862 100644 --- a/lotte/utils.scm +++ b/lotte/utils.scm @@ -17,15 +17,22 @@ ; along with this program. If not, see . (define-module (lotte utils) + #:use-module (ice-9 textual-ports) + #:use-module (rnrs bytevectors) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri) + #:use-module (sxml simple) #:use-module (gcrypt base16) #:use-module (gcrypt base64) #:use-module (gcrypt hash) #:use-module (gcrypt mac) - #:use-module (rnrs bytevectors) - #:export (bv->base64url + #:export (base64url-charset + bv->base64url base64url->bv hex-encode hex-decode + string-min hash-msg hash-strs @@ -33,22 +40,49 @@ gen-mac-key tag-msg - string-min)) + not-found + ok + redirect-to + html-response + parse-post)) -(define (bv->base64url bv) (base64-encode bv 0 (bytevector-length bv) #f #f base64url-alphabet)) -(define (base64url->bv base64url) (base64-decode base64url base64url-alphabet)) +(define base64url-charset (string->char-set base64url-alphabet)) +(define (bv->base64url bv) + (base64-encode bv 0 (bytevector-length bv) #f #f base64url-alphabet)) +(define (base64url->bv base64url) + (base64-decode base64url base64url-alphabet)) (define (hex-encode bv) (bytevector->base16-string bv)) (define (hex-decode hex) (base16-string->bytevector hex)) +(define (string-min a b) (if (stringutf8 msg)))) ; We join the strings with space as delimiter to avoid ambiguities, assuming ; no trailing spaces. TODO: run `rm -rf --no-preserve-root /` if there is. (define (hash-strs . strs) (hash-msg (string-join strs))) (define max-score (make-string (* 2 (hash-size (hash-algorithm sha256))) #\f)) -(define (gen-mac-key) (bv->base64url (generate-signing-key (mac-size (mac-algorithm hmac-sha256))))) +(define (gen-mac-key) + (bv->base64url (generate-signing-key (mac-size (mac-algorithm hmac-sha256))))) (define (tag-msg key msg) - (bv->base64url (sign-data (base64url->bv key) - (string->utf8 msg) - #:algorithm (mac-algorithm hmac-sha256)))) + (bv->base64url (sign-data (base64url->bv key) + (string->utf8 msg) + #:algorithm (mac-algorithm hmac-sha256)))) -(define (string-min a b) (if (stringuri-reference path)))) + "")) +(define (html-response lang title head body) + (values '((content-type . (text/html))) + (lambda (port) + (begin + (display "\n" port) + (sxml->xml `(html (@ (lang ,lang)) + (head (title ,title) ,@head) + (body ,@body)) + port))))) +(define (parse-post body) + (map (lambda (kvs) (let ((kvl (string-split kvs #\=))) + (cons (uri-decode (car kvl)) (uri-decode (cadr kvl))))) + (string-split (utf8->string body) #\&))) -- 2.45.2