brmelect/src/brmelect.scm

;;#!/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))

(define (exec sql . params)
  (apply exec* 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} }
           @,@(row-map*
              (lambda (meeting-id title from to)
                `@tr{
                   @td{@,(number->string meeting-id)}
                   @td{@,title}
                   @td{@,from}
                   @td{@,to}
                 })
              rows)
         }
      }))))
                   ;@td{,(->string from)}

;; 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)