351 lines
12 KiB
Scheme
351 lines
12 KiB
Scheme
;;
|
|
;; Copyright 2023, Jaidyn Levesque <jadedctrl@posteo.at>
|
|
;;
|
|
;; This program is free software: you can redistribute it and/or
|
|
;; modify it under the terms of the GNU General Public License as
|
|
;; published by the Free Software Foundation, either version 3 of
|
|
;; the License, or (at your option) any later version.
|
|
;;
|
|
;; This program 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 General Public License for more details.
|
|
;;
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
|
;;
|
|
|
|
(import scheme
|
|
(chicken file) (chicken io) (chicken sort) (chicken string)
|
|
(chicken irregex) (chicken pretty-print)
|
|
srfi-1 srfi-19
|
|
(prefix chatdir chatdir:)
|
|
(prefix intarweb intarweb:)
|
|
(prefix spiffy spiffy:)
|
|
(prefix uri-common uri:))
|
|
|
|
|
|
;; Santize text for placement in HTML.
|
|
(define (html-encode-string text)
|
|
(irregex-replace/all
|
|
"{" (spiffy:htmlize text) "{"))
|
|
|
|
|
|
;; Generate HTML from a template-file, substituting in variables as appropriate.
|
|
(define (html-from-template template-file variables-alist)
|
|
(let ([text (call-with-input-file template-file
|
|
(lambda (in-port) (read-string #f in-port)))])
|
|
(map (lambda (variable-pair)
|
|
(set! text
|
|
(irregex-replace/all
|
|
(string-append "{{" (car variable-pair) "}}")
|
|
text
|
|
(cdr variable-pair))))
|
|
variables-alist)
|
|
text))
|
|
|
|
|
|
;; Generate HTML for a listing of all rooms the user's joined.
|
|
(define (room-listing-html irc-dir)
|
|
(html-from-template
|
|
"templates/room-list.html"
|
|
`(("LIST_ITEMS"
|
|
. ,(reduce-right
|
|
string-append
|
|
""
|
|
(map (lambda (room)
|
|
(room-list-item-html irc-dir room))
|
|
(chatdir:channels irc-dir)))))))
|
|
|
|
|
|
(define (room-list-item-html irc-dir room)
|
|
(let* ([messages (channel-messages-sorted irc-dir room)]
|
|
[last-message (if (null? messages)
|
|
#f (last messages))]
|
|
[message-text (if last-message
|
|
(car last-message) "")]
|
|
[message-sender (if last-message
|
|
(or (alist-ref 'user.chat.sender
|
|
(cdr last-message))
|
|
"")
|
|
"")]
|
|
[message-time
|
|
(if last-message
|
|
(date->string (alist-ref 'user.chat.date
|
|
(cdr last-message))
|
|
"[~H:~M:~S]")
|
|
"")])
|
|
(html-from-template
|
|
"templates/room-list-item.html"
|
|
`(("ROOM_TITLE" . ,(html-encode-string room))
|
|
("ROOM_ID" . ,(uri:uri-encode-string room))
|
|
("LAST_MSG" . ,message-text)
|
|
("LAST_TIME" . ,message-time)
|
|
("LAST_MSG_SENDER" . ,message-sender)))))
|
|
|
|
|
|
|
|
;; “Send” a message to the given chatdir root, simply by creating a file.
|
|
;; That was easy!
|
|
(define (send-message irc-dir channel message)
|
|
(with-output-to-file
|
|
(string-append irc-dir "/" channel "/.in/a")
|
|
(lambda ()
|
|
(write-string message))))
|
|
|
|
|
|
;; Returns all of a channel's messages — in alist format, with parsed datetimes.
|
|
(define (channel-messages irc-dir channel)
|
|
(map (lambda (msg-alist)
|
|
(let ([date-str (alist-ref 'user.chat.date (cdr msg-alist))])
|
|
(append
|
|
(list (car msg-alist))
|
|
(alist-update 'user.chat.date
|
|
(string->date date-str "~Y-~m-~dT~H:~M:~S~z")
|
|
(cdr msg-alist)))))
|
|
(map (lambda (message)
|
|
(chatdir:channel-message-get irc-dir channel message))
|
|
(chatdir:channel-messages irc-dir channel))))
|
|
|
|
|
|
;; Returns all of a channel's messages, sorted in order of datetime.
|
|
(define (channel-messages-sorted irc-dir channel)
|
|
(sort
|
|
(channel-messages irc-dir channel)
|
|
(lambda (a b)
|
|
(let ([date-a (alist-ref 'user.chat.date (cdr a))]
|
|
[nano-a (alist-ref 'user.chat.date.nanoseconds (cdr a))]
|
|
[date-b (alist-ref 'user.chat.date (cdr b))]
|
|
[nano-b (alist-ref 'user.chat.date.nanoseconds (cdr b))])
|
|
(cond [(and (date=? date-a date-b)
|
|
nano-a nano-b)
|
|
(> (string->number nano-b)
|
|
(string->number nano-a))]
|
|
[#t
|
|
(date<? date-b date-a)])))))
|
|
|
|
|
|
(define (channel-online-users irc-dir channel)
|
|
(directory
|
|
(string-append irc-dir "/" channel "/.users/online/")))
|
|
|
|
|
|
(define (room-users-html irc-dir channel)
|
|
(html-from-template
|
|
"templates/room-user-list.html"
|
|
`(("ROOM_TITLE" . ,(uri:uri-decode-string channel))
|
|
("LIST_ITEMS"
|
|
. ,(reduce-right
|
|
string-append ""
|
|
(map (lambda (user)
|
|
(room-users-item-html irc-dir channel user))
|
|
(channel-online-users
|
|
irc-dir
|
|
(uri:uri-decode-string channel))))))))
|
|
|
|
|
|
(define (room-users-item-html irc-dir channel user)
|
|
(html-from-template
|
|
"templates/room-user-list-item.html"
|
|
`(("USER_NAME" . ,user))))
|
|
|
|
|
|
(define (room-index-html irc-dir channel)
|
|
(html-from-template
|
|
"templates/room-index.html"
|
|
`(("ROOM_TITLE" . ,(uri:uri-decode-string channel))
|
|
("ROOM_ID" . ,(uri:uri-encode-string channel)))))
|
|
|
|
|
|
(define (room-send-html)
|
|
(html-from-template "templates/room-send.html" '()))
|
|
|
|
|
|
;; Generate the HTML listing a room's chat messages.
|
|
(define (room-messages-html irc-dir channel)
|
|
(html-from-template
|
|
"templates/room-messages.html"
|
|
`(("ROOM_TITLE" . ,(uri:uri-decode-string channel))
|
|
("LIST_ITEMS"
|
|
. ,(reduce-right
|
|
string-append ""
|
|
(map (lambda (message)
|
|
(room-messages-item-html irc-dir channel message))
|
|
(channel-messages-sorted
|
|
irc-dir
|
|
(uri:uri-decode-string channel))))))))
|
|
|
|
|
|
;; Generate the HTML for a specific message in a specific room.
|
|
;; Used to substitute {{LIST_ITEMS}} in the room-messages template.
|
|
(define (room-messages-item-html irc-dir channel message)
|
|
(if (and (list? message)
|
|
(string? (car message)))
|
|
(html-from-template
|
|
"templates/room-messages-item.html"
|
|
`(("MESSAGE_SENDER"
|
|
. ,(html-encode-string
|
|
(or (alist-ref 'user.chat.sender (cdr message)) "")))
|
|
("MESSAGE_DATE"
|
|
. ,(html-encode-string
|
|
(date->string
|
|
(alist-ref 'user.chat.date (cdr message))
|
|
"~Y-~m-~d")))
|
|
("MESSAGE_TIME"
|
|
. ,(html-encode-string
|
|
(date->string
|
|
(alist-ref 'user.chat.date (cdr message))
|
|
"~H:~M:~S")))
|
|
("MESSAGE_TEXT"
|
|
. ,(html-encode-string
|
|
(car message)))))
|
|
""))
|
|
|
|
|
|
;; Send response for a listing of joined rooms.
|
|
(define (http-get-rooms-list irc-dir #!optional request path)
|
|
(spiffy:send-response status: 'ok
|
|
body: (room-listing-html irc-dir)))
|
|
|
|
|
|
|
|
(define (http-get-room-dir irc-dir #!optional request path)
|
|
(let* ([channel (third path)]
|
|
[channel? (member channel (chatdir:channels irc-dir))]
|
|
[sub-path (if (eq? (length path) 4)
|
|
(fourth path) #f)])
|
|
(cond
|
|
[(not channel?)
|
|
(spiffy:send-response code: 404
|
|
body: "<h1>That's not a channel, smh!!</h1>")]
|
|
[(equal? sub-path "users")
|
|
(spiffy:send-response status: 'ok
|
|
body: (room-users-html irc-dir channel))]
|
|
[(equal? sub-path "messages")
|
|
(spiffy:send-response status: 'ok
|
|
body: (room-messages-html irc-dir channel))]
|
|
[(equal? sub-path "send")
|
|
(spiffy:send-response status: 'ok
|
|
body: (room-send-html))]
|
|
[(or (not sub-path) (string=? sub-path ""))
|
|
(spiffy:send-response status: 'ok
|
|
body: (room-index-html irc-dir channel))])))
|
|
|
|
|
|
(define (http-post-room-dir irc-dir #!optional request path)
|
|
(let* ([channel (third path)]
|
|
[request-data (intarweb:read-urlencoded-request-data request 50000)])
|
|
(if (alist-ref 'message request-data)
|
|
(begin
|
|
(send-message irc-dir channel (alist-ref 'message request-data))
|
|
(sleep 1)))
|
|
(http-get-room-dir irc-dir request (list '/ "room" channel "messages"))))
|
|
|
|
|
|
;; Send response for the / index.
|
|
(define (http-get-root #!optional irc-dir request path)
|
|
(spiffy:send-response status: 'ok body:
|
|
(html-from-template "templates/index.html" '())))
|
|
|
|
|
|
;; Send a 404 response, with disappointed text.
|
|
(define (http-404 #!optional irc-dir request path)
|
|
(spiffy:send-response code: 404 body: "<h1>Sad!</h1>"))
|
|
|
|
|
|
;; Send the static style CSS.
|
|
(define (http-get-style #!optional irc-dir request path)
|
|
(spiffy:send-response
|
|
status: 'ok
|
|
body: (call-with-input-file "templates/style.css"
|
|
(lambda (in-port) (read-string #f in-port)))
|
|
headers: '((content-type "text/css"))))
|
|
|
|
|
|
;; An associative list of all GET handlers, to be used by assoc-by-path.
|
|
(define http-get-handlers
|
|
`(((/ "room") . ,http-get-rooms-list)
|
|
((/ "room" "*") . ,http-get-room-dir)
|
|
((/ "style.css") . ,http-get-style)
|
|
((/ "*") . ,http-404)
|
|
(("*") . ,http-get-root)))
|
|
|
|
|
|
;; An associative list of POST handlers, to be used by assoc-by-path.
|
|
(define http-post-handlers
|
|
`(((/ "room" "*") . ,http-post-room-dir)))
|
|
|
|
|
|
;; Get a pair from an associative list based on the closest match to the
|
|
;; given path. Wild-cards acceptable! For example…
|
|
;; '(/ "dad" "mom") matches, in order of precedence:
|
|
;; '(/ "dad" "mom") '(/ "dad" "*") '(/ "*")
|
|
(define (assoc-by-path path-list alist #!optional (top-level #t))
|
|
(let* ([our-list=
|
|
(lambda (a b)
|
|
(list= equal? a b))]
|
|
[path-list
|
|
(if (eq? (string-length (last path-list)) 0)
|
|
(drop-right path-list 1)
|
|
path-list)]
|
|
[parent-path (drop-right path-list 1)]
|
|
[exact
|
|
(and top-level
|
|
(assoc path-list
|
|
alist our-list=))]
|
|
[inexact
|
|
(assoc (append parent-path '("*"))
|
|
alist our-list=)])
|
|
(or exact
|
|
inexact
|
|
(and (not (null? parent-path))
|
|
(assoc-by-path parent-path alist #f)))))
|
|
|
|
|
|
;; Handle all GET requests.
|
|
(define (http-get irc-dir request continue)
|
|
(let* ([path (uri:uri-path (intarweb:request-uri request))]
|
|
[handler (assoc-by-path path http-get-handlers)])
|
|
(if handler
|
|
(apply (cdr handler) (list irc-dir request path))
|
|
(continue))))
|
|
|
|
|
|
;; Handle all POST requests.
|
|
(define (http-post irc-dir request continue)
|
|
(let* ([path (uri:uri-path (intarweb:request-uri request))]
|
|
[handler (assoc-by-path path http-post-handlers)])
|
|
(if handler
|
|
(apply (cdr handler) (list irc-dir request path))
|
|
(continue))))
|
|
|
|
|
|
;; Creates a handler for all HTTP requests, with the given IRC dir.
|
|
(define (make-http-handler irc-dir)
|
|
(lambda (continue)
|
|
(let* ([request (spiffy:current-request)]
|
|
[request-type (intarweb:request-method request)])
|
|
(cond [(eq? request-type 'GET)
|
|
(http-get irc-dir request continue)]
|
|
[(eq? request-type 'POST)
|
|
(http-post irc-dir request continue)]
|
|
[#t
|
|
(intarweb:continue)]))))
|
|
|
|
|
|
;; Kick off the HTTP server.
|
|
(define (start-server irc-dir)
|
|
(spiffy:vhost-map `((".*" . ,(make-http-handler irc-dir))))
|
|
(spiffy:root-path irc-dir)
|
|
(spiffy:start-server port: 8080))
|
|
|
|
|
|
;; Check if a `list` begins with the elements of another list.
|
|
(define (starts-with? list list-start #!optional (= equal?))
|
|
(list= =
|
|
(take list (length list-start))
|
|
list-start))
|
|
|
|
|
|
(start-server "/home/jaidyn/Chat/IRC/leagueh/")
|