;;;; irc.scm
;
; Copyright (c) 2000-2009, Felix L. Winkelmann
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer.
;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
;     disclaimer in the documentation and/or other materials provided with the distribution.
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.
;
; Send bugs, suggestions and ideas to:
;
; felix@call-with-current-continuation.org
;
; Felix L. Winkelmann
; Steinweg 1A
; 37130 Gleichen, OT Weissenborn
; Germany


(module irc (irc:connect
	     irc:quit irc:nick irc:say irc:join irc:part irc:command irc:listen irc:action
	     irc:connection-in irc:connection-out irc:connection-server irc:connection-nick
	     irc:connection-user irc:connection-real-name irc:connection-port irc:connection
	     irc:connection-log-traffic irc:connection-reconnect-timeout
	     irc:connected? irc:connection-password irc:connection? irc:connection-channels
	     irc:message-prefix irc:message-command irc:message-timestamp irc:message-code
	     irc:message-body irc:message-parameters irc:message-index irc:disconnect
	     irc:extended-data? irc:extended-data-tag irc:extended-data-content
	     irc:message? irc:run-message-loop irc:process-message
	     irc:add-message-handler! irc:remove-message-handler!
	     irc:message-sender irc:message-receiver irc:reconnect
	     irc:connection-raw-filter-set! irc:leave
	     irc:wait irc:notice)
  (import scheme chicken matchable)
  (use tcp extras srfi-1 regex data-structures posix)

(define-constant default-port 6667)
(define-constant default-user "nobody")
(define-constant default-server-reconnect-timeout 3600000) ; 1 hour

(define-record irc:connection
  index-count				; int
  password				; string | #f
  server				; string
  nick					; string
  user					; string
  real-name				; string
  port					; int
  reconnect-timeout			; ms
  log-traffic				; port | #f
  connected?				; bool
  handlers				; (handler | (tag handler) ...)
  channels				; (string ...)
  in					; port
  out					; port
  raw-filter				; procedure | #f
  reconnect?)

(define irc:connected? irc:connection-connected?)

(define (irc:connection #!key password server (nick (gensym)) (user default-user) (real-name user)
			(port default-port) 
			log-traffic reconnect-timeout reconnect)
  (make-irc:connection
   0
   password
   (or server (error "no server specified"))
   nick user real-name port reconnect-timeout log-traffic
   #f '() '() #f #f #f reconnect) )

(define (send con fstr . args)
  (let ((msg (apply sprintf fstr args)))
    (unless (irc:connection-connected? con)
      (error "not connected" con) )
    (fprintf (irc:connection-out con) "~A\r\n" msg) 
    (and-let* ((log (irc:connection-log-traffic con)))
      (fprintf log "~a > ~a~%~!" (seconds->string (current-seconds)) msg) ) ) )

(define (irc:connect #!optional con . args)
  (let ((con
	 (if (and con (irc:connection? con))
	     con
	     (apply irc:connection (cons con args) ) ) ) )
    (parameterize ((tcp-read-timeout (irc:connection-reconnect-timeout con)))
      (let-values ([(i o)
		    (tcp-connect (irc:connection-server con)
				 (irc:connection-port con) ) ] )
	(irc:connection-in-set! con i)
	(irc:connection-out-set! con o)
	(irc:connection-connected?-set! con #t)
	(and-let* ([pw (irc:connection-password con)])
	  (send con "PASS :~A" pw) )
	(send con "USER ~A 0 * :~A" (irc:connection-user con) (irc:connection-real-name con))
	(and-let* ([nick (irc:connection-nick con)])
	  (send con "NICK ~A" nick) )
	con) ) ) )

(define (irc:quit con . msg)
  (send con "QUIT~A" (if (pair? msg) (sprintf " :~A" (car msg)) ""))
  (close-output-port (irc:connection-out con))
  (close-input-port (irc:connection-in con))
  (irc:connection-connected?-set! con #f)
  (irc:connection-in-set! con #f)
  (irc:connection-out-set! con #f) )

(define (irc:disconnect con)
  (close-output-port (irc:connection-out con))
  (close-input-port (irc:connection-in con))
  (irc:connection-connected?-set! con #f)
  (irc:connection-in-set! con #f)
  (irc:connection-out-set! con #f) )

(define (irc:reconnect con)
  (irc:disconnect con)
  (irc:connect con)
  (for-each (cut irc:join con <>) (irc:connection-channels con)))

(define (irc:join con channel)
  (let ((channels (lset-adjoin string=? (irc:connection-channels con) channel)))
    (irc:connection-channels-set! con channels)
    (send con "JOIN ~A" channel) ) )

(define (irc:part con channel)
  (irc:connection-channels-set!
   con
   (delete channel (irc:connection-channels con) string=?))
  (send con "PART ~A" channel) )

(define irc:leave irc:part)

(define (irc:nick con nick)
  (send con "NICK ~A" nick)
  (irc:connection-nick-set! con nick) )

(define (irc:command con cmd)
  (send con cmd) )

(define (send-message con msg-format msg dests)
  (define (mess d ln)
    (send con msg-format d ln))
  (let ((dests 
	 (if (null? dests)
	     (irc:connection-channels con)
	     dests)))
    (for-each
     (lambda (ln)
       (for-each (cut mess <> ln) dests))
     (string-split
      (if (irc:extended-data? msg)
	  (ext->msg msg)
	  msg)
      "\n"))))

(define (irc:say con msg . dests)
  (send-message con "PRIVMSG ~A :~A" msg dests))

(define (irc:notice con msg . dests)
  (send-message con "NOTICE ~A :~A" msg dests))

(define (irc:listen con)
  (unless (irc:connection-connected? con)
    (error 'irc:listen "not connected" con) )
  (let ([p (irc:connection-in con)])
    (and (char-ready? p)
	 (parse-reply (read-input con) con) ) ) )

(define (read-input con)
  (let ((input (read-line (irc:connection-in con))))
    (and-let* ((log (irc:connection-log-traffic con)))
      (fprintf log "~a < ~a~%~!" (seconds->string (current-seconds)) input) )
    input))

(define-record irc:message
  code					; int | #f
  index					; int
  timestamp				; int
  body					; string
  prefix				; (string ...)
  command				; string | #f
  parameters)				; (string | extended-data ...)

(define-record irc:extended-data
  tag					; symbol
  content)				; string

(define (ext-data tag content)
  (sprintf "~A~A ~A~A" (integer->char 1) tag content (integer->char 1)) )

(define (ext->msg ext)
  (ext-data (irc:extended-data-tag ext) (irc:extended-data-content ext)) )

(define extended-rx
  (regexp (sprintf "~A(ACTION) (.+)~A" (integer->char 1) (integer->char 1))) )

(define (irc:error msg)
  (signal
   (make-composite-condition
    (make-property-condition 'exn 'message (irc:message-body msg))
    (make-property-condition 'irc 'code (irc:message-code msg) 'reply msg) ) ) )

(define (eof-error con)
  (signal
   (make-composite-condition
    (make-property-condition 'exn 'message "eof - IRC connection terminated")
    (make-property-condition 'irc/eof))))

(define-syntax rx
  (syntax-rules ()
    ((_ re) (force (delay (regexp re))))))

(define (parse-params s)
  (match (string-search-positions (rx ":(.+)") s)
    [((start _) . _)
     (let* ([s2 (substring s (add1 start) (string-length s))]
	    [px (match (string-match extended-rx s2)
		  [(_ tag s3) (make-irc:extended-data (string->symbol tag) s3)]
		  [_ s2] ) ] )
       (append (parse-params (substring s 0 start)) (list px)) ) ]
    [_ (string-split s)] ) )

(define (parse-reply s con)
  (when (eof-object? s)
    (eof-error con))
  (let ([cnt (irc:connection-index-count con)]
	[s ((or (irc:connection-raw-filter con) identity) s)] )
    (irc:connection-index-count-set! con (add1 cnt))
    (match (string-match (rx "(:[^ ]+ )?([A-Za-z0-9]+)(.*)") s)
      [(_ prefix command params)
       (let* ([prefix (if prefix
			  (string-split (substring prefix 1 (string-length prefix)) "!@ ")
			  '() ) ]
	      [params (parse-params params)]
	      [num (string->number command)]
	      [msg (make-irc:message
		    num cnt
		    (current-seconds)
		    s prefix command params) ] )
	 (if (and num (>= 400 num 599))
	     (irc:error msg)
	     msg) ) ]
      [_ (make-irc:message #f cnt (current-seconds) s '() #f '())] ) ) )

(define (irc:wait con)
  (unless (irc:connection-connected? con)
    (error "not connected" con) )
  (parse-reply
   (let loop ()
     (condition-case (read-input con)
       (ex (exn net timeout)
	   ;(print "\n*** timeout - reconnecting")
	   (cond ((irc:connection-reconnect? con)
		  (irc:reconnect con)
		  (loop))
		 (else (abort ex))))
       (ex (irc/eof)
	   ;(print "\n*** EOF - reconnecting")
	   (cond ((irc:connection-reconnect? con)
		  (irc:reconnect con)
		  (loop))
		 (else (abort ex))))))
   con))

(define (irc:action con msg . dest)
  (apply irc:say con (sprintf "~AACTION ~A~A" (integer->char 1) msg (integer->char 1)) dest) )

(define (irc:run-message-loop con #!key debug (pong #t) (filter identity))
  (when (and pong (not (find (lambda (h) (and (pair? h) (eq? 'ping (car h)))) (irc:connection-handlers con))))
    (irc:add-message-handler!
     con
     (lambda (msg)
       (irc:command con (string-append "PONG :" (car (irc:message-parameters msg)))) )
     tag: 'ping
     command: "PING") )
  (let loop ()
    (let ([msg (irc:wait con)])
      (irc:process-message con (filter msg) debug)
      (loop) ) ) )

(define (irc:process-message con msg #!optional verbose?)
  (let ([prefix (irc:message-prefix msg)]
	[command (irc:message-command msg)]
	[params (irc:message-parameters msg)] )
    (any
     (lambda (h) ((if (procedure? h) h (cdr h)) msg))
     (irc:connection-handlers con)) ) )

(define (irc:add-message-handler! con proc #!key command sender receiver body code tag)
  (let ([h (lambda (msg)
	     (let ([prefix (irc:message-prefix msg)]
		   [cmd (irc:message-command msg)]
		   [params (irc:message-parameters msg)] )
	       (and (or (not command)
			(and cmd
			     (if (procedure? command)
				 (command cmd)
				 (string-search command cmd))))
		    (or (not sender)
			(and (pair? prefix)
			     (if (procedure? sender)
				 (sender (car prefix))
				 (string-search sender (car prefix)))))
		    (or (not receiver)
			(and (pair? params)
			     (if (procedure? receiver)
				 (receiver (car params))
				 (string-search receiver (car params)))))
		    (or (not body)
			(if (procedure? body)
			    (body msg)
			    (string-search body (irc:message-body msg))))
		    (or (not code) (eq? code (irc:message-code msg)))
		    (proc msg) ) ) ) ] )
    (irc:connection-handlers-set!
     con
     (append
      (irc:connection-handlers con)
      (list (if tag (cons tag h) h)) ) ) ) )

(define (irc:remove-message-handler! con tag)
  (irc:connection-handlers-set!
   con
   (let loop ([hs (irc:connection-handlers con)])
     (cond [(null? hs) (error "undefined message handler" tag)]
	   [(and (pair? hs) (eq? tag (caar hs))) (cdr hs)]
	   [else (cons (car hs) (loop (cdr hs)))] ) ) ) )

(define (irc:message-receiver msg)
  (let ([params (irc:message-parameters msg)])
    (and (pair? params) (car params)) ) )

(define (irc:message-sender msg)
  (let ([prefix (irc:message-prefix msg)])
    (and (pair? prefix) (car prefix)) ) )

)