jadedctrl/ irc-chatdir
Archived
1
0
Disbranĉigi 0
Fontkodo Tirpetoj Activity

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:
Jaidyn Ann 2023-05-29 00:21:03 -05:00
parent cfa631834c
commit d27418362d
1 changed files with 97 additions and 311 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

344
irc-chatdir.scm Normal file → Executable file
View File

@ -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,175 +21,42 @@
;; ;;
(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
xattr
getopt-long) 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)
(let ([root-dir (hash-table-ref connection 'directory)])
(lambda (channel message)
(irc:write-cmd connection "PRIVMSG" channel message) (irc:write-cmd connection "PRIVMSG" channel message)
(make-message-file connection channel (chatdir:channel-message-add! root-dir channel message
(hash-table-ref connection 'nick) (hash-table-ref connection 'nick)))))
message))
;; 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)
(let ([root-dir (hash-table-ref conn 'directory)])
(lambda (conn cmd params #!optional sender)
(cond (cond
[(and (string=? cmd "PRIVMSG") [(and (string=? cmd "PRIVMSG")
(string? sender) (string? sender)
@ -192,36 +64,42 @@
(let ([target (if (irc:user-is-self? conn (car params)) (let ([target (if (irc:user-is-self? conn (car params))
(irc:hostmask-nick sender) (irc:hostmask-nick sender)
(car params))]) (car params))])
(make-message-file conn target (irc:hostmask-nick sender) (last 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)
(let ([root-dir (hash-table-ref conn 'directory)])
(lambda (conn reply params #!optional sender)
(cond (cond
;; If topic set, output to a channel's .topic file ;; If topic set, output to a channel's .topic file
[(and (eq? reply RPL_TOPIC) [(and (eq? reply RPL_TOPIC)
(irc:channel? (second params))) (irc:channel? (second params)))
(set-channel-topic conn (second params) (last 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)
@ -230,12 +108,13 @@
(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
"online" "offline")))
(irc:channel-users conn (second params)))] (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)