A lotte-web.scm => lotte-web.scm +161 -0
@@ 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 <https://www.gnu.org/licenses/>.
+
+(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))
M lotte/utils.scm => lotte/utils.scm +44 -10
@@ 17,15 17,22 @@
; along with this program. If not, see <https://www.gnu.org/licenses/>.
(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 (string<? a b) a b))
(define (hash-msg msg) (hex-encode (sha256 (string->utf8 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 (string<? a b) a b))
+(define (not-found) (values (build-response #:code 404) ""))
+(define (redirect-to path)
+ (values
+ (build-response #:code 303
+ #:headers `((location . ,(string->uri-reference path))))
+ ""))
+(define (html-response lang title head body)
+ (values '((content-type . (text/html)))
+ (lambda (port)
+ (begin
+ (display "<!DOCTYPE html>\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) #\&)))