movie-night-chat/private/irc-functions.rkt

#lang typed/racket
;; A bunch of code in this file was copied from the irc package
;; (c) Jonathan Schuster
(provide (all-defined-out))
(require "ws-typed.rkt")

;; TODO: just use a hash table
(define-type Channel-List (Listof (Pairof String WS)))

;; :prefix command params crlf
(struct irc-message ([prefix : (U False String)]
                     ;; XXX: just Positive-Integer?
                     [command : (U Positive-Integer String)]
                     [params : (Listof String)])
  #:transparent)
(struct irc-connection ([in : Input-Port]
                        [out : Output-Port]
                        [nick : String]
                        [user : String]
                        [custodian : Custodian]
                        [channels : Channel-List])
  #:mutable)

(: send-to-client (-> irc-connection irc-message Void))
(define (send-to-client conn message)
  ;; TODO: flush?
  (match message
    [(irc-message prefix command params)
     (if prefix
         (fprintf (irc-connection-out conn)
                  ":~a ~a ~a\r\n"
                  prefix
                  command
                  (string-join params))
         (fprintf (irc-connection-out conn)
                  "~a ~a\r\n"
                  command
                  (string-join params)))]))

;; blocking read & parse
;; returns eof if there is no more data on the irc socket,
;; returns #f if the message cannot be parsed
(: read-from-input-port (-> Input-Port (U irc-message False EOF)))
(define (read-from-input-port in)
  (if (port-closed? in)
      eof
      ;; 'any ==> break line on etieher return, linefeed, or return-linefeed combo
      (let ([line (read-line in 'any)])
        ;; (log-info (format "Raw line: ~s" line))
        (if (string? line)
            (parse-message line)
            eof))))

(: read-from-client (->* (irc-connection)
                         (#:timeout (U False Nonnegative-Real))
                         (U irc-message False EOF)))
(define (read-from-client conn #:timeout [timeout #f])
  (define in-port (irc-connection-in conn))
  (: rl-evt (Evtof (U EOF String)))
  (define rl-evt (read-line-evt in-port 'any))
  (: line (U False EOF String))
  (define line (if timeout
                   (sync/timeout timeout rl-evt)
                   (sync rl-evt)))
  (if (string? line)
      (parse-message line)
      ;; if the timeout was triggered
      eof   ;; return eof so that the caller closes teh connection
      ))


;; Given the string of an IRC message, returns an irc-message that has been parsed as far as possible,
;; or #f if the input was unparsable
(: parse-message (-> String (U irc-message False)))
(define (parse-message message)
  (define parts (string-split (string-trim message) " " #:trim? #f))
  (define prefix (if (and (pair? parts)
                          (string-starts-with? (list-ref parts 0) ":"))
                     (substring (list-ref parts 0) 1)
                     #f))
  (cond [(> (length parts) (if prefix 1 0))
         (define command (list-ref parts (if prefix 1 0)))
         (define param-parts (list-tail parts (if prefix 2 1)))
         (irc-message prefix (string-upcase command) (parse-params param-parts))]
        [(empty? parts) #f ;; the message is entirely empty
                        ;; don't log this as a warning
                        ;; this happens on erc because it ends messages
                        ;; with a linefeed-return combination instead
                        ;; of the usual return-linefeed 
                        ]
        [else (begin (log-warning (format "Couldn't parse ~a" message))
                     #f)]))

;; Given the list of param parts, return the list of params
(: parse-params (-> (Listof String) (Listof String)))
(define (parse-params parts)
  (define first-tail-part (find-first-tail-part parts))
  (cond [first-tail-part
         (define tail-with-colon (string-join (list-tail parts first-tail-part)))
         (define tail-param (if (string-starts-with? tail-with-colon ":")
                                (substring tail-with-colon 1)
                                tail-with-colon))
         (append (take parts first-tail-part)
                 (list tail-param))]
        [else parts]))

;; Return the index of the first part that starts the tail parameters; of #f if no tail exists
(: find-first-tail-part (-> (Listof String) (U Integer False)))
(define (find-first-tail-part param-parts)
  (define first-colon-index (memf/index (lambda ([v : String]) (string-starts-with? v ":"))
                                        param-parts))
  (cond [(or first-colon-index (> (length param-parts) 14))
         (min 14 (if first-colon-index first-colon-index 14))]
        [else #f]))

;; Like memf, but returns the index of the first item to satisfy proc instead of
;; the list starting at that item.
(: memf/index (All (a) (-> (-> a Boolean) (Listof a) (U Integer False))))
(define (memf/index proc lst)
  (define memf-result (memf proc lst))
  (cond [memf-result (- (length lst) (length memf-result))]
        [else #f]))

(: string-starts-with? (-> String String Boolean))
(define (string-starts-with? s1 s2)
  (define s1-prefix (if (= 0 (string-length s1)) "" (substring s1 0 (string-length s2))))
  (equal? s1-prefix s2))


(define RPL_TOPIC 332)
(define RPL_NAMEREPLY 353)
(define RPL_ENDOFNAMES 366)
(define RPL_CHANNELMODEIS 324)
(define RPL_WHOREPLY 352)
(define RPL_ENDOFWHO 315)
(define RPL_WHOISUSER 311)
;;  "<nick> <user> <host> * :<real name>"
(define RPL_WHOISSERVER 312)
;;  "<nick> <server> :<server info>"
(define RPL_ENDOFWHOIS 318)
;;  "<nick> :End of /WHOIS list"
(define ERR_NOSUCHNICK 401)
;;  "<nickname> :No such nick/channel"
(define RPL_MOTDSTART 375)
(define RPL_MOTD 372)
(define RPL_ENDOFMOTD 376)


;; channel-list related functions

(: lookup-ws-conn (-> Channel-List String (U WS False)))
(define (lookup-ws-conn ls x)
  (define v (assoc x ls))
  (and v (cdr v)))

(: channel-joined? (-> String Channel-List Boolean))
(define (channel-joined? x channels)
  (if (assoc x channels) #t #f))

(: remove-channel (-> String Channel-List Channel-List))
(define (remove-channel chan channels)
  (remove* (filter
            (lambda ([p : (Pairof String WS)]) (equal? (car p) chan))
            channels)
           channels))

(: add-channel (-> String WS Channel-List Channel-List))
(define (add-channel chan ws channels)
  (cons (cons chan ws) channels))