From b3c2b56df388ee0f09e90370b7763096a984073b Mon Sep 17 00:00:00 2001 From: Janneke Nieuwenhuizen Date: Sat, 12 Aug 2023 22:40:05 +0200 Subject: [PATCH] Import (8sync contrib irc) library from Snuik. Snuik was created using 8sync, imported (8sync contrib irc) to override it locally for Snuik, refactored parsing, moved irc procedures out to this library. * 8sync/contrib/irc.scm: New file. * Makefile.am (SOURCES): Add it. --- 8sync/contrib/irc.scm | 270 ++++++++++++++++++++++++++++++++++++++++++ Makefile.am | 1 + 2 files changed, 271 insertions(+) create mode 100644 8sync/contrib/irc.scm diff --git a/8sync/contrib/irc.scm b/8sync/contrib/irc.scm new file mode 100644 index 0000000..d6c9f64 --- /dev/null +++ b/8sync/contrib/irc.scm @@ -0,0 +1,270 @@ +;;; Snuik --- An IRC bot using guile-8sync +;;; Copyright © 2023 Janneke Nieuwenhuizen +;;; +;;; This file is part of Snuik. +;;; +;;; Snuik 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. +;;; +;;; Snuik 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 Snuik. If not, see . +;;; +;;; Commentary: +;;; +;;; Low-level IRC procedures imported from Snuik; (snuik irc). +;;; +;;; Code: + +(define-module (8sync contrib irc) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-71) + + #:use-module (ice-9 rdelim) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + + #:export (%irc:action-regexp + %irc:default-port + %irc:line-regexp + %irc:eol + %irc:prefix-regexp + + + make-irc:message + irc:message? + irc:message-line + irc:message-command + irc:message-prefix + irc:message-params + irc:message-speaker + irc:message-channel + irc:message-message + irc:message-emote? + irc:message-private? + + irc:action + irc:emote + irc:join + irc:leave + irc:line->message + irc:listen + irc:names + irc:nick + irc:notice + irc:params->channel+message+emote? + irc:parse + irc:parse-params + irc:part + irc:pong + irc:prefix->host+user+nick + irc:prefix->nick + irc:quit + irc:receive + irc:send + irc:send-line + irc:send-message + irc:user)) + +;;; +;;; Constants. +;;; +(define %irc:default-port 6665) + +(define %irc:eol "\r\n") + +(define %irc:action-regexp "\x01(ACTION) ([^\x01]+)\x01") +(define %irc:line-regexp "(:[^ ]+ )?([A-Za-z0-9]+)(.*)") +(define %irc:prefix-regexp "^([^!]+)!~?([^@]+)@(.+)") +(define %irc:quote-regexp "(.*)[: ]*\x02([^\x02]+)\x02(.*)") + + +;;; +;;; Utilities, from (snuik util). +;;; +(define (match:positions m) + "If string-match M succeeded, return the positions of its substring +matches as a list." + (and m + (match (vector->list m) + ((string positions ...) + positions)))) + +(define (match:substrings m) + "If string-match M succeeded, return its substrings as a list." + (and m + (let ((lst (vector->list m))) + (map (cute match:substring m <>) (iota (1- (length lst))))))) + + +;;; +;;; Listen. +;;; +(define* (irc:listen hostname #:key (port %irc:default-port) (sleep sleep)) + (let ((socket (socket PF_INET SOCK_STREAM 0))) + (cond + (socket + (let* ((flags (fcntl socket F_GETFL)) + (network-addresses (hostent:addr-list (gethost hostname)))) + (match network-addresses + ((address rest ...) + (let ((ip-address (inet-ntop AF_INET address))) + (connect socket AF_INET (inet-pton AF_INET ip-address) port)))) + socket)) + (else + (sleep 1) + (irc:listen hostname #:port port #:sleep sleep))))) + +(define (irc:receive socket) + (string-trim-right (read-line socket) #\return)) + +(define (irc:send socket template . args) + (let ((line (apply format #f template args))) + (format socket "~a~a" line %irc:eol))) + + +;;; +;;; Commands. +;;; +(define (irc:action socket channel line) + (let ((line (format #f "\\x01ACTION ~a\\x01" line))) + (irc:send socket channel line))) + +(define irc:emote irc:action) + +(define (irc:join socket channel) + (irc:send socket "JOIN ~a" channel)) + +(define (irc:names socket channel) + (irc:send socket "NAMES ~a" channel)) + +(define (irc:nick socket nick) + (irc:send socket "NICK ~a" nick)) + +(define (irc:notice socket channel line) + (irc:send socket "NOTICE ~a :~a" channel line)) + +(define (irc:part socket channel) + (irc:send socket "PART ~a" channel)) + +(define irc:leave irc:part) + +(define* (irc:pong socket #:optional pong) + (irc:send socket "PONG ~a" pong)) + +(define (irc:privmsg socket channel line) + (irc:send socket "PRIVMSG ~a :~a" channel line)) + +(define* (irc:quit socket #:optional message) + (let ((message (if message (format #f " :~a" message) + ""))) + (irc:send socket "QUIT~a" message) + (close socket))) + +(define* (irc:user socket user #:key (host "*") (real user) (server "*")) + (irc:send socket "USER ~a ~a ~a :~a" user host server real)) + + +;;; +;;; Send message. +;;; +(define* (irc:send-line socket channel line #:key emote?) + (let ((send (if emote? irc:emote + irc:privmsg))) + (irc:privmsg socket channel line))) + +(define* (irc:send-message socket channel message #:key emote?) + (let ((lines (string-split message #\newline))) + (for-each (cut irc:send-line socket channel <> #:emote? emote?) lines))) + + +;;; +;;; Parse message. +;;; +(define-immutable-record-type + (make-irc:message line command prefix params + speaker channel message emote? private?) + irc:message? + (line irc:message-line) + (command irc:message-command) + (prefix irc:message-prefix) + (params irc:message-params) + (channel irc:message-channel) + (speaker irc:message-speaker) + (message irc:message-message) + (emote? irc:message-emote?) + (private? irc:message-private?)) + +(define (irc:parse-params params) + (let* ((params (string-trim-both params)) + (m (string-match ":(.+)" params))) + (match (match:positions m) + (((start . _) . _) + (let* ((message (substring params (1+ start) (string-length params))) + (m (string-match %irc:action-regexp message)) + (param (match (match:substrings m) + ((_ action message) `(,(string->symbol action) ,message)) + (_ message)))) + (append (irc:parse-params (substring params 0 start)) (list param)))) + (_ (string-split params #\space))))) + +(define (irc:prefix->host+user+nick prefix) + "Parse PREFIX and return three values, NICK, USER, and HOST." + (match prefix + ((? string?) + (let ((m (string-match %irc:prefix-regexp prefix))) + (if (not m) (values prefix #f #f) + (match (match:substrings m) + ((_ nick host user) + (values host user nick)))))) + (_ (values prefix #f #f)))) + +(define (irc:prefix->nick prefix) + "Parse PREFIX and return NICK." + (let ((host user nick (irc:prefix->host+user+nick prefix))) + nick)) + +(define (irc:parse line) + "Parse LINE and return four values: LINE, COMMAND, PREFIX, and PARAMS." + (let ((m (string-match %irc:line-regexp line))) + (match (match:substrings m) + ((_ prefix command params) + (let* ((code (and=> command string->number)) + (command (or code (and=> command string->symbol))) + (prefix (and=> prefix (cute substring <> 1))) + (params (irc:parse-params params))) + (values line command prefix params))) + ((prefix command) + (let ((nick (irc:prefix->nick prefix))) + (values line command prefix '()))) + (_ (values line #f #f '()))))) + +(define (irc:params->channel+message+emote? params) + "Parse PARAMS and return three values, CHANNEL, MESSAGE, and EMOTE?" + (match params + ((channel (and (? string?) words) ...) + (let ((message (string-join words))) + (values channel message #f))) + ((channel ('ACTION (and words (? string?))) ...) + (let ((message (string-join words))) + (values channel message #t))) + (_ (values #f #f #f)))) + +(define (irc:line->message line) + "Parse LINE and return an ." + (call-with-values (cute irc:parse line) + (lambda (line command prefix params) + (let* ((host user nick (irc:prefix->host+user+nick prefix)) + (channel message emote? + (irc:params->channel+message+emote? params)) + (private? (and (string? channel) + (not (string-prefix? "#" channel))))) + (make-irc:message line command prefix params + nick channel message emote? private?))))) diff --git a/Makefile.am b/Makefile.am index bc75d48..e3eada3 100644 --- a/Makefile.am +++ b/Makefile.am @@ -53,6 +53,7 @@ SOURCES = \ 8sync/ports.scm \ 8sync/rmeta-slot.scm \ 8sync/contrib/base64.scm \ + 8sync/contrib/irc.scm \ 8sync/contrib/sha-1.scm \ 8sync/systems/irc.scm \ 8sync/systems/web.scm \ -- 2.31.1