diff options
| -rw-r--r-- | irc/core.rkt | 19 | ||||
| -rw-r--r-- | irc/db.rkt | 26 | ||||
| -rw-r--r-- | irc/storage.rkt | 94 | ||||
| -rw-r--r-- | irc/users.rkt | 37 |
4 files changed, 170 insertions, 6 deletions
diff --git a/irc/core.rkt b/irc/core.rkt index fa5edce..342cb78 100644 --- a/irc/core.rkt +++ b/irc/core.rkt @@ -1,12 +1,14 @@ #lang racket/base (require (for-syntax racket/provide) racket/provide - racket/string + racket/string 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 + 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) @@ -18,7 +20,7 @@ (make-parameter (λ (x) (displayln (exn->string x))))) (struct connection - (input output hooks output-lock) + (input output hooks output-lock storage) #:mutable) (struct message @@ -29,15 +31,20 @@ (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))) + (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]) - (for-each (λ (h) (h)) (connection-hooks (current-connection)))))) + (set-connection-hooks! conn + (filter-not (λ (h) (eq? (h) hook-abort)) + (connection-hooks conn)))))) (define (msg-print-raw msg out) (define (clean s) @@ -90,7 +97,7 @@ (message tags prefix (string->symbol command) (reverse args) suffix)) -(define (message-params msg) (append (message-args msg) (message-suffix msg))) +(define (message-params msg) (append (message-args msg) (list (message-suffix msg)))) (define (message-prefix-nick msg) (let* ([prefix (message-prefix msg)] diff --git a/irc/db.rkt b/irc/db.rkt new file mode 100644 index 0000000..5cba0d3 --- /dev/null +++ b/irc/db.rkt @@ -0,0 +1,26 @@ +#lang racket/base +(require db sql) +(provide (all-defined-out)) + +; Assumption: Each connection gets its own database + +(define current-database (make-parameter #f)) + +(define (db-init) + (query-exec (current-database) + (create-table #:if-not-exists users + #:columns [name varchar #:not-null] + [power integer #:not-null] + [data varchar #:not-null] + #:constraints (primary-key name))) + + (query-exec (current-database) + (create-table #:if-not-exists channels + #:columns [name varchar #:not-null] + [autojoin boolean #:not-null] + [data varchar #:not-null])) + + (query-exec (current-database) + (create-table #:if-not-exists network + #:columns [name varchar #:not-null] + [data varchar #:not-null]))) diff --git a/irc/storage.rkt b/irc/storage.rkt new file mode 100644 index 0000000..d1425de --- /dev/null +++ b/irc/storage.rkt @@ -0,0 +1,94 @@ +#lang racket/base +(require irc/core irc/bot irc/db irc/users + racket/list racket/function + racket/format racket/serialize + db sql) +(provide (all-defined-out)) + +(define (current-storage) (connection-storage (current-connection))) + +(struct storage + (user volatile-user + channel volatile-channel + network volatile-network)) + +(define (storage-init) + (set-connection-storage! + (current-connection) + (storage (load-storage (select name data #:from users)) (make-hash) + (load-storage (select name data #:from channels)) (make-hash) + (load-storage (select name data #:from network)) (make-hash)))) + +; TODO !!! IRC downcasing of nicks + +(define (user-storage user #:volatile? [volatile #f]) + (hash-ref! ((if volatile storage-volatile-user storage-user) + (current-storage)) + user (thunk (make-hash)))) + +(define (channel-storage channel #:volatile? [volatile #f]) + (hash-ref! ((if volatile storage-volatile-channel storage-channel) + (current-storage))) + channel (thunk (make-hash))) + +(define (network-storage name #:volatile? [volatile #f]) + (hash-ref! ((if volatile storage-volatile-network storage-network) + (current-storage)) + name (thunk (make-hash)))) + +(define (load-storage query) + (define storage (make-hash)) + (for ([(name data) (in-query (current-database) query)]) + (hash-set! storage name (deserialize (safe-read-string data)))) + storage) + +(define empty-serialized-hash + (~s (serialize (make-hash)))) + +(define (persist-user user) + (query-exec (current-database) + (insert #:into users + #:set [name ,user] + [power 0] + [data ,empty-serialized-hash] + #:or-ignore)) + + (query-exec (current-database) + (update users + #:set [data ,(~s (serialize (user-storage user)))] + #:where (= name ,user)))) + +(define (persist-channel channel) + (query-exec (current-database) + (insert #:into channels + #:set [name ,channel] + [autojoin 0] + [data ,empty-serialized-hash] + #:or-ignore)) + + (query-exec (current-database) + (update channels + #:set [data ,(~s (serialize (channel-storage channel)))] + #:where (= name ,channel)))) + +(define (persist-network name) + (query-exec (current-database) + (insert #:into network + #:set [name ,name] + [data ,empty-serialized-hash] + #:or-ignore)) + + (query-exec (current-database) + (update network + #:set [data ,(~s (serialize (network-storage name)))] + #:where (= name ,name)))) + +(define (ref h . path) + (foldl (λ (p h) (hash-ref h p)) h path)) + +(define (ref-set! h value . path) + (if (pair? (cdr path)) + (apply ref-set! + (hash-ref! h (car path) (thunk (make-hash))) + value (cdr path)) + (hash-set! h (car path) value))) diff --git a/irc/users.rkt b/irc/users.rkt new file mode 100644 index 0000000..330b965 --- /dev/null +++ b/irc/users.rkt @@ -0,0 +1,37 @@ +#lang racket/base +(require irc/core irc/bot irc/db + racket/match racket/string + db sql) +(provide (all-defined-out)) + +; Power levels +; 0 untrusted +; 1 trusted +; 2 admin + +(define (user-power user) + (or (query-maybe-value (current-database) + (select power #:from users #:where (= name ,user))) + 0)) + +(define (is-untrusted? user) (= 0 (user-power user))) +(define (is-trusted? user) (= 1 (user-power user))) +(define (is-admin? user) (= 2 (user-power user))) + +; Do VERSION, wait for reply +; Store CASEMAPPING in network storage +; Implement case mapping, dependent on that value, with fallback + +; TODO This can leak on repeated timeouts +(define (is-identified? user) + (send (msg 'WHO '() user)) + (define ch (make-channel)) + (on (command-is '|352|) + (match-define + (list-rest own-nick channel _user host + server nick mode suffix) (params)) + (when (string=? nick user) + (channel-put ch (string-contains? mode "r")) + hook-abort)) + (sync/timeout 15 ch)) + |