From 1819609bb32cef1a264e4e3f81b9ae531229ae86 Mon Sep 17 00:00:00 2001
From: wes <wjak56@gmail.com>
Date: Sat, 14 Apr 2012 23:47:24 -0400
Subject: [PATCH] first commit

---
 botcore.rkt  |  36 +++++++++
 commands.rkt |  39 ++++++++++
 config.rkt   |  50 +++++++++++++
 config.sexp  |  13 ++++
 database.rkt | 124 +++++++++++++++++++++++++++++++
 irclib.rkt   |  32 ++++++++
 redis.rkt    | 204 +++++++++++++++++++++++++++++++++++++++++++++++++++
 7 files changed, 498 insertions(+)
 create mode 100644 botcore.rkt
 create mode 100644 commands.rkt
 create mode 100644 config.rkt
 create mode 100644 config.sexp
 create mode 100644 database.rkt
 create mode 100644 irclib.rkt
 create mode 100644 redis.rkt

diff --git a/botcore.rkt b/botcore.rkt
new file mode 100644
index 0000000..e3342be
--- /dev/null
+++ b/botcore.rkt
@@ -0,0 +1,36 @@
+#lang racket
+ 
+;;TCP
+;;print-from-port : port -> void
+;;prints out lines from the port until there are no more lines to print.
+(define (print-from-port port)
+  (if (char-ready? port)
+      (let ([nextchar (read-char port)])
+        (printf (if (char=? #\~ nextchar)
+                    "~~"
+                    (string nextchar)))
+        (print-from-port port))
+      (printf "~n")))
+ 
+;;send-to-port : port -> void
+;;sends direct input from the user to the port.
+(define (send-to-port port)
+  (let ([input (read-line)])
+    (if (not (string=? input "n"))
+        (begin (display (string-append input "\r\n") port)
+               (flush-output port)
+               (printf "Sending ~a~n" input))
+        (printf "Not sending anything.~n"))))
+ 
+;;irc-connect : string number (port port -> void) -> void
+;;connects to an IRC network, and begins running the provided irc handler.
+(define (irc-connect server port handler)
+         (call-with-values (lambda () (tcp-connect server port))
+                  (lambda (arguments) (handler (first arguments) (second arguments)))))
+ 
+(define (irc-handle in out)
+  (print-from-port in)
+  (send-to-port out)
+  (irc-handle in out))
+ 
+;(irc-connect "localhost" 6667 irc-handle)
\ No newline at end of file
diff --git a/commands.rkt b/commands.rkt
new file mode 100644
index 0000000..af0e92b
--- /dev/null
+++ b/commands.rkt
@@ -0,0 +1,39 @@
+#lang racket
+(require "database.rkt")
+(require "config.rkt")
+;; Command Parsing
+
+(define (string-head str)
+  (substring str 0 1))
+
+(define (string-tail str)
+  (substring str 1 (string-length str)))
+
+(define (cmd? cmdchar cmd)
+  (string=? cmdchar (string-head cmd)))
+
+(define split-whitespace
+  ((curry regexp-split) #rx" "))
+
+(define (cmdparse command-char)
+  (compose
+   (lambda (command)
+    (match (cmd? command-char (car command))
+    [#f 'nil]
+    [#t (list (string-tail (car command))
+                            (cdr command))]))
+   split-whitespace))
+
+(define parse-exclamation
+  (cmdparse "!"))
+
+(define parse-at
+  (cmdparse "@"))
+
+;; Command Dispatcher
+(define (dispatch nick command)
+  (match (parse-exclamation command)
+    [(list-rest "set" args) (submit-question (caar args) (string-join (cdar args) " "))]
+    [(list-rest "alias" args) (make-alias (cadar args) (caar args))]
+    [(list-rest name _) (get-question name)]))
+
diff --git a/config.rkt b/config.rkt
new file mode 100644
index 0000000..2bb3fca
--- /dev/null
+++ b/config.rkt
@@ -0,0 +1,50 @@
+#lang racket
+; Config stuff
+(define inp-port
+  (open-input-file "./config.sexp"))
+
+; Decides what to do with a config item
+(define (config-parse item)
+  (match item
+    [(list-rest x (list-rest xs)) 
+     (update (make-hash) item)] ; make this into a new hash-table
+    [(list-rest xs) item] ; a flat list
+    [_ item])) ; any other type
+
+; Creates a config hash table
+(define (update htable settings)
+    (cond ((null? settings) htable)
+    (else (map (lambda (setting)
+        (hash-set! htable (first setting) (config-parse
+                                           (second setting)))) settings)
+        htable)))
+
+; the actual config hash-table
+(define config
+  (update (make-hash)
+          (read inp-port)))
+
+; get database info
+(define database-info
+  (let* [(database
+    (hash-ref
+     config
+     "database"))]
+  (lambda (key)
+    (hash-ref
+     database
+     key))))
+
+; get admin info, each admin returns an int which is access level
+(define admin-info
+  (let* [(admins
+          (hash-ref
+           config
+           "admins")
+          )]
+    (lambda (key)
+      (hash-ref
+       admins
+       key 1 ; default is 1 which is non-admin))))
+
+(provide (all-defined-out))
\ No newline at end of file
diff --git a/config.sexp b/config.sexp
new file mode 100644
index 0000000..cffae53
--- /dev/null
+++ b/config.sexp
@@ -0,0 +1,13 @@
+(
+ ; database info
+ ("database"
+ (("hostname" "localhost")
+ ("port" 5984)
+ ("user" "foo")
+ ("pass" "bar")))
+ ; bot administrators
+ ("admins"
+  (
+   ("foo" 0)
+   )
+ ))
diff --git a/database.rkt b/database.rkt
new file mode 100644
index 0000000..0d74ed2
--- /dev/null
+++ b/database.rkt
@@ -0,0 +1,124 @@
+#lang racket
+(require (planet mordae/couchdb:1:11))
+(require (planet dherman/json:4:0))
+(require net/base64)
+(require "redis.rkt")
+(require "config.rkt")
+
+; Couch Database operations
+; object used to connect to the database
+(define (database-connection database-name)
+  (couchdb-db
+   (couchdb-connect
+   #:host (database-info "hostname")
+   #:port (database-info "port")
+   #:user (database-info "user")
+   #:password (database-info "pass"))
+   database-name))
+
+; gets a single uuid
+(define (get-uuid)
+  (couchdb-get (database-connection "_uuids") ""))
+
+; submits a question
+(define couchdb-submit
+  (compose ((curry couchdb-put)
+            (database-connection "faqbot"))
+           ; build the jsexpr (hasheq)
+           (lambda (question)
+             (hasheq '_id
+                     (first question)
+                     'text 
+                     (second question)))
+           ; strip all newlines
+           (lambda (question)
+             (list (first question)
+                   (strip-newlines
+                    (second question))))))
+
+; gets a question
+(define couchdb-retrieve
+  (compose
+   (lambda (result)
+     (hash-ref result 'text))
+   ((curry couchdb-get)
+   (database-connection "faqbot"))))
+
+; strips all newlines
+(define (strip-newlines text)
+  (regexp-replace* #rx"\n" text ""))
+
+; Redis Database Operations
+
+; make a command
+(define make-cmd set)
+
+; gets a specified command ID from redis
+(define (get-id cmd)
+  (match (get cmd)
+    ['nil 'nil]
+    [result (match (bytes->string/utf-8 result)
+    ['nil 'nil]
+    [result (match (regexp-match #rx"^[0-9a-z]*$" result)
+              [#f 'nil]
+              [_ result])])]))
+
+; make a command alias
+(define (make-alias new-cmd old-cmd)
+  (match (get-id old-cmd)
+    ['nil 'nil]
+    [_ (make-cmd
+   new-cmd
+   (get-id old-cmd))]))
+
+
+;; Command Dispatch Functions
+;; These functions take a string, parse it, and then execute the command
+
+; associates a name with an id in Redis, then puts the question in couchdb
+(define (submit-question name content)
+  (let* ([id (caar (hash-values [get-uuid]))])
+    (make-cmd name id)
+    (couchdb-submit (list id content))))
+
+; gets an id associated with a name from Redis, then gets the question from couchdb
+
+(define (get-question name)
+  (let* ([id (get-id name)])
+    (match id
+      ['nil "No question found"]
+      [_ (couchdb-retrieve id)])))
+
+;; Rate Limiting
+; if |hC Current| > k, then set hC to Current, and hN to 0, and allow
+; if |hC Current| < k and hN == n, then deny
+; if |hC Current| < k, and hN < n, then allow, and increment hN by 1
+
+(define (bytes->number x)
+  (string->number (bytes->string/utf-8 x)))
+; Is there a built-in Racket function to convert byte strings to floats?
+
+(define (time-magnitude a b)
+  (abs (- b (bytes->number a))))
+
+(define (rate-check-helper mag hN n k)
+  (let ([hN (bytes->number hN)])
+    (cond
+    [(and (> k mag) (eq? hN n)) #f]
+    [(and (< mag k) (< hN n)) (hincrby "counter" "n" "1") #t]
+    [else (hset "counter" "n" "0")
+          (hset "counter" "current" (number->string (current-inexact-milliseconds)))
+          #t])))
+
+(define ((rate-check n k))
+  (let* ([counter (hvals "counter")]
+         [current-time (current-inexact-milliseconds)])
+    (let* ([hC-Current (time-magnitude (second counter) current-time)])
+      (rate-check-helper hC-Current (first counter) n k))))
+
+; Allows no more than 20 commands every 5 minutes
+; resets after 5 minutes have passed from the last time it was reset
+(define allowed? (rate-check 20 (* 5 60000)))
+;; Admin Stuff
+
+(provide (all-defined-out))
\ No newline at end of file
diff --git a/irclib.rkt b/irclib.rkt
new file mode 100644
index 0000000..6030d7b
--- /dev/null
+++ b/irclib.rkt
@@ -0,0 +1,32 @@
+#lang racket
+
+; This module builds strings for requisite IRC commands
+
+; PRIVMSG command
+(define (privmsg target msg)
+  (format "PRIVMSG ~a :~a"
+          target
+          msg))
+
+; USER command
+(define (usermsg username realname)
+  (format 
+   "USER ~a 0 * :~a" username realname))
+
+; JOIN command
+(define (join channel)
+  (format
+   "JOIN :~a" channel))
+
+; PART command
+(define (part channel reason)
+  (format
+   "PART ~a :~a"
+   channel
+   reason))
+  
+; QUIT command
+(define (quit reason)
+  (format "QUIT :~a"
+          reason))
+  
\ No newline at end of file
diff --git a/redis.rkt b/redis.rkt
new file mode 100644
index 0000000..e51814b
--- /dev/null
+++ b/redis.rkt
@@ -0,0 +1,204 @@
+;;; redis.rkt
+;;;
+;;; Implements an interface to the redis persistent key-value
+;;; database. Communicates with the database through its TCP
+;;; interface.
+#lang racket
+
+(require racket/date)
+
+(define-struct connection (in out cust))
+
+(define (connect)
+  (let ([cust (make-custodian)])
+    (parameterize ([current-custodian cust])
+      (let-values ([(in out) (tcp-connect "localhost" 6379)])
+        (make-connection in out cust)))))
+
+(define current-connection (make-parameter (connect)))
+
+(define (disconnect!)
+  (define conn (current-connection))
+  (with-handlers ([exn:fail:network? void])
+    (close-output-port (connection-out conn)))
+  (with-handlers ([exn:fail:network? void])
+    (close-input-port (connection-in conn))))
+
+(define send-command
+  (lambda commands
+    (define out (connection-out (current-connection)))
+    (fprintf out "*~a\r\n" (length commands))
+    (for-each (lambda (command)
+                (fprintf out "$~a\r\n~a\r\n"
+                         (bytes-length
+                          (string->bytes/utf-8
+                           command))
+                         command))
+              commands)
+    (flush-output out)))
+
+(define-struct exn:redis (message))
+
+(define (read-reply)
+  (define in (connection-in (current-connection)))
+  (match (read-bytes 1 in)
+    [#"-" (read-line in 'return-linefeed)]
+    [#"+" (read-line in 'return-linefeed)]
+    [#"$" (read-bulk-reply in)]
+    [#"*" (read-multi-bulk-reply in)]
+    [#":" (string->number (read-line in 'return-linefeed))]
+    [_ (raise (make-exn:redis (format "invalid control character: ~a"
+                                      (read-byte in))))]))
+
+(define (read-bulk-reply in)
+  (flush-output)
+  (let ([length (string->number (read-line in 'return-linefeed))])
+    (match length
+      [-1 'nil]
+      [_ (begin0 (read-bytes length in)
+      (read-line in 'return-linefeed))])))
+
+(define (read-multi-bulk-reply in)
+  (let ([length (string->number (read-line in 'return-linefeed))])
+    (flush-output)
+    (build-list length
+                (lambda (_) (read-reply)))))
+    
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; COMMANDS
+
+(define (ping)
+  (send-command "PING")
+  (read-reply))
+
+;; Connection handling
+
+(define (quit)
+  (send-command "QUIT")
+  (disconnect!))
+
+(define (auth)
+  (send-command "AUTH")
+  (read-reply))
+
+;; Commands operating on all value types
+
+(define (exists? key)
+  (send-command "EXISTS" key) 
+  (match (read-reply)
+         [1 #t]
+         [0 #f]))
+
+(define del!
+  (lambda keys
+    (apply send-command `("DEL" ,@keys))
+    (read-reply)))
+
+(define (type key)
+  (send-command "TYPE" key)
+  (string->symbol (read-reply)))
+
+(define (keys pattern)
+  (send-command "KEYS" pattern)
+  (read-reply))
+
+(define (randomkey)
+  (send-command "RANDOMKEY")
+  (read-reply))
+
+
+(define (rename! oldkey newkey)
+  (send-command "RENAME" oldkey newkey)
+  (read-reply))
+
+(define (renamenx! oldkey newkey)
+  (send-command "RENAME" oldkey newkey)
+  (match (read-reply)
+         [1 #t]
+         [0 #f]))
+
+(define (dbsize)
+  (send-command "DBSIZE")
+  (read-reply))
+
+(define (expire! key seconds)
+  (send-command "EXPIRE" key seconds)
+  (read-reply))
+
+(define (expireat! key date)
+  (send-command "EXPIREAT" key (date->seconds date))
+  (read-reply))
+
+(define (ttl key)
+  (send-command "TTL" key)
+  (read-reply))
+
+(define (select key)
+  (send-command "SELECT" key)
+  (read-reply))
+
+(define (move key dbindex)
+  (send-command "MOVE" key dbindex)
+  (read-reply))
+
+(define (flushdb)
+  (send-command "FLUSHDB")
+  (read-reply))
+
+(define (flushall)
+  (send-command "FLUSHALL")
+  (read-reply))
+
+(define (set key value)
+  (send-command "SET" key value)
+  (read-reply))
+
+(define (get key)
+  (send-command "GET" key)
+  (read-reply))
+
+(define (getset key value)
+  (send-command "GETSET" key value)
+  (read-reply))
+
+(define mget
+  (lambda keys
+    (apply send-command `("MGET" ,@keys)
+    (read-reply))))
+
+(define (incrby key n)
+  (send-command "INCRBY" key n)
+  (read-reply))
+
+;; Hash commands
+
+(define (hset key field value)
+  (send-command "HSET" key field value)
+  (read-reply))
+
+(define (hget key field)
+  (send-command "HGET" key field)
+  (read-reply))
+
+(define (hgetall key)
+  (send-command "HGETALL" key)
+  (read-reply))
+
+(define (hincrby key field num)
+  (send-command "HINCRBY" key field num)
+  (read-reply))
+
+(define (hincrbyfloat key field num)
+  (send-command "HINCRBYFLOAT" key field num)
+  (read-reply))
+
+(define (hkeys key)
+  (send-command "HKEYS" key)
+  (read-reply))
+
+(define (hvals key)
+  (send-command "HVALS" key)
+  (read-reply))
+
+(provide (all-defined-out))
\ No newline at end of file