#lang racket/base
(require (for-syntax racket/provide) racket/provide
         racket/string racket/format racket/list
         racket/function racket/promise racket/exn
         racket/tcp openssl
         (only-in srfi/13 string-index string-index-right))
(provide current-connection current-message current-hook-fail-handler
         connect hook-add hook-process hook-abort
         msg send listen
         connection-storage set-connection-storage!
         (matching-identifiers-out #rx"^log-irc-" (all-defined-out))
         (matching-identifiers-out #rx"^message-" (all-defined-out)))

(define-logger irc)

(define current-connection (make-parameter #f))
(define current-message (make-parameter #f))

(define current-hook-fail-handler
  (make-parameter (λ (x) (log-irc-error (exn->string x)))))

(struct connection
  (input output hooks output-lock storage)
  #:mutable)

(struct message
  (tags prefix command args suffix)
  #:methods gen:custom-write
  [(define (write-proc msg port mode)
     (msg-print-raw msg port))])

(define (connect host port #:ssl (ssl #f))
  (define-values (i o) ((if ssl ssl-connect tcp-connect) host port))
  (connection i o '() (make-semaphore 1) #f))

(define (hook-add conn fn)
  (set-connection-hooks! conn (cons fn (connection-hooks conn))))

(define hook-abort (string->uninterned-symbol "abort"))
(define (hook-process msg)
  (define conn (current-connection))
  ; TODO add synchronisation
  (with-handlers ([exn:fail? (current-hook-fail-handler)])
    (parameterize ([current-message msg])
      (set-connection-hooks! conn
        (filter-not (λ (h) (eq? (h) hook-abort))
                    (connection-hooks conn))))))

(define (msg-print-raw msg out)
  (define (clean s)
    (string-replace s #rx"[\r\n]" ""))

  (let ([tags (force (message-tags msg))]
        [prefix (message-prefix msg)]
        [cmd (message-command msg)]
        [args (message-args msg)]
        [suff (message-suffix msg)])
    (when (pair? tags)
      (fprintf out "@~A "
        (string-join
          (map (λ (t) (string-append (car t) "=" (cdr t))) tags)
          ";")))

    (when prefix (fprintf out ":~A " (clean prefix)))
    (fprintf out "~A" (clean (symbol->string cmd)))
    (when (pair? args)
      (fprintf out " ~A" (string-join (map clean args))))
    (when suff (fprintf out " :~A" (clean suff)))))

(define (msg-parse src)
  (define (parse-tags tags)
    (define (parse-tag tag)
      (let ((eq-index (string-index tag #\=)))
        (if eq-index
          (list* (substring tag 0 eq-index) (substring tag (add1 eq-index)))
          (list* tag '()))))
    (map parse-tag (string-split (substring tags 1) ";")))

  (define-values (tags prefix command args suffix) (values #f #f #f '() #f))
  (define len (string-length src))

  (do ([left 0 (add1 right)]
       [right 0]
       [curr #f])
      ((= right len))
    (set! right (or (string-index src #\space left len) len))
    (set! curr (string-ref src left))

    (cond [(char=? #\@ curr)
           (set! tags (delay (parse-tags (substring src left right))))]
          [(char=? #\: curr)
           (if (or prefix command)
             (begin (set! suffix (substring src (min len (add1 left)) len))
                    (set! right len))
             (set! prefix (substring src (add1 left) right)))]
          [(not command) (set! command (substring src left right))]
          [else (set! args (cons (substring src left right) args))]))

  (message tags prefix (string->symbol command) (reverse args) suffix))

(define (message-params msg) (append (message-args msg) (list (message-suffix msg))))

(define (message-prefix-nick msg)
  (let* ([prefix (message-prefix msg)]
         [bang (string-index prefix #\!)])
    (substring prefix 0 bang)))

(define (message-prefix-user msg)
  (let* ((prefix (message-prefix msg))
         (bang (string-index prefix #\!))
         (at (string-index-right prefix #\@)))
    (substring prefix bang at)))

(define (message-prefix-host msg)
  (let* ((prefix (message-prefix msg))
         (at (string-index-right prefix #\@)))
    (substring prefix at)))

(define (msg cmd args suffix #:tags (tags #f) #:prefix (prefix #f))
  (message tags prefix cmd args suffix))

(define (send msg #:conn [conn (current-connection)])
  (define formatted (~a msg))
  (define capped (substring formatted 0 (min 510 (string-length formatted))))
  (call-with-semaphore
    (connection-output-lock conn)
    (thunk (log-irc-info "» ~a" capped)
           (define out (connection-output conn))
           (display capped out)
           (display "\r\n" out)
           (flush-output out))))

(define (listen)
  (let ([input (connection-input (current-connection))])
    (let loop ()
      (let* ([l (read-line input 'any)]
             [msg (msg-parse l)])
        (when (not (string=? (~a msg) l))
          (log-irc-warning "Message roundtrip lossy:\nActual: ~a\nParsed: ~a" l msg))
        (log-irc-info "« ~a" l)
        (thread (thunk (hook-process msg))))
      (loop))))