~shironeko/lotte

788e47db675bfc37733618a2468c45ec3094d5c9 — shironeko 9 months ago 44fa83f master
add mock web interface
2 files changed, 205 insertions(+), 10 deletions(-)

A lotte-web.scm
M lotte/utils.scm
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) #\&)))