diff --git a/irc-chatdir.scm b/irc-chatdir.scm old mode 100644 new mode 100755 index cf198b5..1f2dcc2 --- a/irc-chatdir.scm +++ b/irc-chatdir.scm @@ -1,3 +1,8 @@ + #! /bin/sh + #| + exec csi -s "$0" "$@" + |# + ;; ;; Copyright 2023, Jaidyn Levesque ;; @@ -16,226 +21,100 @@ ;; (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 - 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))))) + (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 + getopt-long) ;; 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) - (irc:write-cmd connection "PRIVMSG" channel message) - (make-message-file connection channel - (hash-table-ref connection 'nick) - 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) + (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) - (cond - [(and (string=? cmd "PRIVMSG") - (string? sender) - (irc:hostmask? sender)) - (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)))] +(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) + (irc:hostmask? sender)) + (let ([target (if (irc:user-is-self? conn (car params)) + (irc:hostmask-nick sender) + (car 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))] + [(or (string=? cmd "NOTICE") + (and (string=? cmd "PRIVMSG") + (or (string-null? sender) (not (irc:hostmask? sender))))) + (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))] + [(and (string=? cmd "JOIN") (irc:user-is-self? conn sender)) + (chatdir:channel-add! root-dir (last params))] - [(string=? cmd "JOIN") - (make-user conn (last params) sender)] + [(string=? cmd "JOIN") + (chatdir:channel-user-add! root-dir (last params) sender)])))) -;; [(string=? cmd "NICK") -;; (chatd-json-write conn + ;; [(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) - (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))] +(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))) + (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))] + [(and (eq? reply RPL_TOPICWHOTIME) + (irc:channel? (second 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) - (eq? reply RPL_ENDOFNAMES)) - (eq? reply RPL_ENDOFWHO)) - (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"))) - (irc:channel-users conn (second params)))] + ;; We've got to add users, when they join the room! + [(or (and (irc:capability? conn 'userhost-in-names) + (eq? reply RPL_ENDOFNAMES)) + (eq? reply RPL_ENDOFWHO)) + (map (lambda (nick) + (let ([hostmask (irc:user-get conn nick 'hostmask)] + [channel (second params)]) + (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))])) + [#t + (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)