#lang racket/base
(require "core.rkt"
         (for-syntax racket/base racket/syntax)
         racket/string racket/function
         racket/stxparam
         racket/sandbox)
(provide (all-defined-out))

(define (replace-many s rep)
  (foldl (λ (rep acc) (apply string-replace acc rep)) s rep))

(define casemap-empty '())

(define casemap-uppercase-strict-rfc1459
  '(("{" "[") ("}" "]") ("|" "\\")))
(define casemap-lowercase-strict-rfc1459
  (map reverse casemap-uppercase-strict-rfc1459))

(define casemap-uppercase-relaxed-rfc1459
  (cons '("^" "~") casemap-uppercase-strict-rfc1459))
(define casemap-lowercase-relaxed-rfc1459
  (map reverse casemap-uppercase-relaxed-rfc1459))

(define (irc-downcase s [casemap casemap-lowercase-relaxed-rfc1459])
  (replace-many (string-downcase s) casemap))

(define (irc-upcase s [casemap casemap-uppercase-relaxed-rfc1459])
  (replace-many (string-upcase s) casemap))

(define current-nick (make-parameter #f))

(define (tags) (message-tags (current-message)))
(define (prefix) (message-prefix (current-message)))
(define (command) (message-command (current-message)))
(define (args) (message-args (current-message)))
(define (suffix) (message-suffix (current-message)))
(define (params) (message-params (current-message)))

(define (unaltered-source) (message-prefix-nick (current-message)))
(define (source) (irc-downcase (unaltered-source)))
(define (target) (car (params)))
(define (context)
  (let* ([t (target)]
         [is-channel (memv (string-ref t 0) '(#\# #\& #\+))])
    (if is-channel t (source))))

(define-syntax-parameter it
  (λ (stx) (raise-syntax-error 'it "Use of the \"it\" identifier is not allowed here" stx)))
(define-syntax (comparison-functions stx)
  (syntax-case stx ()
    [(_ name)
     (with-syntax ([name-is (format-id stx "~a-is" #'name)]
                 [name-match (format-id stx "~a-match" #'name)])
      #'(begin
          (define (name-is expected)
            (let ([actual (name)])
            (and actual (equal? actual expected))))
          (define-syntax-rule (name-match test)
            (let ([actual (name)])
              (and actual 
                (syntax-parameterize ([it (make-rename-transformer #'actual)])
                  test))))))]))

(comparison-functions tags)
(comparison-functions prefix)
(comparison-functions command)
(comparison-functions args)
(comparison-functions suffix)
(comparison-functions params)
(comparison-functions source)
(comparison-functions target)
(comparison-functions context)

(define (register [nick (current-nick)]
                  #:user [user nick] #:mode [mode "0"]
                  #:unused [unused "*"] #:realname [realname user]
                  #:pass [pass #f]
                  #:capabilities [caps '()])
  (for-each (λ (cap) (send (msg 'CAP '("REQ") cap))) caps)
  (when pass (send (msg 'PASS '() pass)))
  (send (msg 'USER (list user mode unused) realname))
  (send (msg 'NICK '() nick)))

(define (join . chans)
  (send (msg 'JOIN chans #f)))

(define (part chans [reason #f])
  (send (msg 'PART (list chans) reason)))

(define (quit reason)
  (send (msg 'QUIT '() reason)))

(define (privmsg to content)
  (send (msg 'PRIVMSG (list to) content)))

(define (notice to content)
  (send (msg 'NOTICE (list to) content)))

(define (reply content)
  (privmsg (context) content))

(define (reply-notice content)
  (notice (context) content))

(define-syntax-rule (on condition action ...)
  (hook-add (current-connection) (λ () (when condition action ...))))

(define-syntax-rule (on-once condition action ...)
  (on condition action ... hook-abort))

; does this belong here?
; limit to 5s, 25MB to prevent reading 2^30 element vectors
(define read-sandbox
  (parameterize ([sandbox-eval-limits '(5 25)])
    (make-evaluator 'racket/base)))

(define (safe-read-string s)
  (call-with-default-reading-parameterization
    (thunk
      (parameterize ([read-square-bracket-as-paren #f]
                     [read-curly-brace-as-paren #f]
                     [read-accept-compiled #f]
                     [read-accept-reader #f]
                     [read-accept-lang #f])
        (read-sandbox `(read (open-input-string ,s)))))))