;; $Id: infra.scm,v 1.4 2023/11/17 19:04:40 fpp Exp fpp $ ;; Internal structure for infrastructure website (use-modules (ice-9 format) (srfi srfi-1) ; lists (srfi srfi-9) ; records (srfi srfi-9 gnu) ; set-record-type-printer! (srfi srfi-10) (srfi srfi-19) ; dates (rnrs enums) (rnrs io ports) (rnrs bytevectors) ;(ice-9 iconv) (sxml simple) ; sxml (web uri) (web http) (web server) (web server http) (web request) (web response) ) (define-record-type comment (make-comment date-string statement) comment? (date-string comment-date-string) (statement comment-statement set-comment-statement!)) (set-record-type-printer! comment (lambda (record port) (format port "#,(comment ~s ~s)~%" (comment-date-string record) (comment-statement record)))) (define-reader-ctor 'comment make-comment) (define (make-dated-comment date statement) (make-comment (date->string date "~5") statement)) (define (comment-date comment) (let ((time-fmt-string "~Y-~m-~dT~H:~M:~S")) (string->date (comment-date-string comment) time-fmt-string))) (define-record-type issue (make-issue date-string subject description comment-list) issue? (date-string issue-date-string) (subject issue-subject) (description issue-description) (comment-list issue-comment-list set-issue-comment-list!)) (set-record-type-printer! issue (lambda (record port) (format port "#,(issue ~s ~s ~s ~s)~%" (issue-date-string record) (issue-subject record) (issue-description record) (issue-comment-list record)))) (define-reader-ctor 'issue make-issue) (define (issue-date issue) (let ((time-fmt-string "~Y-~m-~dT~H:~M:~S")) (string->date (issue-date-string issue) time-fmt-string))) (define (make-dated-issue date subject description comment-list) (make-issue (date->string date "~5") subject description comment-list)) (define test-issue-list (list (make-dated-issue (current-date) "Rent" "Rent is too high" '()) (make-dated-issue (current-date) "Broken Board" "The board needs replacment." '()) (make-dated-issue (current-date) "Fan does not spin" "The big overhead fan doesn't spin" (list (make-dated-comment (current-date) "This was reported to the landlord."))) ) ) ;(define datafile "/home/fpp/src/infrastructure/infra.data.scm") (define datafile "infra.data.scm") (define persist-issue-list (let ((datafile datafile)) (lambda (issue-list) (let ((oport (open-file-output-port datafile (make-enumeration '(no-fail))))) (put-datum oport issue-list) (close-port oport) )))) (define (get-issue-list datafile) (let* ((iport (open-file-input-port datafile)) (data (get-datum iport))) (close-port iport) ;; (if (null? data) ;; test-issue-list ;; data) ;; data ) ) (define issue-list (get-issue-list datafile) ) (define (templatize title body) `(html (head (title ,title)) (body ,@body))) (define* (respond #:optional body #:key (status 200) (title "Hello hello!") (doctype "\n") (content-type-params '((charset . "utf-8"))) (content-type 'text/html) (extra-headers '()) (sxml (and body (templatize title body)))) (values (build-response #:code status #:headers `((content-type . (,content-type ,@content-type-params)) ,@extra-headers)) (lambda (port) (if sxml (begin (if doctype (display doctype port)) (sxml->xml sxml port)))))) (define (debug-page request body) (respond `((h1 "hello world!") (table (tr (th "header") (th "value")) ,@(map (lambda (pair) `(tr (td (tt ,(with-output-to-string (lambda () (display (car pair)))))) (td (tt ,(with-output-to-string (lambda () (write (cdr pair)))))))) (request-headers request) ))))) (define (debug-accept request body) (respond `((h1 "Accept") (p ,(with-output-to-string (lambda () (write (request-accept request)))))))) (define (basic-handler request request-body) (respond (format #f "~s ~s~%" request request-body) )) (define (summary-page issue-list) (let ((tabulated-issue-list (if (null? issue-list) '() (list-tabulate (length issue-list) (lambda (n) (cons n (list-ref issue-list n))))) )) `((html (head (title "Issues") (meta (@ (http-equiv author) (content "Frank Pursel"))) (meta (@ (http-equiv pragma) (content "no-cache"))) (style (@ (type "text/css")) "h3 {text-align: center} tr {margin: 10px auto 10px auto } .centered { margin: 10px auto 10px auto } .centertable { margin: 0px auto }")) (body (h3 "Table of issues") (p (@ (class centered)) (table (@ (border 1) (class centertable)) (tr (th "Subject") (th "Description") (th "Created")) ,(if (null? tabulated-issue-list) `() (map (lambda (issue) `(tr (td (a (@ (href ,(format #f "/issue-detail/~a" (car issue)) )) ,(issue-subject (cdr issue)))) (td ,(issue-description (cdr issue))) (td ,(date->string (issue-date (cdr issue)) "~Y-~b-~d")))) tabulated-issue-list) ) ) ) (hr) (form (@ (action "/add-issue") (method "POST")) (fieldset (label "New Issue?") (br) Subject (br) (input (@ (type "text") (name "subject"))) (br) Description (br) (textarea (@ (rows 4) (cols 40) (name "description")) "") (p (input (@ (type "submit") (value "Submit"))))) ) )))) ) (define (issue-detail issue-list issue-number) (let ((issue (list-ref issue-list issue-number))) `((html (head (title "Issue Detail") (meta (@ (http-equiv author) (content "Frank Pursel"))) (meta (@ (http-equiv pragma) (content "no-cache"))) (style (@ (type "text/css")) "h3 {text-align: center} tr {margin: 10px auto 10px auto } .centered { margin: 10px auto 10px auto } .centertable { margin: 0px auto }")) (body (h3 "Issue Detail") (p "Subject: " ,(issue-subject issue)) (p "Description: " ,(issue-description issue)) (hr) (table (@ (border 1) (class centertable)) (tr (th Time) (th Comments)) ,@(map (lambda (comment) `(tr (td ,(date->string (comment-date comment) "~Y-~b-~d ~H:~M")) (td ,(comment-statement comment)))) (issue-comment-list issue))) (hr) (form (@ (action ,(format #f "/add-comment/~a" issue-number)) (method "POST")) (fieldset (label "Additional Comment?") (br) (textarea (@ (rows 4) (cols 40) (name "comment")) "") (p (input (@ (type "submit") (value "Submit"))))) ) (br) (p (@ (align "right")) (a (@ (href "/")) "Summary")) ))) ) ) (define (request-path-component request) (uri-path (request-uri request))) (define (request-path-component-list request) (split-and-decode-uri-path (uri-path (request-uri request)))) (define (request-query-components request) (uri-query (request-uri request))) ;; (define (path-handler request request-body) ;; (cond ((equal? (uri-path (request-uri request)) "add-issue") ;; (if (add-issue request request-body issue-list) ;; (respond (summary-page issue-list)) ;; (respond "Failed to add issue."))) ;; (#t ;; (respond (summary-page issue-list))))) (define (request-body->alist request-body) (map (lambda (kv) (string-split kv #\=)) (map (lambda (input) (uri-decode input)) (string-split (utf8->string request-body) #\&)))) ;; Beware externally provided data. (define (request-body->safe-alist request-body) (catch #t (lambda () (map (lambda (kv) (string-split kv #\=)) (map (lambda (input) (uri-decode input)) (string-split (utf8->string request-body) #\&)))) (lambda (key args) #f))) (define (path-handler request request-body) (respond (cond ((member "add-issue" (split-and-decode-uri-path (uri-path (request-uri request)))) (summary-page (let* ((vars (request-body->alist request-body)) (subject (cadr (assoc "subject" vars))) (description (cadr (assoc "description" vars)))) (reverse (cons (make-dated-issue (current-date) subject description '()) (reverse (get-issue-list datafile))))))) (else (summary-page (get-issue-list datafile))) ) )) (define (parse-headers request) (split-and-decode-uri-path (uri-path (request-uri request)))) ;; This path handler catches header parsing exceptions making ;; the server more stable. (define (path-handler3 request request-body) (let* ((datafile datafile) (date (current-date)) (issue-list (get-issue-list datafile)) (decoded-path (catch #t (lambda () (parse-headers request)) (lambda (key args) (respond (summary-page issue-list)))))) (if (response? decoded-path) decoded-path ; There was a problem in parsing; serve the summary. (respond (cond ((member "issue-detail" decoded-path) (issue-detail issue-list (string->number (last decoded-path)))) ((member "add-issue" decoded-path) (let ( (vars (request-body->safe-alist request-body)) ) (if vars (let* ( (subject (cadr (assoc "subject" vars))) (description (cadr (assoc "description" vars))) (new-issue (make-dated-issue date subject description '())) (new-issue-list (reverse (cons new-issue (reverse issue-list))))) (if (not (member subject (map issue-subject issue-list))) ; No duplicate subjects. (begin (set! issue-list new-issue-list) (persist-issue-list issue-list))))) (summary-page issue-list) )) ((member "add-comment" decoded-path) (let ((vars (request-body->safe-alist request-body))) (if vars (let* ( (statement (cadr (assoc "comment" vars))) (new-comment (make-dated-comment (current-date) statement)) (issue-number (string->number (last decoded-path))) (issue (list-ref issue-list issue-number)) (comment-list (issue-comment-list issue)) (new-comment-list (reverse (cons new-comment (reverse comment-list))))) (set-issue-comment-list! issue new-comment-list) (persist-issue-list issue-list) (issue-detail issue-list issue-number) ) (summary-page issue-list)))) (else (summary-page issue-list)))) ) ) ) ;; The first servable working handler (define (path-handler2 request request-body) (let* ((datafile datafile) (date (current-date)) (decoded-path (split-and-decode-uri-path (uri-path (request-uri request)))) (issue-list (get-issue-list datafile)) ) (respond (cond ((member "issue-detail" decoded-path) (issue-detail issue-list (string->number (last decoded-path)))) ((member "add-issue" decoded-path) (let* ((vars (request-body->alist request-body)) (subject (cadr (assoc "subject" vars))) (description (cadr (assoc "description" vars))) (new-issue (make-dated-issue date subject description '())) (new-issue-list (reverse (cons new-issue (reverse issue-list))))) (set! issue-list new-issue-list) (persist-issue-list issue-list) (summary-page issue-list) )) ((member "add-comment" decoded-path) (let* ((vars (request-body->alist request-body)) (statement (cadr (assoc "comment" vars))) (new-comment (make-dated-comment (current-date) statement)) (issue-number (string->number (last decoded-path))) (issue (list-ref issue-list issue-number)) (comment-list (issue-comment-list issue)) (new-comment-list (reverse (cons new-comment (reverse comment-list))))) (set-issue-comment-list! issue new-comment-list) (persist-issue-list issue-list) (issue-detail issue-list issue-number) )) (else (summary-page issue-list)))))) (define (next-handler request request-body) (respond (summary-page issue-list) )) ;; In use remember to init the issue list. ;; eg.. (persist-issue-list test-issue-list) or (persist-issue-list '()) ;; ;; Then if entirely local ;; (run-server path-handler2) ;; ;; If in the local network ;; (run-server path-handler2 'http (list #:port 9090 #:addr (inet-pton AF_INET "192.168.16.106"))) ;;