From fc07c90d707c3a36251c9e9c6277a70c885cea3d Mon Sep 17 00:00:00 2001
From: tilpner
Date: Sun, 22 Apr 2018 23:35:58 +0200
Subject: Add user management

---
 irc/core.rkt    | 19 ++++++++----
 irc/db.rkt      | 26 ++++++++++++++++
 irc/storage.rkt | 94 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 irc/users.rkt   | 37 +++++++++++++++++++++++
 4 files changed, 170 insertions(+), 6 deletions(-)
 create mode 100644 irc/db.rkt
 create mode 100644 irc/storage.rkt
 create mode 100644 irc/users.rkt

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))
+
-- 
cgit v1.2.3