brmlab/brmelect
9
0
Fork 0
forked from brmlab/brmelect-github
Code Pull requests Activity

fix more

Browse source
This commit is contained in:
TMA 2026-03-15 13:22:51 +01:00
parent 5019188ed6
commit 5911221acb
1 changed files with 141 additions and 72 deletions
Download patch file Download diff file Expand all files Collapse all files

213
src/brmelect.scm
View file

@ -59,6 +59,17 @@
code: 302 code: 302
headers: `((location . ,url)))) headers: `((location . ,url))))
(define-syntax define-resource-POST
(syntax-rules ()
((_ (name step/arg ... parameters)
expr ...)
(define-resource (name step/arg ... parameters)
(if (string=? (resource-context-method (current-resource-context)) "POST")
(begin expr ...)
(make-error-response
405 "The access method used to request the document is not supported."
#:headers '(("Allow" . "POST"))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; navigation menu ;; navigation menu
(define (layout title . body) (define (layout title . body)
@ -144,6 +155,74 @@
})))) }))))
;@td{,(->string from)} ;@td{,(->string from)}
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; /admin/votes ; obsolete
;(define-resource (votes "admin" "votes" parameters)
; (let ((rows
; (query-db
; "SELECT vote_id,meeting_id,title,opens_at,closes_at,is_active FROM brm.votes ORDER BY vote_id")))
; (make-html-response
; 200
; (layout
; "Votes"
; `@div{
; @a[href: "/votes/add"]{"Create Vote"}
; @table{
; @tr{
; @th{"ID"}
; @th{"Meeting"}
; @th{"Name"}
; @th{"Opens"}
; @th{"Closes"}
; @th{"Active"}
; }
; ,@(row-map
; (lambda (r)
; `@tr{
; @td{,(number->string (vector-ref r 0))}
; @td{,(number->string (vector-ref r 1))}
; @td{,(vector-ref r 2)}
; @td{,(->string (vector-ref r 3))}
; @td{,(->string (vector-ref r 4))}
; @td{,(if (vector-ref r 5) "yes" "no")}
; })
; rows)
; }
; }))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; /elect/status ; obsolete
;(define-resource (status "elect" "status" parameters)
; (let* ((vote (int-param parameters 'vote_id))
; (rows
; (query-db
; "SELECT m.member_id,m.nick,s.in_debt,s.short_tenure,s.eligible
; FROM brm.member_status s
; JOIN brm.members m USING(member_id)
; WHERE vote_id=$1
; ORDER BY m.member_id"
; vote)))
; (make-html-response
; 200
; (layout
; "Member Status"
; `@table{
; @tr{
; @th{"Member"}
; @th{"Debt"}
; @th{"Short Tenure"}
; @th{"Eligible"}
; }
; ,@(row-map
; (lambda (r)
; `@tr{
; @td{,(vector-ref r 1)}
; @td{,(if (vector-ref r 2) "yes" "no")}
; @td{,(if (vector-ref r 3) "yes" "no")}
; @td{,(if (vector-ref r 4) "yes" "no")}
; })
; rows)
; }))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; /admin/meeting/:id ;; /admin/meeting/:id
@ -205,50 +284,41 @@ ORDER BY vote_id" id))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; /admin/meeting/:id/members ;; /admin/meeting/:id/members
(define-resource (update-meeting-members "admin" "meeting" id "members" params) (define-resource-POST (update-meeting-members "admin" "meeting" id "members" params)
(if (string=? (resource-context-method (current-resource-context)) "POST") (let* ((all-member-rows (query-db "SELECT member_id, eligible, present FROM brm.meeting_member_status WHERE meeting_id = $1" id))
(let* ((all-member-rows (query-db "SELECT member_id, eligible, present FROM brm.meeting_member_status WHERE meeting_id = (member-updates
$1" id)) (for-each
(member-updates (lambda (member-row)
(for-each (let* ((member-id (vector-ref member-row 0))
(lambda (member-row) (eligible-str (param params (string-append "eligible_" (number->string member-id))))
(let* ((member-id (vector-ref member-row 0)) (present-str (param params (string-append "present_" (number->string member-id)))))
(eligible-str (param params (string-append "eligible_" (number->string member-id)))) (when member-id
(present-str (param params (string-append "present_" (number->string member-id))))) (query-db "UPDATE brm.meeting_member_status SET eligible = $2, present = $3 WHERE member_id = $1 AND
(when member-id meeting_id = $4"
(query-db "UPDATE brm.meeting_member_status SET eligible = $2, present = $3 WHERE member_id = $1 AND member-id (if eligible-str #t #f) (if present-str #t #f) id))))
meeting_id = $4" all-member-rows)))
member-id (if eligible-str #t #f) (if present-str #t #f) id)))) (make-html-response
all-member-rows))) 200
(make-html-response (layout
200 "Members Updated"
(layout `@div{
"Members Updated" @p{Members status updated successfully for meeting @,(identity id).}
`@div{ @a[(href @,(string-append "/admin/meeting/" id))]{Back to Meeting}
@p{Members status updated successfully for meeting @,(identity id).} }))))
@a[(href @,(string-append "/admin/meeting/" id))]{Back to Meeting}
})))
(make-error-response
405 "The access method used to request the document is not supported."
#:headers '(("Allow" . "POST")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; /admin/meeting/:id/vote ;; /admin/meeting/:id/vote
(define-resource (create-meeting-vote "admin" "meeting" id "vote" params) (define-resource-POST (create-meeting-vote "admin" "meeting" id "vote" params)
(if (string=? (resource-context-method (current-resource-context)) "POST") (let ((title (param params "vote-title")))
(let ((title (param params "vote-title"))) (query-db "SELECT brm.create_vote_and_init_status($1, $2)" id title)
(query-db "SELECT brm.create_vote_and_init_status($1, $2)" id title) (make-html-response
(make-html-response 200
200 (layout
(layout "Vote Created"
"Vote Created" `@div{
`@div{ @p{Vote successfully created for meeting @,(identity id).}
@p{Vote successfully created for meeting @,(identity id).} @a[(href @,(string-append "/admin/meeting/" id))]{Back to Meeting}
@a[(href @,(string-append "/admin/meeting/" id))]{Back to Meeting} }))))
})))
(make-error-response
405 "The access method used to request the document is not supported."
#:headers '(("Allow" . "POST")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; /admin/vote/:id ;; /admin/vote/:id
@ -301,36 +371,35 @@ meeting_id = $4"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; /admin/vote/:id/members ;; /admin/vote/:id/members
(define-resource (update-vote-members "admin" "vote" id "members" params) (define-resource-POST (update-vote-members "admin" "vote" id "members" params)
(if (string=? (resource-context-method (current-resource-context)) "POST") (let* ((all-member-rows (query-db "SELECT member_id, eligible, present, meeting_id FROM brm.vote_member_status WHERE
(let* ((all-member-rows (query-db "SELECT member_id, eligible, present, meeting_id FROM brm.vote_member_status WHERE vote_id = $1" id)))
vote_id = $1" id)) ;(row-for-each*
(member-updates ; (lambda (member-id eligible present meeting-id)
(for-each ; (let* ((eligible-str (param params (string-append "eligible_" (number->string member-id))))
(lambda (member-row) ; (present-str (param params (string-append "present_" (number->string member-id)))))
(let* ((member-id (vector-ref member-row 0)) ; (when member-id
(meeting-id (vector-ref member-row 3)) ; (query-db "UPDATE brm.vote_member_status SET eligible = $2, present = $3 WHERE member_id = $1 AND vote_id = $4"
(eligible-str (param params (string-append "eligible_" (number->string member-id)))) ; member-id (if eligible-str #t #f) (if present-str #t #f) id)
(present-str (param params (string-append "present_" (number->string member-id))))) ; (when (and present-str (eq? (string=? (if (eq? (vector-ref member-row 3) #f) #t) #t))
(when member-id ; (query-db "SELECT brm.sync_vote_present_to_meeting($1, $2, $3)"
(query-db "UPDATE brm.vote_member_status SET eligible = $2, present = $3 WHERE member_id = $1 AND vote_id = ; member-id meeting-id (if present-str #t #f))))))
$4" ; all-member-rows))
member-id (if eligible-str #t #f) (if present-str #t #f) id) (make-html-response
(when (and present-str (eq? (string=? (if (eq? (vector-ref member-row 3) #f) #t) #t)) 200
(query-db "SELECT brm.sync_vote_present_to_meeting($1, $2, $3)" (layout
member-id meeting-id (if present-str #t #f)))))) "Vote Members Updated"
all-member-rows)))) `@div{
(make-html-response @p{Members status updated successfully for vote @,(identity id).}
200 @a[(href @,(string-append "/admin/vote/" id))]{Back to Vote}
(layout @table{@tr{@th{member-id}@th{eligible-str}@th{present-str}}
"Vote Members Updated" @,@(row-map*
`@div{ (lambda (member-id eligible present meeting-id)
@p{Members status updated successfully for vote @,(identity id).} (let* ((eligible-str (param params (string-append "eligible_" (number->string member-id))))
@a[(href @,(string-append "/admin/vote/" id))]{Back to Vote} (present-str (param params (string-append "present_" (number->string member-id)))))
}))) `@tr{@td{@,(number->string member-id)}@td{@,eligible-str}@td{@,present-str}}))
(make-error-response all-member-rows)
405 "The access method used to request the document is not supported." }}))))
#:headers '(("Allow" . "POST")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; /admin/vote/:id/end ;; /admin/vote/:id/end
@ -416,7 +485,7 @@ $4"
} }
} }
})) }))
(define brmelect-style (define brmelect-style
"p, li { font-family: monospace; } "p, li { font-family: monospace; }
#ballot { margin-left: auto; margin-right: auto; border: 1pt solid; width: 20em; padding: 1ex 1em; } #ballot { margin-left: auto; margin-right: auto; border: 1pt solid; width: 20em; padding: 1ex 1em; }