(module vandusen-scores ()

(import chicken scheme irregex)
(use vandusen vandusen-db srfi-13 irc data-structures srfi-1 regex)

(define (initialize-table)
  (exec (sql "CREATE TABLE IF NOT EXISTS scores ("
             "name TEXT PRIMARY KEY,"
             "score INTEGER NOT NULL)")))

(define message-body
  (let ((rx (irregex '(seq #\: (+ (~ #\:)) #\: (submatch (+ any))))))
    (lambda (m)
      (irregex-match-substring (irregex-match rx (irc:message-body m)) 1))))

(plugin 'scores
	(lambda ()
          (initialize-table)

          (define get-score
            (sql "SELECT score FROM scores WHERE name = ? COLLATE NOCASE"))

          (define update-score
            (sql "UPDATE scores SET score = score + ? WHERE name = ? COLLATE NOCASE"))

          (define insert-score
            (sql "INSERT INTO scores (name, score) VALUES (?, ?)"))

          (define get-top-scores
            (sql "SELECT name, score FROM scores ORDER BY score DESC LIMIT ?"))

          (define get-flop-scores
            (sql "SELECT name, score FROM scores ORDER BY score ASC LIMIT ?"))

          (define (modify-score! name delta)
            (if (null? (exec get-score name))
                (handle-exceptions exn
                  (if (eq? 'constraint (error-code (database)))
                      (modify-score! name delta)
                      (signal exn))
                  (exec insert-score name delta))
                (exec update-score delta name)))

	  (message-handler (lambda (m) 
                             (for-each (lambda (scoring)
                                         (modify-score! (string-drop-right scoring 2)
                                                        (if (string-suffix? "--" scoring) -1 1)))
                                       (filter (lambda (s)
                                                 (and (> (string-length s) 2)
                                                      (or (string-suffix? "--" s)
                                                          (string-suffix? "++" s))))
                                               (string-split (message-body m) " ")))
                             #f)
                           command: "PRIVMSG")

          (command 'score
                   '(seq "score" (+ space) (submatch (+ (~ space))))
                   (lambda (m name)
                     (handle-exceptions exn
                       (reply-to m (format "database error: ~A"
                                           (get-condition-property exn 'exn 'message)))

                       (let ((score (exec get-score name)))
                         (if (null? score)
                             (reply-to m (format "~A has not been rated, yet" name))
                             (reply-to m (format "the current score for ~A is ~A" name (car score)))))))
                   public: #t)

          
          (define (score-list-command cmd stmt default-limit)
            (command (string->symbol (string-append "score-" cmd))
                     `(seq ,cmd (? (+ space) (submatch (* num))))
                     (lambda (message limit)
                       (reply-to message
                                 (string-intersperse
                                  (map (lambda (score)
                                         (string-intersperse (map ->string score) ": "))
                                       (query fetch-all stmt (or limit default-limit)))
                                  ", ")))
                     public: #t))

          (score-list-command "top" get-top-scores 10)
          (score-list-command "flop" get-flop-scores 10)))

)