Browse Source

More groups & user queries (very hacky; sqlite is temporary)

master
Christian Fischer 1 year ago
parent
commit
8e410e87e6
3 changed files with 185 additions and 115 deletions
  1. +15
    -15
      server/access.rkt
  2. +9
    -61
      server/db.rkt
  3. +161
    -39
      server/groups.rkt

+ 15
- 15
server/access.rkt View File

@@ -155,8 +155,8 @@
;; (set user)
;; (set)))))

(add-group-for-owner 4)
(add-group-for-owner 3)
;; (add-group-for-owner 4)
;; (add-group-for-owner 3)

;; (define (has-user? g u)
;; (or (set-member? (group-admins g) u)
@@ -249,16 +249,16 @@
;; (resource n o ps))


(define tst-res
(let ([plines (list (pl-dataset-data empty)
(pl-dataset-desc "test desc")
(pl-resource-admin empty))])
(resource "test"
(user-by-id 1)
empty
plines
(list (cons 1 (maximum-access-mask plines))
(cons 2 (minimum-access-mask plines))
(cons 0 (list '(data . edit)
'(desc . no-access)
'(admin . not-admin)))))))
;; (define tst-res
;; (let ([plines (list (pl-dataset-data empty)
;; (pl-dataset-desc "test desc")
;; (pl-resource-admin empty))])
;; (resource "test"
;; (user-by-id 1)
;; empty
;; plines
;; (list (cons 1 (maximum-access-mask plines))
;; (cons 2 (minimum-access-mask plines))
;; (cons 0 (list '(data . edit)
;; '(desc . no-access)
;; '(admin . not-admin)))))))

+ 9
- 61
server/db.rkt View File

@@ -2,8 +2,7 @@

(require db
json
threading
"groups.rkt")
threading)

(provide connect-db
create-users-table
@@ -14,75 +13,24 @@
(sqlite3-connect #:database "./proxy.db"
#:mode 'create))


(define (create-users-table dbc)
(query-exec
dbc
"create temporary table users (
"create table users (
user_id integer primary key,
name text not null)"))

(define (create-groups-table dbc)
(query-exec
dbc
"create temporary table groups (
"create table groups (
group_id integer primary key,
admin_ids text not null,
member_ids text not null)"))

(define (insert-group dbc admins members)
(let ([admin-str (jsexpr->string (set->list admins))]
[mems-str (jsexpr->string (set->list members))])

(query-exec
dbc
"insert into groups (admin_ids, member_ids)
values (?, ?)"
admin-str
mems-str)))

(define test-grp
(cons (list->set '(1 2 3 4))
(list->set '(5 6 7 8 9 10))))

(define (read-group-row r)
(define (ref i)
(~> (vector-ref r i)
(string->jsexpr)
(list->set)))
(group (vector-ref r 0)
(ref 1)
(ref 2)))

(define (select-groups dbc)
(map read-group-row
(query-rows dbc
"select * from groups")))

(define (select-group-id dbc id)
(read-group-row
(query-row dbc
"select * from groups where group_id = ?"
id)))


(define (read-user-row r)
(user (vector-ref r 0)
(vector-ref r 1)))

(define (select-users dbc)
(map read-user-row
(query-rows
dbc
"select * from users")))

(define (select-user-id dbc id)
(read-user-row
(query-row dbc
"select * from users where user_id = ?"
id)))

(define (insert-user dbc name)
(query-exec
dbc
"insert into users (name) values (?)"
name))
;; (define (create-resources-table dbc)
;; (query-exec
;; dbc
;; "create table resources (
;; )"))

+ 161
- 39
server/groups.rkt View File

@@ -1,61 +1,181 @@
#lang racket

(require racket/set
threading)

(provide group-by-id
groups-by-user
user-by-id
has-user?
add-group-for-owner
(require db
json
racket/set
threading
"db.rkt")

(provide ;group-by-id
;groups-by-user
;user-by-id
;; has-user?
;add-group-for-owner
(struct-out user)
(struct-out group))

; Groups and users are the second, for now, a user is simply an ID
; A simple (placeholder) user type, to be replaced by one isomorphic
; to the GeneNetwork user type.
(struct user (id name)
#:transparent)

(define (read-user-row r)
(user (vector-ref r 0)
(vector-ref r 1)))

(define (select-users dbc)
(map read-user-row
(query-rows
dbc
"select * from users")))

(define (select-user-id dbc id)
(read-user-row
(query-maybe-row dbc
"select * from users where user_id = ?"
id)))

;; (define (select-users-id dbc ids)
;; (map read-user-row
;; (query-rows dbc
;; "select * from users where user_id

(define (select-user-name dbc name)
(read-user-row
(query-maybe-row dbc
"select * from users where name = ?"
name)))

(define (insert-user dbc name)
(query-exec
dbc
"insert into users (name) values (?)"
name))

; A group is a product of two sets of users, admins and members. A
; user can be either an admin or a member, not both. Logically, for
; access control purposes, being an admin implies being a member.
(struct group (id admins members)
#:transparent)


(define (insert-group dbc admins members)
(let ([admin-str (jsexpr->string (set->list admins))]
[mems-str (jsexpr->string (set->list members))])
(query-exec
dbc
"insert into groups (admin_ids, member_ids)
values (?, ?)"
admin-str
mems-str)))


(define test-grp
(cons (list->set '(1 2 3 4))
(list->set '(5 6 7 8 9 10))))

(define (read-group-row r)
(define (ref i)
(~> (vector-ref r i)
(string->jsexpr)
(list->set)))
(group (vector-ref r 0)
(ref 1)
(ref 2)))

(define (select-groups dbc)
(map read-group-row
(query-rows dbc
"select * from groups")))

(define (select-group-id dbc id)
(read-group-row
(query-row dbc
"select * from groups where group_id = ?"
id)))

;; this is just a *terrible* way of doing it, but it's temporary and
;; i'm not about to set sqlite up with regex support just for this,
;; though for now it would probably be better to just do `select * from groups`
;; and do the filtering in racket...
(define (group-query-string column id)
(if (and (number? id)
(string? column))
(let ([id (number->string id)])
(string-append
"select * from groups where "
column " like '[" id "]' or "
column " like '[" id ",%' or "
column " like '%," id ",%' or "
column " like '%," id "]'"))
#f))


(define (select-groups-by-admin-id dbc id)
(if (number? id)
(map read-group-row
(query-rows dbc
(group-query-string "admin_ids" id)))
(error "tried to select groups where id is not a number"))

(define (select-groups-by-member-id dbc id)
(if (number? id)
(map read-group-row
(query-rows dbc
(group-query-string "member_ids" id)))
(error "tried to select groups where id is not a number"))


;; (define (select-groups-by-user-id dbc id)
;; (map read-group-row




; Placeholder global user "DB" with some entries for testing
(define user-db
(list (user 1 "admin1")
(user 2 "user1")
(user 3 "user2")
(user 4 "admin2")))
;; (define user-db
;; (list (user 1 "admin1")
;; (user 2 "user1")
;; (user 3 "user2")
;; (user 4 "admin2")))

(define (user-by-id id)
(findf (lambda (u) (eq? id (user-id u))) user-db))
;; TODO rewrite
;; (define (user-by-id id)
;; (findf (lambda (u) (eq? id (user-id u))) user-db))



(define (same-user? a b)
(equal? (user-id a) (user-id b)))
;; NOTE this isn't used anywhere
;; (define (same-user? a b)
;; (equal? (user-id a) (user-id b)))

;A `group` is a collection of users of different levels, including a
; non-empty set of admin users
(struct group (id admins members)
#:transparent)

; Placeholder global group "DB", will be replaced by an actual DB
; system etc.
(define group-db
(mutable-set))
;; (define group-db
;; (mutable-set))

;; (define user-groups (make-parameter group-db))


(set-add! group-db (group 0
(set (user-by-id 1))
(set (user-by-id 3))))
;; (set-add! group-db (group 0
;; (set (user-by-id 1))
;; (set (user-by-id 3))))

; Placeholder function for adding a group to the global DB; only works
; if the given user ID exists in the user Db
(define (add-group-for-owner owner-id)
(define user (user-by-id owner-id))
(when user
(set-add! group-db (group (set-count group-db)
(set user)
(set)))))

;; TODO rewrite
;; (define (add-group-for-owner owner-id)
;; (define user (user-by-id owner-id))
;; (when user
;; (set-add! group-db (group (set-count group-db)
;; (set user)
;; (set)))))

;; This is only used by add-member and make-admin. These functions
;; should probably be replaced by an interface that makes more sense
;; for our purposes.
(define (has-user? g u)
(or (set-member? (group-admins g) u)
(set-member? (group-members g) u)))
@@ -81,13 +201,15 @@
[members (set-remove (group-members g) m)])
g))

(define (group-by-id id)
(findf (lambda (g) (eq? id (group-id g)))
(set->list group-db)))
;; TODO rewrite
;; (define (group-by-id id)
;; (findf (lambda (g) (eq? id (group-id g)))
;; (set->list group-db)))

(define (groups-by-user u)
(filter (lambda (g) (has-user? g u))
(set->list group-db)))
;; TODO rewrite
;; (define (groups-by-user u)
;; (filter (lambda (g) (has-user? g u))
;; (set->list group-db)))

;
(define (all-members g)


Loading…
Cancel
Save