8sync/contrib/irc.scm

   1 ;;; Snuik --- An IRC bot using guile-8sync
   2 ;;; Copyright © 2023 Janneke Nieuwenhuizen <janneke@gnu.org>
   3 ;;;
   4 ;;; This file is part of Snuik.
   5 ;;;
   6 ;;; Snuik is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; Snuik is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with Snuik.  If not, see <http://www.gnu.org/licenses/>.
  18 ;;;
  19 ;;; Commentary:
  20 ;;;
  21 ;;; Low-level IRC procedures imported from Snuik; (snuik irc).
  22 ;;;
  23 ;;; Code:
  24
  25 (define-module (8sync contrib irc)
  26   #:use-module (srfi srfi-9 gnu)
  27   #:use-module (srfi srfi-26)
  28   #:use-module (srfi srfi-71)
  29
  30   #:use-module (ice-9 rdelim)
  31   #:use-module (ice-9 match)
  32   #:use-module (ice-9 regex)
  33
  34   #:export (%irc:action-regexp
  35             %irc:default-port
  36             %irc:line-regexp
  37             %irc:eol
  38             %irc:prefix-regexp
  39
  40             <irc:message>
  41             make-irc:message
  42             irc:message?
  43             irc:message-line
  44             irc:message-command
  45             irc:message-prefix
  46             irc:message-params
  47             irc:message-speaker
  48             irc:message-channel
  49             irc:message-message
  50             irc:message-emote?
  51             irc:message-private?
  52
  53             irc:action
  54             irc:emote
  55             irc:join
  56             irc:leave
  57             irc:line->message
  58             irc:listen
  59             irc:names
  60             irc:nick
  61             irc:notice
  62             irc:params->channel+message+emote?
  63             irc:parse
  64             irc:parse-params
  65             irc:part
  66             irc:pong
  67             irc:prefix->host+user+nick
  68             irc:prefix->nick
  69             irc:quit
  70             irc:receive
  71             irc:send
  72             irc:send-line
  73             irc:send-message
  74             irc:user))
  75
  76 ;;;
  77 ;;; Constants.
  78 ;;;
  79 (define %irc:default-port 6665)
  80
  81 (define %irc:eol "\r\n")
  82
  83 (define %irc:action-regexp "\x01(ACTION) ([^\x01]+)\x01")
  84 (define %irc:line-regexp "(:[^ ]+ )?([A-Za-z0-9]+)(.*)")
  85 (define %irc:prefix-regexp "^([^!]+)!~?([^@]+)@(.+)")
  86 (define %irc:quote-regexp "(.*)[: ]*\x02([^\x02]+)\x02(.*)")
  87
  88 \f
  89 ;;;
  90 ;;; Utilities, from (snuik util).
  91 ;;;
  92 (define (match:positions m)
  93   "If string-match M succeeded, return the positions of its substring
  94 matches as a list."
  95   (and m
  96        (match (vector->list m)
  97          ((string positions ...)
  98           positions))))
  99
 100 (define (match:substrings m)
 101   "If string-match M succeeded, return its substrings as a list."
 102   (and m
 103        (let ((lst (vector->list m)))
 104          (map (cute match:substring m <>) (iota (1- (length lst)))))))
 105
 106 \f
 107 ;;;
 108 ;;; Listen.
 109 ;;;
 110 (define* (irc:listen hostname #:key (port %irc:default-port) (sleep sleep))
 111   (let ((socket (socket PF_INET SOCK_STREAM 0)))
 112     (cond
 113      (socket
 114       (let* ((flags (fcntl socket F_GETFL))
 115              (network-addresses (hostent:addr-list (gethost hostname))))
 116         (match network-addresses
 117           ((address rest ...)
 118            (let ((ip-address (inet-ntop AF_INET address)))
 119              (connect socket AF_INET (inet-pton AF_INET ip-address) port))))
 120         socket))
 121      (else
 122       (sleep 1)
 123       (irc:listen hostname #:port port #:sleep sleep)))))
 124
 125 (define (irc:receive socket)
 126   (string-trim-right (read-line socket) #\return))
 127
 128 (define (irc:send socket template . args)
 129   (let ((line (apply format #f template args)))
 130     (format socket "~a~a" line %irc:eol)))
 131
 132 \f
 133 ;;;
 134 ;;; Commands.
 135 ;;;
 136 (define (irc:action socket channel line)
 137   (let ((line (format #f "\\x01ACTION ~a\\x01" line)))
 138     (irc:send socket channel line)))
 139
 140 (define irc:emote irc:action)
 141
 142 (define (irc:join socket channel)
 143   (irc:send socket "JOIN ~a" channel))
 144
 145 (define (irc:names socket channel)
 146   (irc:send socket "NAMES ~a" channel))
 147
 148 (define (irc:nick socket nick)
 149   (irc:send socket "NICK ~a" nick))
 150
 151 (define (irc:notice socket channel line)
 152   (irc:send socket "NOTICE ~a :~a" channel line))
 153
 154 (define (irc:part socket channel)
 155   (irc:send socket "PART ~a" channel))
 156
 157 (define irc:leave irc:part)
 158
 159 (define* (irc:pong socket #:optional pong)
 160   (irc:send socket "PONG ~a" pong))
 161
 162 (define (irc:privmsg socket channel line)
 163   (irc:send socket "PRIVMSG ~a :~a" channel line))
 164
 165 (define* (irc:quit socket #:optional message)
 166   (let ((message (if message (format #f " :~a" message)
 167                      "")))
 168     (irc:send socket "QUIT~a" message)
 169     (close socket)))
 170
 171 (define* (irc:user socket user #:key (host "*") (real user) (server "*"))
 172   (irc:send socket "USER ~a ~a ~a :~a" user host server real))
 173
 174 \f
 175 ;;;
 176 ;;; Send message.
 177 ;;;
 178 (define* (irc:send-line socket channel line #:key emote?)
 179   (let ((send (if emote? irc:emote
 180                   irc:privmsg)))
 181     (irc:privmsg socket channel line)))
 182
 183 (define* (irc:send-message socket channel message #:key emote?)
 184   (let ((lines (string-split message #\newline)))
 185     (for-each (cut irc:send-line socket channel <> #:emote? emote?) lines)))
 186
 187 \f
 188 ;;;
 189 ;;; Parse message.
 190 ;;;
 191 (define-immutable-record-type <irc:message>
 192   (make-irc:message line command prefix params
 193                     speaker channel message emote? private?)
 194   irc:message?
 195   (line     irc:message-line)
 196   (command  irc:message-command)
 197   (prefix   irc:message-prefix)
 198   (params   irc:message-params)
 199   (channel  irc:message-channel)
 200   (speaker  irc:message-speaker)
 201   (message  irc:message-message)
 202   (emote?   irc:message-emote?)
 203   (private? irc:message-private?))
 204
 205 (define (irc:parse-params params)
 206   (let* ((params (string-trim-both params))
 207          (m (string-match ":(.+)" params)))
 208     (match (match:positions m)
 209       (((start . _) . _)
 210        (let* ((message (substring params (1+ start) (string-length params)))
 211               (m (string-match %irc:action-regexp message))
 212               (param (match (match:substrings m)
 213                        ((_ action message) `(,(string->symbol action) ,message))
 214                        (_ message))))
 215          (append (irc:parse-params (substring params 0 start)) (list param))))
 216       (_ (string-split params #\space)))))
 217
 218 (define (irc:prefix->host+user+nick prefix)
 219   "Parse PREFIX and return three values, NICK, USER, and HOST."
 220   (match prefix
 221     ((? string?)
 222      (let ((m (string-match %irc:prefix-regexp prefix)))
 223        (if (not m) (values prefix #f #f)
 224            (match (match:substrings m)
 225              ((_ nick host user)
 226               (values host user nick))))))
 227     (_ (values prefix #f #f))))
 228
 229 (define (irc:prefix->nick prefix)
 230   "Parse PREFIX and return NICK."
 231   (let ((host user nick (irc:prefix->host+user+nick prefix)))
 232     nick))
 233
 234 (define (irc:parse line)
 235   "Parse LINE and return four values: LINE, COMMAND, PREFIX, and PARAMS."
 236   (let ((m (string-match %irc:line-regexp line)))
 237     (match (match:substrings m)
 238       ((_ prefix command params)
 239        (let* ((code (and=> command string->number))
 240               (command (or code (and=> command string->symbol)))
 241               (prefix (and=> prefix (cute substring <> 1)))
 242               (params (irc:parse-params params)))
 243          (values line command prefix params)))
 244       ((prefix command)
 245        (let ((nick (irc:prefix->nick prefix)))
 246          (values line command prefix '())))
 247       (_ (values line #f #f '())))))
 248
 249 (define (irc:params->channel+message+emote? params)
 250   "Parse PARAMS and return three values, CHANNEL, MESSAGE, and EMOTE?"
 251   (match params
 252     ((channel (and (? string?) words) ...)
 253      (let ((message (string-join words)))
 254        (values channel message #f)))
 255     ((channel ('ACTION (and words (? string?))) ...)
 256      (let ((message (string-join words)))
 257        (values channel message #t)))
 258     (_ (values #f #f #f))))
 259
 260 (define (irc:line->message line)
 261   "Parse LINE and return an <irc:message>."
 262   (call-with-values (cute irc:parse line)
 263     (lambda (line command prefix params)
 264       (let* ((host user nick (irc:prefix->host+user+nick prefix))
 265              (channel message emote?
 266                       (irc:params->channel+message+emote? params))
 267              (private? (and (string? channel)
 268                             (not (string-prefix? "#" channel)))))
 269         (make-irc:message line command prefix params
 270                           nick channel message emote? private?)))))