path: root/8sync/systems/irc.scm

;;; 8sync --- Asynchronous programming for Guile
;;; Copyright © 2015, 2016, 2017 Christopher Allan Webber <cwebber@dustycloud.org>
;;; Copyright © 2023 Janneke Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of 8sync.
;;;
;;; 8sync is free software: you can redistribute it and/or modify it
;;; under the terms of the GNU Lesser General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; 8sync 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 Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with 8sync.  If not, see <http://www.gnu.org/licenses/>.

(define-module (8sync systems irc)
  #:use-module (8sync repl)
  #:use-module (8sync agenda)
  #:use-module (8sync actors)
  #:use-module (8sync contrib irc)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 getopt-long)
  #:use-module (ice-9 format)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 q)
  #:use-module (ice-9 match)
  #:use-module (oop goops)
  #:export (<irc-bot>
            irc-bot-username irc-bot-server irc-bot-channels irc-bot-port

            irc-bot-init irc-bot-cleanup
            dispatch-message handle-message

            default-irc-port                ;REMOVEME compat
            irc-bot-send-line               ;REMOVEME compat
            handle-line handle-misc-input)) ;REMOVEME compat

;;; A goofy default handler.
(define* (echo-message irc-bot speaker channel-name
                       line-text emote? #:key (port (current-output-port)))
  "Simply echoes the message to the PORT."
  (if emote?
      (format port "~a emoted ~s in channel ~a\n"
              speaker line-text channel-name)
      (format port "~a said ~s in channel ~a\n"
              speaker line-text channel-name)))


;;; Bot
;;; ===

(define-class <irc-bot> (<actor>)
  (username #:init-keyword #:username
            #:getter irc-bot-username)
  (realname #:init-keyword #:realname
            #:init-value #f)
  (server #:init-keyword #:server
          #:getter irc-bot-server)
  (channels #:init-keyword #:channels
            #:getter irc-bot-channels)
  (port #:init-keyword #:port
        #:init-value %irc:default-port
        #:getter irc-bot-port)
  (socket #:accessor irc-bot-socket)
  (actions #:allocation #:each-subclass
           #:init-thunk (build-actions
                         (*init* irc-bot-init)
                         (*cleanup* irc-bot-cleanup)
                         (main-loop irc-bot-main-loop)
                         (dispatch-message dispatch-message)
                         (handle-line handle-line) ;REMOVEME compat
                         (send-line irc-bot-send-line-action))))

(define (irc-bot-realname irc-bot)
  (or (slot-ref irc-bot 'realname)
      (irc-bot-username irc-bot)))

(define-method (irc-bot-init (irc-bot <irc-bot>) message)
  "Initialize the IRC bot"
  (define socket (irc:listen (irc-bot-server irc-bot)
                             #:port (irc-bot-port irc-bot)
                             #:sleep 8sleep))
  (define flags (fcntl socket F_GETFL))

  (fcntl socket F_SETFL (logior O_NONBLOCK flags))
  (set! (irc-bot-socket irc-bot) socket)

  (irc:user socket (irc-bot-username irc-bot)
            #:real (irc-bot-realname irc-bot))
  (irc:nick socket (irc-bot-username irc-bot))

  (for-each (cute irc:join socket <>) (irc-bot-channels irc-bot))

  (<- (actor-id irc-bot) 'main-loop))

(define-method (irc-bot-cleanup (irc-bot <irc-bot>) message)
  (close (irc-bot-socket irc-bot)))

(define (irc-bot-main-loop irc-bot message)
  (define socket (irc-bot-socket irc-bot))
  (define line (irc:receive socket))
  (define message (or (false-if-exception (irc:line->message line))
                      line))
  (<- (actor-id irc-bot) 'dispatch-message message)
  (cond
   ;; The port's been closed for some reason, so stop looping
   ((port-closed? socket)
    'done)
   ;; We've reached the EOF object, which means we should close
   ;; the port ourselves and stop looping
   ((eof-object? (peek-char socket))
    (close socket)
    'done)
   ;; ;; Looks like we've been killed somehow... well, stop running
   ;; ;; then!
   ;; ((actor-am-i-dead? irc-bot)
   ;;  (if (not (port-closed? socket))
   ;;      (close socket))
   ;;  'done)
   ;; Otherwise, let's read till the next line!
   (else
    (<- (actor-id irc-bot) 'main-loop))))

(define* (irc-bot-send-line-action irc-bot message
                                   channel line #:key emote?)
  "Action handler for sending lines.  Real behavior happens in
irc:send-line."
  (define socket (irc-bot-socket irc-bot))
  (irc:send-line socket channel line #:emote? emote?))


;;;
;;; Likely-to-be-overridden generic methods
;;;
(define-method (dispatch-message (irc-bot <irc-bot>) 8sync-message message)
  "Dispatch an <irc:message>."
  (match message
    ((and ($ <irc:message>)
          (= irc:message-command 'PING)
          (= irc:message-message message))
     (irc:pong (irc-bot-socket irc-bot) message))
    (_ (handle-message irc-bot message))))

(define-method (handle-message (irc-bot <irc-bot>) message)
  (match message
    ((and ($ <irc:message>)
          (= irc:message-line line)
          (= irc:message-command command)
          (= irc:message-speaker speaker)
          (= irc:message-channel channel)
          (= irc:message-message message)
          (= irc:message-emote? emote?))
     (or
      (case command
        ((PRIVMSG)
         (handle-line irc-bot #f speaker channel message emote?)) ;REMOVEME compat
        (else
         (handle-misc-input irc-bot line))) ;REMOVEME compat
      (echo-message irc-bot speaker channel message #f
                    #:port (current-error-port))))))


;;;
;;; Compatibility with 0.4.2.
;;;
(define default-irc-port %irc:default-port)
(define irc-eol %irc:eol)

(define* (irc-bot-send-line irc-bot channel line #:key emote?)
  (define socket (irc-bot-socket irc-bot))
  (irc:send-line socket channel line))

(define-method (handle-line (irc-bot <irc-bot>) ;REMOVEME compat
                            8sync-message
                            username channel-name line-text emote?)
  "Keep compatibility with previous release."
  #f)

(define-method (handle-misc-input (irc-bot <irc-bot>) ;REMOVEME compat
                                  (line <string>))
  "Keep compatibility with previous release."
  #f)

(define (startswith-colon? str)
  (and (> (string-length str) 0)
       (eq? (string-ref str 0)
            #\:)))

;; TODO: This needs a cleanup.  Maybe even just using a regex is fine.
(define (parse-line line)               ;REMOVEME compat
  (define (parse-params pre-params)
    ;; This is stupid and imperative but I can't wrap my brain around
    ;; the right way to do it in a functional way :\
    (let ((param-list '())
          (currently-building '()))
      (for-each
       (lambda (param-item)
         (cond
          ((startswith-colon? param-item)
           (if (not (eq? currently-building '()))
               (set! param-list
                     (cons
                      (reverse currently-building)
                      param-list)))
           (set! currently-building (list param-item)))
          (else
           (set! currently-building (cons param-item currently-building)))))
       pre-params)
      ;; We're still building something, so tack that on there
      (if (not (eq? currently-building '()))
          (set! param-list
                (cons (reverse currently-building) param-list)))
      ;; return the reverse of the param list
      (reverse param-list)))

  (match (string-split line #\space)
    (((? startswith-colon? prefix)
      command
      pre-params ...)
     (values prefix command
             (parse-params pre-params)))
    ((command pre-params ...)
     (values #f command
             (parse-params pre-params)))))

(define (strip-colon-if-necessary string) ;REMOVME compat
  (if (and (> (string-length string) 0)
           (string-ref string 0))
      (substring/copy string 1)
      string))

;; @@: Not sure if this works in all cases, like what about in a non-privmsg one?
(define (irc-line-username irc-line-prefix) ;REMOVME compat
  (let* ((prefix-name (strip-colon-if-necessary irc-line-prefix))
         (exclaim-index (string-index prefix-name #\!)))
    (if exclaim-index
        (substring/copy prefix-name 0 exclaim-index)
        prefix-name)))

(define (condense-privmsg-line line)    ;REMOVME compat
  "Condense message line and do multiple value return of
  (channel message emote?)"
  (define (strip-last-char string)
    (substring/copy string 0 (- (string-length string) 1)))
  (let* ((channel-name (caar line))
         (rest-params (apply append (cdr line))))
    (match rest-params
      (((or "\x01ACTION" ":\x01ACTION") middle-words ... (= strip-last-char last-word))
       (values channel-name
               (string-join
                (append middle-words (list last-word))
                " ")
               #t))
      (((= strip-colon-if-necessary first-word) rest-message ...)
       (values channel-name
               (string-join (cons first-word rest-message) " ")
               #f)))))