forked from brmlab/brmelect-github
290 lines
9.3 KiB
Scheme
290 lines
9.3 KiB
Scheme
;;#!/usr/bin/env csi -s
|
|
|
|
;; Import necessary modules for CGI handling
|
|
;(use posix)
|
|
;(use srfi-19) ; For basic string manipulation
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken format)
|
|
;(chicken miscmacros)
|
|
miscmacros
|
|
postgresql
|
|
webgate-core
|
|
;configuration
|
|
)
|
|
(import-for-syntax
|
|
srfi-1
|
|
webgate-core)
|
|
|
|
;(eval-when (eval)
|
|
;(cond-expand
|
|
; (chicken
|
|
; (begin
|
|
; (import (only webgate-utils use-at-read-table))
|
|
; (use-at-read-table #:list-arguments? #t)))
|
|
; ;(else #f)
|
|
; )
|
|
|
|
;; Thread-local parameter to re-use SQLite3 DB handle for subsequent queries
|
|
;(define *cached-brmelect-db* (make-parameter #f))
|
|
;(define =brmelect-db-path= "/home/brmelect/brmelect/brmelect.sqlite3")
|
|
|
|
(define db
|
|
(connect
|
|
'((dbname . "brmelect")
|
|
(user . "brmelectmgr")
|
|
(host . "localhost"))))
|
|
|
|
(define (query-db sql . params)
|
|
(apply query db sql params))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; helpers
|
|
(define (param parameters key)
|
|
(hash-table-ref/default parameters key ""))
|
|
|
|
(define (int-param parameters key)
|
|
(string->number (param parameters key)))
|
|
|
|
(define (redirect url)
|
|
(make-response
|
|
code: 302
|
|
headers: `((location . ,url))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; navigation menu
|
|
(define (layout title . body)
|
|
`@html{
|
|
@head{
|
|
@title{@,title}
|
|
}
|
|
@body{
|
|
@h1{@,title}
|
|
@nav{
|
|
@a[(href "/members")]{"Members"} " | "
|
|
@a[(href "/meetings")]{"Meetings"} " | "
|
|
@a[(href "/votes")]{"Votes"}
|
|
}
|
|
@hr{}
|
|
@,@body
|
|
}})
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; /admin/members
|
|
(define-resource (members "admin" "members" parameters)
|
|
(let ((rows (query-db "SELECT member_id,nick,name,surname FROM brm.members ORDER BY nick")))
|
|
(make-html-response
|
|
200
|
|
(layout
|
|
"Members"
|
|
`@div{
|
|
@table{
|
|
@tr{@th{ID} @th{Nick} @th{Name} @th{Surname}}
|
|
@,@(row-map*
|
|
(lambda (id nick name surname)
|
|
`@tr{@td{@,(number->string id)}@td{@,nick}@td{@,name}@td{@,surname}})
|
|
rows)
|
|
}
|
|
}))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; /members/add
|
|
;(define-resource (members-add "elect" "members" "add" parameters)
|
|
; (if (param parameters 'submit)
|
|
; (begin
|
|
; (exec
|
|
; "INSERT INTO brm.members(member_id,nick,name,surname) VALUES($1,$2,$3,$4)"
|
|
; (int-param parameters 'member_id)
|
|
; (param parameters 'nick)
|
|
; (param parameters 'name)
|
|
; (param parameters 'surname))
|
|
; (redirect "/members"))
|
|
; (make-html-response
|
|
; 200
|
|
; (layout
|
|
; "Add Member"
|
|
; `@form[action: "/members/add" method: "get"]{
|
|
; "ID:" @input[name: "member_id"]{} @br{}
|
|
; "Nick:" @input[name: "nick"]{} @br{}
|
|
; "Name:" @input[name: "name"]{} @br{}
|
|
; "Surname:" @input[name: "surname"]{} @br{}
|
|
; @input[type: "submit" name: "submit" value: "Create"]{}
|
|
; }))))
|
|
;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; /admin/meetings
|
|
(define-resource (meetings "admin" "meetings" parameters)
|
|
(let ((rows
|
|
(query-db "SELECT meeting_id,title,lower(held_on),upper(held_on) FROM brm.meetings ORDER BY meeting_id")))
|
|
(make-html-response
|
|
200
|
|
(layout
|
|
"Meetings"
|
|
`@div{
|
|
@a[(href "/meetings/add")]{"Add Meeting"}
|
|
@table{
|
|
@tr{ @th{ID} @th{Title} @th{Start} @th{End} @th{Actions}}
|
|
@,@(row-map*
|
|
(lambda (meeting-id title from to)
|
|
`@tr{
|
|
@td{@,(number->string meeting-id)}
|
|
@td{@,title}
|
|
@td{@,from}
|
|
@td{@,to}
|
|
@td{@a[(href @,(string-append "/admin/meeting/" (number->string meeting-id)))]{details}}
|
|
})
|
|
rows)
|
|
}
|
|
}))))
|
|
;@td{,(->string from)}
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; /admin/meeting/:id
|
|
(define-resource (meeting-votes "admin" "meeting" id params)
|
|
(let ((meeting-info (query-db "SELECT title FROM brm.meetings WHERE meeting_id = $1" id))
|
|
(rows (query-db "SELECT vote_id,title,lower(open_time),upper(open_time),is_active FROM brm.votes WHERE meeting_id = $1
|
|
ORDER BY vote_id" id)))
|
|
(make-html-response
|
|
200
|
|
(layout
|
|
(string-append "Meeting " (identity id) " - Votes")
|
|
`@div{
|
|
@h2{@,(row-fold* (lambda (title x) title) "" meeting-info) - Votes}
|
|
@form[
|
|
(action @,(string-append "/admin/meeting/" id "/vote"))
|
|
(method "POST")]
|
|
@table{
|
|
@tr{ @th{"New Vote Title"} @th{}}
|
|
@tr{ @td{@input[(name "vote-title")]} @td{@input[(type "submit") (value "Create Vote")]}}}
|
|
@table{
|
|
@tr{ @th{ID} @th{Title} @th{Start} @th{End} @th{Active} @th{Actions}}
|
|
@,@(row-map*
|
|
(lambda (vote-id title from to is-active)
|
|
`@tr{
|
|
@td{@,(number->string vote-id)}
|
|
@td{@,title}
|
|
@td{@,from}
|
|
@td{@,to}
|
|
@td{@,(if (eq? is-active #t) "Yes" "No")}
|
|
@td{@a[(href @,(string-append "/admin/vote/" (number->string vote-id)))]{details}}
|
|
})
|
|
rows)
|
|
}
|
|
}))))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; /admin/meeting/:id/vote
|
|
(define-resource (create-meeting-vote "admin" "meeting" id "vote" params)
|
|
(if (string=? (resource-context-method (current-resource-context)) "POST")
|
|
(let ((title (hash-ref params 'vote-title)))
|
|
(query-db "SELECT brm.create_vote_and_init_status($1, $2)" id title)
|
|
(make-html-response
|
|
200
|
|
(layout
|
|
"Vote Created"
|
|
`@div{
|
|
@p{"Vote successfully created for meeting " (number->string id) "."}
|
|
@a[(href (string-append "/admin/meeting/" (number->string id)))]{Back to Meeting}
|
|
})))
|
|
(make-error-response
|
|
405 "The access method used to request the document is not supported."
|
|
#:headers '(("Allow" . "POST")))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; /foo -- debug endpoint
|
|
(define-resource (foo-bar-baz "foo" id params)
|
|
(make-html-response
|
|
200
|
|
(layout
|
|
"FOO"
|
|
`@div{
|
|
@,(resource-context-method (current-resource-context))
|
|
@p{Foo successfully frobnicated for meeting @,(identity id).}
|
|
@a[(href @,(string-append "/admin/meeting/" id))]{Back to Meeting}
|
|
})))
|
|
|
|
;; Returns (possibly cached) SQLite3 DB handle
|
|
;(define (brmelect-db)
|
|
; (let ((cdb (*cached-brmelect-db*)))
|
|
; (if cdb
|
|
; cdb
|
|
; (begin
|
|
; (*cached-brmelect-db*
|
|
; (let ((handler (make-busy-timeout 2000)))
|
|
; (let ((db (open-database =brmelect-db-path=)))
|
|
; (set-busy-handler! db handler)
|
|
; db)))
|
|
; (*cached-brmelect-db*)))))
|
|
|
|
;(define (initialize-db)
|
|
; (let ((db (brmelect-db)))
|
|
; ;; admin passwords
|
|
; (execute db "create table if not exists admins (login text not null primary key, password text not null)")
|
|
; ;; GA
|
|
; (execute db "create table if not exists general_assemblies (id integer primary key, ga_date text not null, ga_open integer not null)")
|
|
; (execute db "insert or ignore into general_assemblies (id, ga_date, ga_open) values (17, '2025-01-21', 1)")
|
|
; ;; elections
|
|
; (execute db "create table if not exists elections (id integer primary key autoincrement, ga_id integer not null, election_name text not null, election_running integer not null, election_file text not null, foreign key (ga_id) references general_assemblies(id))")
|
|
; ;; candidates
|
|
; (execute db "create table if not exists candidates (id integer primary key autoincrement, election_id integer not null, candidate_name text not null, candidate_nick text not null, foreign key (election_id) references elections(id)")
|
|
; ))
|
|
|
|
;(initialize-db)
|
|
|
|
(define-resource (root* parameters)
|
|
(make-html-response
|
|
200
|
|
;@li{@a[(href ,(resource-uri calc "add"))]{Suspensions}}
|
|
;@,common-head
|
|
`@html{
|
|
@head{
|
|
@title{foo}
|
|
}
|
|
@body{
|
|
@h1{web foo}
|
|
@div[(class "navbar navbar-inverse navbar-fixed-top")]{
|
|
@div[(class "navbar-inner")]{
|
|
@div[(class "container")]{
|
|
@a[(class "brand") (href "#")]{WebGate}
|
|
@div[(class "nav-collapse collapse")]{
|
|
@ul[(class "nav")]{
|
|
@li[(class "active")]{@a[(href "#")]{Miscellaneous}}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}))
|
|
|
|
(define brmelect-style
|
|
"p, li { font-family: monospace; }
|
|
#ballot { margin-left: auto; margin-right: auto; border: 1pt solid; width: 20em; padding: 1ex 1em; }
|
|
.error { text-width: bold; color: red }
|
|
#blurb { margin: 8ex 2em; }
|
|
table { margin-left: auto; margin-right: auto; border: 1pt solid; border-collapse: collapse; }
|
|
td { border: 1pt solid; padding: 0.5ex 0.5em; }")
|
|
|
|
(define-resource (elect "elect" parameters)
|
|
(make-html-response
|
|
200
|
|
`@html{
|
|
@head{@title{brmelect Web Ballot}
|
|
@style[(type "text/css")]{@,brmelect-style}}
|
|
@body{
|
|
@h1{web ballot}
|
|
}}))
|
|
|
|
(define-resource (elect-config "elect" "config" parameters)
|
|
(make-html-response
|
|
200
|
|
`@html{
|
|
@head{@title{brmelect web config}}
|
|
@body{
|
|
@h1{web config}
|
|
}}))
|
|
|
|
(cgi-main-loop handle-request)
|