Drastically refactor into new, modular structure
The majority of this program has been split off into two separate libraries: * chatdir, a library for easily writing chatdir daemons. * ircc, an IRC connection library. files,
This commit is contained in:
parent
cfa631834c
commit
d27418362d
|
@ -1,3 +1,8 @@
|
||||||
|
#! /bin/sh
|
||||||
|
#|
|
||||||
|
exec csi -s "$0" "$@"
|
||||||
|
|#
|
||||||
|
|
||||||
;;
|
;;
|
||||||
;; Copyright 2023, Jaidyn Levesque <jadedctrl@posteo.at>
|
;; Copyright 2023, Jaidyn Levesque <jadedctrl@posteo.at>
|
||||||
;;
|
;;
|
||||||
|
@ -16,226 +21,100 @@
|
||||||
;;
|
;;
|
||||||
|
|
||||||
(import scheme
|
(import scheme
|
||||||
(chicken file) (chicken file posix) (chicken io) (chicken keyword) (chicken random)
|
(chicken file) (chicken io) (chicken pathname)
|
||||||
(chicken pathname)
|
(chicken process-context) (chicken process-context posix)
|
||||||
(chicken pretty-print) (chicken process-context)
|
(chicken string)
|
||||||
(chicken process-context posix) (chicken string)
|
srfi-1 srfi-18 srfi-69
|
||||||
srfi-1 srfi-13 srfi-18 srfi-19 srfi-69 srfi-180
|
(prefix chatdir chatdir:) (prefix chatdir-inotify chatdir:)
|
||||||
inotify
|
ircc
|
||||||
ircc
|
getopt-long)
|
||||||
xattr
|
|
||||||
getopt-long)
|
|
||||||
|
|
||||||
|
|
||||||
;; Wrapper around `directory` that lists a dir's files as a relative path
|
|
||||||
(define (directory-rel #!optional (path "./"))
|
|
||||||
(let ([relative-parent (normalize-pathname (string-append path "/"))])
|
|
||||||
(map (lambda (leaf)
|
|
||||||
(string-append relative-parent leaf))
|
|
||||||
(directory path))))
|
|
||||||
|
|
||||||
|
|
||||||
;; Returns an inotify watch-descriptor according the given path
|
|
||||||
(define (path->wd path)
|
|
||||||
(car
|
|
||||||
(filter (lambda (wd)
|
|
||||||
(string=? (normalize-pathname (wd->path wd))
|
|
||||||
(normalize-pathname path)))
|
|
||||||
(wd-list))))
|
|
||||||
|
|
||||||
|
|
||||||
;; Attempt to remove an inotify watch; if it's already been removed, no sweat
|
|
||||||
;; (This happens sometimes when inotify automatically deletes a watch)
|
|
||||||
(define (attempt-remove-watch! watch)
|
|
||||||
(handle-exceptions exn
|
|
||||||
#t
|
|
||||||
(remove-watch! watch)))
|
|
||||||
|
|
||||||
|
|
||||||
;; Returns the path of a channel's directory
|
|
||||||
(define (channel-directory-path conn channel)
|
|
||||||
(string-append (hash-table-ref conn 'directory)
|
|
||||||
"/" channel "/"))
|
|
||||||
|
|
||||||
|
|
||||||
;; Returns the .users/ path of a channel
|
|
||||||
(define (channel-users-directory-path conn channel)
|
|
||||||
(string-append (channel-directory-path conn channel)
|
|
||||||
".users/"))
|
|
||||||
|
|
||||||
|
|
||||||
;; Main directory path of the given user
|
|
||||||
(define (channel-user-directory-path conn channel hostmask #!optional (state "all"))
|
|
||||||
(string-append (channel-users-directory-path conn channel)
|
|
||||||
state "/" (irc:hostmask-nick hostmask)))
|
|
||||||
|
|
||||||
|
|
||||||
;; Main directory path of the given user
|
|
||||||
(define (user-directory-path conn channel hostmask)
|
|
||||||
(string-append (channel-users-directory-path conn channel)
|
|
||||||
"all/" hostmask))
|
|
||||||
|
|
||||||
|
|
||||||
;; Tidies up a channel directory; removes `online` and `offline` user links, etc.
|
|
||||||
(define (cleanup-channel conn channel)
|
|
||||||
(let ([users-dir (channel-users-directory-path conn channel)])
|
|
||||||
(map
|
|
||||||
(lambda (state-dir)
|
|
||||||
(if (not (substring-index state-dir "/all"))
|
|
||||||
(map
|
|
||||||
(lambda (link)
|
|
||||||
(let ([link-path (string-append users-dir state-dir "/" link)])
|
|
||||||
(if (symbolic-link? link-path)
|
|
||||||
(delete-file link-path))))
|
|
||||||
(directory (string-append users-dir state-dir)))))
|
|
||||||
(directory users-dir))))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;; Creates a channel's file hierarchy, if need be
|
|
||||||
(define (make-channel conn channel)
|
|
||||||
(let* ([path (channel-directory-path conn channel)]
|
|
||||||
[subpath (lambda (leaf) (string-append path leaf))])
|
|
||||||
(create-directory (subpath ".in") #t)
|
|
||||||
(create-directory (subpath ".users/online") #t)
|
|
||||||
(create-directory (subpath ".users/offline") #t)
|
|
||||||
(create-directory (subpath ".users/all") #t)
|
|
||||||
(cleanup-channel conn channel)))
|
|
||||||
|
|
||||||
|
|
||||||
;; Creates a user's info files in the given channel, if need bee
|
|
||||||
(define (make-user conn channel hostmask)
|
|
||||||
(create-directory (user-directory-path conn channel hostmask) #t))
|
|
||||||
|
|
||||||
|
|
||||||
;; Disables a user-state (that is, removes a symlink from a .users directory
|
|
||||||
(define (user-disable-state conn channel hostmask state)
|
|
||||||
(let ([state-link
|
|
||||||
(create-directory (channel-user-directory-path conn channel hostmask state) #t)])
|
|
||||||
(if (or (file-exists? state-link)
|
|
||||||
(symbolic-link? state-link))
|
|
||||||
(delete-file state-link))))
|
|
||||||
|
|
||||||
|
|
||||||
;; Enables a user-state (that is, makes a symlink to a .users directory
|
|
||||||
(define (user-enable-state conn channel hostmask state)
|
|
||||||
(let ([state-link
|
|
||||||
(create-directory (channel-user-directory-path conn channel hostmask state) #t)])
|
|
||||||
(if (not (or (file-exists? state-link)
|
|
||||||
(symbolic-link? state-link)))
|
|
||||||
(create-symbolic-link (string-append "../all/" hostmask)
|
|
||||||
state-link))))
|
|
||||||
|
|
||||||
|
|
||||||
;; Ensures the enabled-state is enabled, and it's opposite (disabled-state) is not
|
|
||||||
(define (user-toggle-state conn channel hostmask enabled-state disabled-state)
|
|
||||||
(user-disable-state conn channel hostmask disabled-state)
|
|
||||||
(user-enable-state conn channel hostmask enabled-state))
|
|
||||||
|
|
||||||
|
|
||||||
;; Returns the appropriate, non-colliding file path of a hypothetical message
|
|
||||||
(define (message-file-path conn channel #!optional (suffix ""))
|
|
||||||
(let ([path
|
|
||||||
(string-append (channel-directory-path conn channel)
|
|
||||||
(date->string (current-date) "[~m-~d] ~H:~M:~S")
|
|
||||||
suffix)])
|
|
||||||
(if (file-exists? path)
|
|
||||||
(message-file-path conn channel
|
|
||||||
(number->string (+ (or (string->number suffix) 0) .1)))
|
|
||||||
path)))
|
|
||||||
|
|
||||||
|
|
||||||
;; Create a message file; putting metadata in xattrs, and text directly in the file
|
|
||||||
(define (make-message-file conn channel sender message)
|
|
||||||
(let ([file (message-file-path conn channel)])
|
|
||||||
(call-with-output-file file
|
|
||||||
(lambda (out-port) (write-string message #f out-port)))
|
|
||||||
(set-xattr file "user.chat.sender" sender)
|
|
||||||
(set-xattr file "user.chat.date" (date->string (current-date) "~1T~2"))
|
|
||||||
(set-xattr file "user.chat.channel" channel)
|
|
||||||
(set-xattr file "user.chat.mime" "text/plain")))
|
|
||||||
|
|
||||||
|
|
||||||
;; Sets a channel's .topic file
|
|
||||||
(define (set-channel-topic conn channel topic #!optional (username #f) (date #f))
|
|
||||||
(let ([topic-path (string-append (channel-directory-path conn channel)
|
|
||||||
".topic")])
|
|
||||||
(if (string? topic)
|
|
||||||
(call-with-output-file
|
|
||||||
topic-path
|
|
||||||
(lambda (out-port)
|
|
||||||
(write-string topic #f out-port))))
|
|
||||||
(if username
|
|
||||||
(set-xattr topic-path "user.chat.sender" (irc:hostmask-nick username)))))
|
|
||||||
|
|
||||||
|
|
||||||
;; Join an IRC channel
|
;; Join an IRC channel
|
||||||
(define (join-channel connection channel)
|
(define (make-join-channel-callback connection)
|
||||||
(irc:write-cmd connection "JOIN" channel)
|
(let ([root-dir (hash-table-ref connection 'directory)])
|
||||||
(make-channel connection channel))
|
(lambda (channel)
|
||||||
|
(irc:write-cmd connection "JOIN" channel))))
|
||||||
|
|
||||||
|
|
||||||
|
;; Leave an IRC channel
|
||||||
|
(define (make-leave-channel-callback connection)
|
||||||
|
(let ([root-dir (hash-table-ref connection 'directory)])
|
||||||
|
(lambda (channel)
|
||||||
|
(irc:write-cmd connection "PART" channel))))
|
||||||
|
|
||||||
|
|
||||||
;; Send message to an IRC channel
|
;; Send message to an IRC channel
|
||||||
(define (send-message connection channel message)
|
(define (make-send-message-callback connection)
|
||||||
(irc:write-cmd connection "PRIVMSG" channel message)
|
(let ([root-dir (hash-table-ref connection 'directory)])
|
||||||
(make-message-file connection channel
|
(lambda (channel message)
|
||||||
(hash-table-ref connection 'nick)
|
(irc:write-cmd connection "PRIVMSG" channel message)
|
||||||
message))
|
(chatdir:channel-message-add! root-dir channel message
|
||||||
|
(hash-table-ref connection 'nick)))))
|
||||||
|
|
||||||
|
|
||||||
;; Hook function for irc:loop; handles all IRC commands
|
;; Hook function for irc:loop; handles all IRC commands
|
||||||
(define (on-command conn cmd params #!optional sender)
|
(define (make-irc-command-callback conn)
|
||||||
(cond
|
(let ([root-dir (hash-table-ref conn 'directory)])
|
||||||
[(and (string=? cmd "PRIVMSG")
|
(lambda (conn cmd params #!optional sender)
|
||||||
(string? sender)
|
(cond
|
||||||
(irc:hostmask? sender))
|
[(and (string=? cmd "PRIVMSG")
|
||||||
(let ([target (if (irc:user-is-self? conn (car params))
|
(string? sender)
|
||||||
(irc:hostmask-nick sender)
|
(irc:hostmask? sender))
|
||||||
(car params))])
|
(let ([target (if (irc:user-is-self? conn (car params))
|
||||||
(make-message-file conn target (irc:hostmask-nick sender) (last params)))]
|
(irc:hostmask-nick sender)
|
||||||
|
(car params))])
|
||||||
|
(chatdir:channel-message-add! root-dir target
|
||||||
|
(last params) (irc:hostmask-nick sender)))]
|
||||||
|
|
||||||
[(or (string=? cmd "NOTICE")
|
[(or (string=? cmd "NOTICE")
|
||||||
(and (string=? cmd "PRIVMSG")
|
(and (string=? cmd "PRIVMSG")
|
||||||
(or (string-null? sender) (not (irc:hostmask? sender)))))
|
(or (string-null? sender) (not (irc:hostmask? sender)))))
|
||||||
(make-message-file conn ".server" "server" (last params))]
|
(chatdir:channel-message-add! root-dir ".server" (last params) "server")]
|
||||||
|
|
||||||
[(and (string=? cmd "JOIN") (irc:user-is-self? conn sender))
|
[(and (string=? cmd "JOIN") (irc:user-is-self? conn sender))
|
||||||
(make-channel conn (last params))]
|
(chatdir:channel-add! root-dir (last params))]
|
||||||
|
|
||||||
[(string=? cmd "JOIN")
|
[(string=? cmd "JOIN")
|
||||||
(make-user conn (last params) sender)]
|
(chatdir:channel-user-add! root-dir (last params) sender)]))))
|
||||||
|
|
||||||
;; [(string=? cmd "NICK")
|
;; [(string=? cmd "NICK")
|
||||||
;; (chatd-json-write conn
|
;; (chatd-json-write conn
|
||||||
;; (compose-event-alist conn "user-info" #:user (last params)))])
|
;; (compose-event-alist conn "user-info" #:user (last params)))])
|
||||||
))
|
|
||||||
|
|
||||||
|
|
||||||
;; Hook function for irc:loop; handles all IRC errors and replies
|
;; Hook function for irc:loop; handles all IRC errors and replies
|
||||||
(define (on-reply conn reply params #!optional sender)
|
(define (make-irc-reply-callback conn)
|
||||||
(cond
|
(let ([root-dir (hash-table-ref conn 'directory)])
|
||||||
;; If topic set, output to a channel's .topic file
|
(lambda (conn reply params #!optional sender)
|
||||||
[(and (eq? reply RPL_TOPIC)
|
(cond
|
||||||
(irc:channel? (second params)))
|
;; If topic set, output to a channel's .topic file
|
||||||
(set-channel-topic conn (second params) (last params))]
|
[(and (eq? reply RPL_TOPIC)
|
||||||
|
(irc:channel? (second params)))
|
||||||
|
(chatdir:channel-metadata-set! root-dir (second params)
|
||||||
|
"topic" (last params))]
|
||||||
|
|
||||||
[(and (eq? reply RPL_TOPICWHOTIME)
|
[(and (eq? reply RPL_TOPICWHOTIME)
|
||||||
(irc:channel? (second params)))
|
(irc:channel? (second params)))
|
||||||
(set-channel-topic conn (second params) #f (third params) (last params))]
|
(chatdir:channel-metadata-set! root-dir (second params)
|
||||||
|
"topic" #f
|
||||||
|
`((user.chat.sender . ,(third params))
|
||||||
|
(user.chat.date . ,(last params))))]
|
||||||
|
|
||||||
;; We've got to add users, when they join the room!
|
;; We've got to add users, when they join the room!
|
||||||
[(or (and (irc:capability? conn 'userhost-in-names)
|
[(or (and (irc:capability? conn 'userhost-in-names)
|
||||||
(eq? reply RPL_ENDOFNAMES))
|
(eq? reply RPL_ENDOFNAMES))
|
||||||
(eq? reply RPL_ENDOFWHO))
|
(eq? reply RPL_ENDOFWHO))
|
||||||
(map (lambda (nick)
|
(map (lambda (nick)
|
||||||
(let ([hostmask (irc:user-get conn nick 'hostmask)]
|
(let ([hostmask (irc:user-get conn nick 'hostmask)]
|
||||||
[channel (second params)])
|
[channel (second params)])
|
||||||
(make-user conn channel hostmask)
|
(chatdir:channel-user-add! root-dir channel nick)
|
||||||
(user-toggle-state conn channel hostmask "online" "offline")))
|
(chatdir:channel-user-toggle-states! root-dir channel nick
|
||||||
(irc:channel-users conn (second params)))]
|
"online" "offline")))
|
||||||
|
(irc:channel-users conn (second params)))]
|
||||||
|
|
||||||
[#t
|
[#t
|
||||||
(make-message-file conn ".server" "server" (last params))]))
|
(chatdir:channel-message-add! root-dir ".server" (last params) "server")]))))
|
||||||
|
|
||||||
|
|
||||||
(define *help-msg*
|
(define *help-msg*
|
||||||
|
@ -290,109 +169,6 @@
|
||||||
#t))
|
#t))
|
||||||
|
|
||||||
|
|
||||||
;; Initialization for the input loop
|
|
||||||
(define (input-loop-init connection)
|
|
||||||
(let ([irc-dir (hash-table-ref connection 'directory)])
|
|
||||||
(init!)
|
|
||||||
;; Start watching top-level IRC dir (for new channel joins, etc)
|
|
||||||
(add-watch! irc-dir
|
|
||||||
'(onlydir moved-to moved-from delete delete-self create))
|
|
||||||
|
|
||||||
|
|
||||||
;; Can't actually join channels below, unless we're connected! :P
|
|
||||||
(wait-for-registration connection)
|
|
||||||
|
|
||||||
;; Start watching input dirs of all pre-existing channel dirs
|
|
||||||
(map (lambda (path)
|
|
||||||
(let ([in-path (normalize-pathname (string-append path "/.in"))]
|
|
||||||
[dirname (pathname-file (pathname-directory (string-append path "/")))])
|
|
||||||
(join-channel connection dirname)
|
|
||||||
|
|
||||||
(add-watch! in-path '(moved-to close-write))
|
|
||||||
(print "Joined and watching: " in-path)))
|
|
||||||
(filter directory-exists? (directory-rel irc-dir)))))
|
|
||||||
|
|
||||||
|
|
||||||
;; Handles all inotify-watched file events from the top-level IRC-directory.
|
|
||||||
;; Mainly, checking for newly-joined or left channels.
|
|
||||||
(define (handle-main-dir-event connection event)
|
|
||||||
(let ([flags (event-flags event)])
|
|
||||||
(cond
|
|
||||||
;; If a channel dir's been moved or removed, stop watching (ofc)
|
|
||||||
;; … Also quit that room! Heck them!
|
|
||||||
[(or (member 'moved-from flags)
|
|
||||||
(member 'delete flags)
|
|
||||||
(member 'delete-self flags))
|
|
||||||
(let* ([channel (event-name event)]
|
|
||||||
[channel-inpath (string-append (wd->path (event-wd event)) channel "/.in")]
|
|
||||||
[channel-wd (path->wd channel-inpath)])
|
|
||||||
(print "Leaving " channel "…")
|
|
||||||
(print "Remove watch for " channel-inpath "…")
|
|
||||||
|
|
||||||
(if (and channel-wd (member channel-wd (wd-list)))
|
|
||||||
(attempt-remove-watch! channel-wd))
|
|
||||||
(if (member channel (irc:channels connection))
|
|
||||||
(irc:write-cmd connection "PART" channel)))]
|
|
||||||
|
|
||||||
;; If a dir's been created for a channel, maybe-join, then watch input!
|
|
||||||
[(or (member 'create flags)
|
|
||||||
(member 'moved-to flags))
|
|
||||||
(let* ([path (event->pathname event)]
|
|
||||||
[in-path (normalize-pathname (string-append path "/.in"))]
|
|
||||||
[dirname (pathname-file (pathname-directory (string-append path "/")))])
|
|
||||||
(print "Joining channel " dirname "…")
|
|
||||||
(join-channel connection dirname)
|
|
||||||
|
|
||||||
(add-watch! in-path '(moved-to close-write))
|
|
||||||
(print "Began watching input " in-path "."))])))
|
|
||||||
|
|
||||||
|
|
||||||
;; Handles an inotify event that pertains to a channel's .in/ directory
|
|
||||||
(define (handle-channel-dir-event connection event)
|
|
||||||
(let* ([event-dir (pathname-directory (event->pathname event))]
|
|
||||||
[dirname (pathname-file event-dir)]
|
|
||||||
[parent-dirname (pathname-file (pathname-directory event-dir))])
|
|
||||||
(cond
|
|
||||||
;; If input is given to an `.in` dir, and its channel is still valid…
|
|
||||||
;; well, send that darn message(s)! What're you waiting for?!
|
|
||||||
[(and (string=? dirname ".in")
|
|
||||||
(member parent-dirname (irc:channels connection)))
|
|
||||||
(print "Sending message(s) [" (event->pathname event) "] to " parent-dirname "…")
|
|
||||||
(map (lambda (message)
|
|
||||||
(send-message connection parent-dirname message))
|
|
||||||
(with-input-from-file (event->pathname event)
|
|
||||||
read-lines))
|
|
||||||
(delete-file* (event->pathname event))]
|
|
||||||
|
|
||||||
;; If input is given to `.in`, but its channel is invalid… let's give up.
|
|
||||||
[(string=? dirname ".in")
|
|
||||||
(print "Removing watch on " dirname "…")
|
|
||||||
(attempt-remove-watch! (event-wd event))])))
|
|
||||||
|
|
||||||
|
|
||||||
;; Handle a single inotify file event, as part of the input loop
|
|
||||||
(define (handle-file-event connection event)
|
|
||||||
(if (not (member 'ignored (event-flags event)))
|
|
||||||
(let* ([flags (event-flags event)]
|
|
||||||
[wd-path (wd->path (event-wd event))]
|
|
||||||
[main-dir? (string=? wd-path (hash-table-ref connection 'directory))])
|
|
||||||
(if main-dir?
|
|
||||||
(handle-main-dir-event connection event)
|
|
||||||
(handle-channel-dir-event connection event)))))
|
|
||||||
|
|
||||||
|
|
||||||
;; The FS-backed input loop, to be run in a seperate thread (so as to not block)
|
|
||||||
;; This handles channel leaving/joining, and sending messages
|
|
||||||
(define (input-loop connection #!optional (init #f))
|
|
||||||
(if (not init)
|
|
||||||
(input-loop-init connection))
|
|
||||||
|
|
||||||
(map (lambda (event) (handle-file-event connection event))
|
|
||||||
(next-events!))
|
|
||||||
|
|
||||||
(input-loop connection #t))
|
|
||||||
|
|
||||||
|
|
||||||
;; The `main` procedure that should be called to run feedsnake-unix for use as script.
|
;; The `main` procedure that should be called to run feedsnake-unix for use as script.
|
||||||
(define (main)
|
(define (main)
|
||||||
(let* ([args (getopt-long (command-line-arguments) *opts*)]
|
(let* ([args (getopt-long (command-line-arguments) *opts*)]
|
||||||
|
@ -409,11 +185,13 @@
|
||||||
[fullname (alist-ref 'name args)]
|
[fullname (alist-ref 'name args)]
|
||||||
[server (last free-args)]
|
[server (last free-args)]
|
||||||
[hostname (first (string-split server ":"))]
|
[hostname (first (string-split server ":"))]
|
||||||
[port (or (string->number (last (string-split server ":")))
|
[port (string->number (or (last (string-split server ":"))
|
||||||
6697)]
|
"6697"))]
|
||||||
[directory (or (alist-ref 'directory args) "./")]
|
[directory (normalize-pathname
|
||||||
|
(string-append (or (alist-ref 'directory args) "./")
|
||||||
|
"/"))]
|
||||||
[connection (if server
|
[connection (if server
|
||||||
(irc:connect server port username nickname password fullname)
|
(irc:connect hostname port username nickname password fullname)
|
||||||
#f)])
|
#f)])
|
||||||
|
|
||||||
(unless connection
|
(unless connection
|
||||||
|
@ -421,18 +199,26 @@
|
||||||
|
|
||||||
(hash-table-set! connection 'directory
|
(hash-table-set! connection 'directory
|
||||||
(normalize-pathname (string-append directory "/")))
|
(normalize-pathname (string-append directory "/")))
|
||||||
|
(create-directory (string-append directory "/.server"))
|
||||||
|
|
||||||
;; Kick off the input loop, which monitors channels' .in/ dirs
|
;; Kick off the input loop, which monitors channels' .in/ dirs
|
||||||
(thread-start!
|
(thread-start!
|
||||||
(make-thread
|
(make-thread
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(input-loop connection))
|
(let ([callbacks
|
||||||
|
`((join-channel . ,(make-join-channel-callback connection))
|
||||||
|
(leave-channel . ,(make-leave-channel-callback connection))
|
||||||
|
(send-message . ,(make-send-message-callback connection)))])
|
||||||
|
(thread-sleep! 10)
|
||||||
|
(chatdir:input-loop-init directory callbacks)
|
||||||
|
(chatdir:input-loop directory callbacks)))
|
||||||
"Chat input"))
|
"Chat input"))
|
||||||
|
|
||||||
;; Kick off the mani loop!
|
(print (hash-table-ref connection 'directory))
|
||||||
|
;; Kick off the main loop!
|
||||||
(irc:loop connection
|
(irc:loop connection
|
||||||
on-command
|
(make-irc-command-callback connection)
|
||||||
on-reply))))
|
(make-irc-reply-callback connection)))))
|
||||||
|
|
||||||
|
|
||||||
(main)
|
(main)
|
||||||
|
|
Reference in New Issue