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>
|
||||
;;
|
||||
|
|
@ -16,175 +21,42 @@
|
|||
;;
|
||||
|
||||
(import scheme
|
||||
(chicken file) (chicken file posix) (chicken io) (chicken keyword) (chicken random)
|
||||
(chicken pathname)
|
||||
(chicken pretty-print) (chicken process-context)
|
||||
(chicken process-context posix) (chicken string)
|
||||
srfi-1 srfi-13 srfi-18 srfi-19 srfi-69 srfi-180
|
||||
inotify
|
||||
(chicken file) (chicken io) (chicken pathname)
|
||||
(chicken process-context) (chicken process-context posix)
|
||||
(chicken string)
|
||||
srfi-1 srfi-18 srfi-69
|
||||
(prefix chatdir chatdir:) (prefix chatdir-inotify chatdir:)
|
||||
ircc
|
||||
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
|
||||
(define (join-channel connection channel)
|
||||
(irc:write-cmd connection "JOIN" channel)
|
||||
(make-channel connection channel))
|
||||
(define (make-join-channel-callback connection)
|
||||
(let ([root-dir (hash-table-ref connection 'directory)])
|
||||
(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
|
||||
(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)
|
||||
(make-message-file connection channel
|
||||
(hash-table-ref connection 'nick)
|
||||
message))
|
||||
(chatdir:channel-message-add! root-dir channel message
|
||||
(hash-table-ref connection 'nick)))))
|
||||
|
||||
|
||||
;; 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
|
||||
[(and (string=? cmd "PRIVMSG")
|
||||
(string? sender)
|
||||
|
|
@ -192,36 +64,42 @@
|
|||
(let ([target (if (irc:user-is-self? conn (car params))
|
||||
(irc:hostmask-nick sender)
|
||||
(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")
|
||||
(and (string=? cmd "PRIVMSG")
|
||||
(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))
|
||||
(make-channel conn (last params))]
|
||||
(chatdir:channel-add! root-dir (last params))]
|
||||
|
||||
[(string=? cmd "JOIN")
|
||||
(make-user conn (last params) sender)]
|
||||
(chatdir:channel-user-add! root-dir (last params) sender)]))))
|
||||
|
||||
;; [(string=? cmd "NICK")
|
||||
;; (chatd-json-write conn
|
||||
;; (compose-event-alist conn "user-info" #:user (last params)))])
|
||||
))
|
||||
|
||||
|
||||
;; 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
|
||||
;; If topic set, output to a channel's .topic file
|
||||
[(and (eq? reply RPL_TOPIC)
|
||||
(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)
|
||||
(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!
|
||||
[(or (and (irc:capability? conn 'userhost-in-names)
|
||||
|
|
@ -230,12 +108,13 @@
|
|||
(map (lambda (nick)
|
||||
(let ([hostmask (irc:user-get conn nick 'hostmask)]
|
||||
[channel (second params)])
|
||||
(make-user conn channel hostmask)
|
||||
(user-toggle-state conn channel hostmask "online" "offline")))
|
||||
(chatdir:channel-user-add! root-dir channel nick)
|
||||
(chatdir:channel-user-toggle-states! root-dir channel nick
|
||||
"online" "offline")))
|
||||
(irc:channel-users conn (second params)))]
|
||||
|
||||
[#t
|
||||
(make-message-file conn ".server" "server" (last params))]))
|
||||
(chatdir:channel-message-add! root-dir ".server" (last params) "server")]))))
|
||||
|
||||
|
||||
(define *help-msg*
|
||||
|
|
@ -290,109 +169,6 @@
|
|||
#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.
|
||||
(define (main)
|
||||
(let* ([args (getopt-long (command-line-arguments) *opts*)]
|
||||
|
|
@ -409,11 +185,13 @@
|
|||
[fullname (alist-ref 'name args)]
|
||||
[server (last free-args)]
|
||||
[hostname (first (string-split server ":"))]
|
||||
[port (or (string->number (last (string-split server ":")))
|
||||
6697)]
|
||||
[directory (or (alist-ref 'directory args) "./")]
|
||||
[port (string->number (or (last (string-split server ":"))
|
||||
"6697"))]
|
||||
[directory (normalize-pathname
|
||||
(string-append (or (alist-ref 'directory args) "./")
|
||||
"/"))]
|
||||
[connection (if server
|
||||
(irc:connect server port username nickname password fullname)
|
||||
(irc:connect hostname port username nickname password fullname)
|
||||
#f)])
|
||||
|
||||
(unless connection
|
||||
|
|
@ -421,18 +199,26 @@
|
|||
|
||||
(hash-table-set! connection 'directory
|
||||
(normalize-pathname (string-append directory "/")))
|
||||
(create-directory (string-append directory "/.server"))
|
||||
|
||||
;; Kick off the input loop, which monitors channels' .in/ dirs
|
||||
(thread-start!
|
||||
(make-thread
|
||||
(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"))
|
||||
|
||||
;; Kick off the mani loop!
|
||||
(print (hash-table-ref connection 'directory))
|
||||
;; Kick off the main loop!
|
||||
(irc:loop connection
|
||||
on-command
|
||||
on-reply))))
|
||||
(make-irc-command-callback connection)
|
||||
(make-irc-reply-callback connection)))))
|
||||
|
||||
|
||||
(main)
|
||||
|
|
|
|||
Reference in New Issue