;;; Snuik --- An IRC bot using guile-8sync
;;; Copyright © 2023 Janneke Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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 <http://www.gnu.org/licenses/>.
;;;
;;; 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

            <irc:message>
            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 <irc:message>
  (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 <irc:message>."
  (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?)))))