(use-modules (srfi srfi-1)) ; lists
(use-modules (srfi srfi-13)) ; strings
(use-modules (ice-9 regex)) ; regular expressions

;; Helpers

(define (tagged? obj tag)
  (and (pair? obj) (eq? (car obj) tag)))

(define (assq-lookup tag alist)
  (let ((record (assq tag alist)))
    (and record (cadr record))))

(define (symbol-append s1 s2)
  (string->symbol (string-append (symbol->string s1) (symbol->string s2))))

(define (report . args)
  (display (car args))
  (for-each (lambda (a) (display " ") (write a)) (cdr args))
  (newline))

(define *debug-level* 5)

(define (debug-print level . args)
  (if (<= level *debug-level*) (apply report args)))

(define (option->list option) (if option (list option) '()))

;; hash tables

(define (make-btree) (make-hash-table 641))
(define btree-get hash-ref)
(define btree-set! hash-set!)
(define (btree-sum h)
  (hash-fold (lambda (key val acc) (+ val acc)) 0 h))

;; timers

(define *timers* '())

(define (add-timer time thunk)
  (debug-print 6 "Set timer:" time)
  (sigaction SIGALRM check-timers)
  (set! *timers* (cons (list (+ (current-time) time) thunk) *timers*))
  (set-alarm))

(define (check-timers arg)
  (let* ((time (current-time))
	 (active-timers (filter (lambda (timer) (<= (car timer) time))
				*timers*)))
    (for-each (lambda (timer)
		(debug-print 6 "Run timer:" (car timer))
		(catch #t (cadr timer)
		       (lambda (key . args)
			 (if (eq? key 'toplevel) (throw 'toplevel)
			   (debug-print 3 "Timer error:" key args)))))
	      active-timers)
    (set! *timers* (lset-difference eq? *timers* active-timers))
    (set-alarm)))

(define (set-alarm)
  (if (not (null? *timers*))
    (alarm (max 1 (- (apply min (map car *timers*)) (current-time))))))

;; pinging

(define *ping-interval* 600)
(define *last-receive* #f)

(define (ping-and-check)
  (irc-write '(message ping "testing connection"))
  (add-timer 20 (lambda ()
		  (if (and *last-receive*
			   (< *ping-interval*
			      (- (current-time) *last-receive*)))
		    (close-port *irc-connection*))))
  (add-timer *ping-interval* ping-and-check))

;; hook handling

(define *irc-hooks* (make-btree))

(define (get-hooks type) (btree-get *irc-hooks* type '()))

(define (add-hook type name hook)
  (btree-set! *irc-hooks* type (cons (cons name hook) (get-hooks type))))

(define (run-hook hook args)
  (debug-print 6 "Run hook:" (car hook))
  (catch #t (lambda () (apply (cdr hook) args))
	 (lambda (key . args)
	   (if (eq? key 'toplevel) (throw 'toplevel)
	     (debug-print 3 "Hook error:" key args)))))

(define (run-hooks type args)
  (debug-print 6 "Run hooks:" type args)
  (for-each (lambda (hook) (run-hook hook args))
	    (get-hooks type)))

;; admin commands

(define *admins* '())

(define (irc-user=? addr user)
  (and (tagged? addr 'user)
       (string= (irc-address-username addr) (irc-address-username user))
       (string= (irc-address-hostname addr) (irc-address-hostname user))))

(define (is-admin? source)
  (any (lambda (admin) (irc-user=? source admin)) *admins*))

(define (add-admin user) (set! *admins* (cons user *admins*)))

(define command-regexp (make-regexp "^!([a-z]*) ?(.*)$"))
(define (process-admin-command source dest text)
  (define ms match:substring)
  (let ((match (regexp-exec command-regexp text)))
    (and match
	 (if (is-admin? source)
	   (run-hooks 'command
		      (list source dest (string->symbol (ms match 1))
			    (ms match 2)))
	   (debug-print 4 "Admin command from nonadmin:" source)))))

(define (add-admin-command command handler)
  (add-hook 'command (symbol-append 'is-it- command)
	    (lambda (source dest cmd params)
	      (if (eq? command cmd) (handler source dest params)))))

;; ctcp commands

(define ctcp-delim (string (integer->char 1)))
(define ctcp-regexp
  (make-regexp (string-append "^" ctcp-delim
			      "([^ ]*) *([^" ctcp-delim "]*)" ctcp-delim)))
(define (process-ctcp-request source dest text)
  (define ms match:substring)
  (let ((match (regexp-exec ctcp-regexp text)))
    (and match (run-hooks 'ctcp (list source dest (string->symbol (ms match 1))
				      (ms match 2))))))

(define (add-ctcp-request request handler)
  (add-hook 'ctcp (symbol-append 'is-it- request)
	    (lambda (source dest req params)
	      (if (eq? request req) (handler source dest params)))))

(define (ctcp-send dest text)
  (irc-write `(message notice ,dest
		       ,(string-append ctcp-delim text ctcp-delim))))

;; channels

(define *my-channels* '())

(define (rejoin-channels)
  (for-each irc-join *my-channels*))

(define (irc-join channel)
  (if (not (member channel *my-channels*))
    (set! *my-channels* (cons channel *my-channels*)))
  (irc-write `(message join ,channel)))

;; chat shorthands

(define (irc-say dest text) (irc-write `(message privmsg ,dest ,text)))

(define (irc-reply source dest text)
  (irc-say (if (eq? (irc-nick dest) *irc-my-nick*) source dest) text))

;; Generic network-related stuff

(define (host->address host)
  (car (hostent:addr-list (gethost host))))

(define (open-connection host port)
  (let ((s (socket PF_INET SOCK_STREAM 0)))
    (connect s AF_INET (host->address host) port)
    s))

;; IRC connection handling

(define *irc-connection* #f)
(define *irc-my-nick* #f)

(define (open-irc-connection host port nick username)
  (set! *irc-my-nick* nick)
  (set! *irc-connection* (open-connection host port))
  (irc-write `(message nick ,nick))
  (irc-write `(message user ,nick 0 * ,username))
  (run-hooks 'reconnect (list host port nick username)))

(define (irc-write message)
  (debug-print 5 "Sent:" message)
  (if (not *irc-connection*)
    (debug-print 4 "irc-write called before opening connection")
    (let ((m (message->string message)))
      (if (>= (string-length m) 509)
	(let ((truncated (substring m 0 509)))
	  (debug-print 4 "Message truncated:" truncated)
	  (display truncated *irc-connection*))
	(display m *irc-connection*))
      (display "\r\n" *irc-connection*)
      (force-output *irc-connection*))))

(define (irc-loop)
  (let ((input (read-line *irc-connection*)))
    (if (not (eof-object? input))
      (let ((message (string->message input)))
	(set! *last-receive* (current-time))
	(debug-print 5 "Got:" message)
	(run-hooks (message-command message)
		   (cons (message-source message) (message-params message)))
	(irc-loop)))))

(define (irc-reconnect-loop host port nick username)
  (catch #t (lambda ()
	      (open-irc-connection host port nick username)
	      (irc-loop))
	 (lambda (key . args)
	   (if (eq? key 'toplevel) (throw 'toplevel)
	     (debug-print 2 "Bot error:" key args))
	   (sleep 10)))
  (irc-reconnect-loop host port nick username))

(define (standard-hooks)
  (add-hook 'ping 'reply-to-ping
	    (lambda (source . args) (irc-write `(message pong ,@args))))
  (add-hook 'invite 'join-when-invited
	    (lambda (source me chan) (irc-write `(message join ,chan))))
  (add-hook 'privmsg 'process-admin-command process-admin-command)
  (add-hook 'privmsg 'process-ctcp-request process-ctcp-request)
  (add-hook 'reconnect 'rejoin-channels (lambda args (rejoin-channels)))
  (add-timer *ping-interval* ping-and-check)
  (add-admin-command
    'eval (lambda (source dest params)
	    (irc-reply source dest (format #f "~s" (eval-string params)))))
  (add-ctcp-request
    'ACTION (lambda (source dest params)
	      (run-hooks 'action (list source dest params))))
  (add-ctcp-request
    'VERSION (lambda (source dest params)
	       (ctcp-send source "VERSION ircbot.ss:0.3:guile 1.6")))
  (add-ctcp-request
    'PING (lambda (source dest params) (ctcp-send source params))))

;; IRC address conversion

(define (irc-address? obj)
  (and (pair? obj)
       (memq (car obj) '(user channel server multi-addr other))
       #t))

(define (irc-address->string addr)
    (cond ((tagged? addr 'channel)
	   (string-append (string (assq-lookup 'chantype (cddr addr)))
			  (symbol->string (cadr addr))))
	  ((tagged? addr 'multi-addr)
	   (string-join (map irc-address->string (cdr addr)) ","))
	  ((tagged? addr 'user) (symbol->string (cadr addr)))
	  (else (cadr addr))))

(define string->irc-address
  (let ((user-regexp (make-regexp "^([^,.!#+!&][^,.!]*)((!([-~=+^]?)([^,@]*))?@([^,]*))?$"))
	(channel-regexp (make-regexp "^([#+!&])([^,]*)$"))
	(server-regexp (make-regexp "^[-a-zA-Z0-9]+([.][-a-zA-Z0-9]+)+$")))
    (define ms match:substring)
    (lambda (str)
      (cond ((regexp-exec user-regexp str)
	     => (lambda (match)
		  (if (ms match 2)
		    `(user ,(string->symbol (ms match 1))
			   (usermode ,(ms match 4))
			   (username ,(ms match 5))
			   (hostname ,(ms match 6)))
		    `(user ,(string->symbol (ms match 1))))))
	    ((regexp-exec channel-regexp str)
	     => (lambda (match)
		  `(channel ,(string->symbol (ms match 2))
			    (chantype ,(string-ref (ms match 1) 0)))))
	    ((regexp-exec server-regexp str) `(server ,str))
	    (else (debug-print 4 "Unparseable irc address:" str)
		  `(other ,str))))))

(define (irc-channel-name addr)
  (cond ((tagged? addr 'channel) (cadr addr))
	((string? addr) (irc-channel-name (string->irc-address addr)))
	((symbol? addr) (irc-channel-name (symbol->string addr)))
	(else #f)))

(define (irc-nick addr-or-nick)
  (cond ((tagged? addr-or-nick 'user) (cadr addr-or-nick))
	((symbol? addr-or-nick) addr-or-nick)
	(else #f)))

(define (irc-address-hostname addr)
  (cond ((tagged? addr 'server) (cadr addr))
	((tagged? addr 'user) (assq-lookup 'hostname (cddr addr)))
	(else #f)))

(define (irc-address-username addr)
  (and (tagged? addr 'user) (assq-lookup 'username (cddr addr))))

;; IRC messages

(define (message? obj) (tagged? obj 'message))

(define (message-part->string part)
  (cond ((symbol? part) (symbol->string part))
	((string? part) (string-append ":" part))
	((number? part) (number->string part))
	((irc-address? part) (irc-address->string part))
	(else (debug-print 4 "Weird message part:" part))))

(define (message->string message)
  (if (message? message)
    (let ((command (cadr message))
	  (rest (cddr message)))
      (string-join (cons (string-upcase (symbol->string command))
			 (map message-part->string rest)) " "))
    (debug-print 4 "Bad message:" message)))

(define string->message
  (let ((message-regexp
	  (make-regexp "^(:([^ ]*) )?([A-Za-z]*|[0-9]{3})(( ([^: ][^ ]*))*)( :([^\r]*))?\r?\n?$")))
    (define ms match:substring)
    (lambda (str)
      (let ((match (regexp-exec message-regexp str)))
	(let ((source (ms match 2)) (command (ms match 3))
	      (params (ms match 4)) (trailing (ms match 8)))
	  (let ((source (and source (string->irc-address source)))
		(command (string->symbol (string-downcase command)))
		(params (map string->symbol (string-tokenize params))))
	    `(message ,@(option->list source) ,command ,@params
		      ,@(option->list trailing))))))))

(define (message-source message)
  (and (message? message)
       (irc-address? (cadr message))
       (cadr message)))

(define (message-command message)
  (and (message? message)
       (if (irc-address? (cadr message)) (caddr message) (cadr message))))

(define (message-params message)
  (and (message? message)
       (if (irc-address? (cadr message)) (cdddr message) (cddr message))))