From 839abeba255fa358c47b5115d8793c414919352d Mon Sep 17 00:00:00 2001 From: Christian Date: Fri, 29 May 2020 17:23:45 -0500 Subject: [PATCH 01/19] Add endpoint that returns action set for resource type --- server/privileges.rkt | 10 ++++++++++ server/rest.rkt | 32 +++++++++++++++++++++++++++----- 2 files changed, 37 insertions(+), 5 deletions(-) diff --git a/server/privileges.rkt b/server/privileges.rkt index a7badd0..096fa84 100644 --- a/server/privileges.rkt +++ b/server/privileges.rkt @@ -1,6 +1,7 @@ #lang racket (provide (struct-out action) + action-set->hash minimum-access-mask maximum-access-mask run-action @@ -40,6 +41,15 @@ (for/and ([(k v) (in-hash actions)]) (and (dict? v) (list? v))))) + +;; It's useful to be able to partially represent an action set as +;; a tree, to show exactly what actions are available, in general, +;; on a resource type +(define (action-set->hash actions) + (for/hash ([(k v) (in-hash actions)]) + (values k (map car v)))) + + ;; A mask is a map from action branches to action IDs. In a sense ;; it is a subset of the action set; though it doesn't actually ;; contain the actions, it does describe which actions can be used. diff --git a/server/rest.rkt b/server/rest.rkt index 888e793..163195e 100644 --- a/server/rest.rkt +++ b/server/rest.rkt @@ -20,12 +20,32 @@ ;;;; Endpoints +;; Get a JSON representation of the action set for a resource type, +;; can be useful when resource types start changing so we know what +;; the proxy expects the masks in a redis resource to look like +(define (get-action-set-endpoint req) + (define binds (request-bindings/raw req)) + (define message + (match (list (bindings-assq #"resource-type" binds)) + [(list #f) + "Provide a resource type"] + [(list (binding:form _ res-type)) + (let ((type (dict-ref resource-types + (~> res-type + (bytes->string/utf-8) + (string->symbol))))) + (jsexpr->bytes (action-set->hash type)))])) + (response/output + (lambda (out) + (displayln message out)))) + +(define (get-action-set-dispatcher conn req) + (output-response conn (get-action-set-endpoint req))) + + ;; Query available actions for a resource, for a given user (define (query-available-endpoint req) (define binds (request-bindings/raw req)) - (define (masked-actions actions) - (for/hash ([(k v) (in-hash actions)]) - (values k (map car v)))) (define message (match (list (bindings-assq #"resource" binds) (bindings-assq #"user" binds)) @@ -40,7 +60,7 @@ (~> (apply-mask (dict-ref resource-types (resource-type res)) mask) - (masked-actions) + (action-set->hash) (jsexpr->bytes)))])) (response/output (lambda (out) @@ -114,7 +134,9 @@ (filter:make #rx"^/available/" query-available-dispatcher) (filter:make #rx"^/run-action/" - run-action-dispatcher)) + run-action-dispatcher) + (filter:make #rx"^/get-action-set/" + get-action-set-dispatcher)) #:listen-ip "127.0.0.1" #:port (string->number (or (getenv "PORT") From bad41a239118db1960ab85f3f84c72eeafa9c58d Mon Sep 17 00:00:00 2001 From: Christian Date: Fri, 29 May 2020 17:24:31 -0500 Subject: [PATCH 02/19] Use dispatch-rules to improve routing - changes API URLs --- server/rest.rkt | 21 ++++++++------------- 1 file changed, 8 insertions(+), 13 deletions(-) diff --git a/server/rest.rkt b/server/rest.rkt index 163195e..929ea5d 100644 --- a/server/rest.rkt +++ b/server/rest.rkt @@ -10,6 +10,7 @@ web-server/http/bindings web-server/servlet-dispatch web-server/web-server + web-server/dispatch (prefix-in filter: web-server/dispatchers/dispatch-filter) (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer) "db.rkt" @@ -39,9 +40,6 @@ (lambda (out) (displayln message out)))) -(define (get-action-set-dispatcher conn req) - (output-response conn (get-action-set-endpoint req))) - ;; Query available actions for a resource, for a given user (define (query-available-endpoint req) @@ -66,8 +64,6 @@ (lambda (out) (displayln message out)))) -(define (query-available-dispatcher conn req) - (output-response conn (query-available-endpoint req))) (define (action-params action binds) (for/hash ([k (action-req-params action)]) @@ -124,19 +120,18 @@ (lambda (out) (displayln message out)))) -(define (run-action-dispatcher conn req) - (output-response conn (run-action-endpoint req))) + +(define-values (app reverse-uri) + (dispatch-rules + [("available") query-available-endpoint] + [("run-action") run-action-endpoint] + [("get-action-set") get-action-set-endpoint])) ;; Run the server (define stop (serve #:dispatch (sequencer:make - (filter:make #rx"^/available/" - query-available-dispatcher) - (filter:make #rx"^/run-action/" - run-action-dispatcher) - (filter:make #rx"^/get-action-set/" - get-action-set-dispatcher)) + (dispatch/servlet app)) #:listen-ip "127.0.0.1" #:port (string->number (or (getenv "PORT") From 637ccf9f7f75ffae25f2a28d30062e7c0bf6c6ef Mon Sep 17 00:00:00 2001 From: Christian Date: Sat, 30 May 2020 20:52:01 -0500 Subject: [PATCH 03/19] Split resources into modules --- server/resource.rkt | 148 ++--------------------------------- server/resource/geno.rkt | 39 +++++++++ server/resource/probe.rkt | 40 ++++++++++ server/resource/probeset.rkt | 46 +++++++++++ server/resource/publish.rkt | 51 ++++++++++++ server/resource/util.rkt | 28 +++++++ 6 files changed, 210 insertions(+), 142 deletions(-) create mode 100644 server/resource/geno.rkt create mode 100644 server/resource/probe.rkt create mode 100644 server/resource/probeset.rkt create mode 100644 server/resource/publish.rkt create mode 100644 server/resource/util.rkt diff --git a/server/resource.rkt b/server/resource.rkt index 9d8d16d..2becb79 100644 --- a/server/resource.rkt +++ b/server/resource.rkt @@ -7,7 +7,12 @@ racket/file "db.rkt" "groups.rkt" - "privileges.rkt") + "privileges.rkt" + "resource/geno.rkt" + "resource/probe.rkt" + "resource/probeset.rkt" + "resource/publish.rkt" + "resource/util.rkt") (provide (struct-out resource) get-mask-for-user @@ -161,15 +166,6 @@ (cdr action) no-access-action)))) - ;; (cdr (assoc action-id (hash-ref action-set branch-id))))) - -;; The general "no access" action -- may change in the future -(define no-access-action - (action "no-access" - (lambda (data params) - 'no-access) - '())) - ;; Actions for file-based resources (define view-file (action "view" @@ -243,52 +239,6 @@ (hasheq))) -;; Function that serializes an SQL result row into a stringified JSON -;; array. Probably doesn't work with all SQL types yet!! -(define (sql-result->json query-result) - (jsexpr->bytes - (map (lambda (x) - (if (sql-null? x) 'null x)) - (vector->list query-result)))) - -(define (select-publish dataset-id trait-name) - (sql-result->json - (query-row (mysql-conn) - "SELECT - PublishXRef.Id, InbredSet.InbredSetCode, Publication.PubMed_ID, - Phenotype.Pre_publication_description, Phenotype.Post_publication_description, Phenotype.Original_description, - Phenotype.Pre_publication_abbreviation, Phenotype.Post_publication_abbreviation, PublishXRef.mean, - Phenotype.Lab_code, Phenotype.Submitter, Phenotype.Owner, Phenotype.Authorized_Users, - Publication.Authors, Publication.Title, Publication.Abstract, - Publication.Journal, Publication.Volume, Publication.Pages, - Publication.Month, Publication.Year, PublishXRef.Sequence, - Phenotype.Units, PublishXRef.comments - FROM - PublishXRef, Publication, Phenotype, PublishFreeze, InbredSet - WHERE - PublishXRef.Id = ? AND - Phenotype.Id = PublishXRef.PhenotypeId AND - Publication.Id = PublishXRef.PublicationId AND - PublishXRef.InbredSetId = PublishFreeze.InbredSetId AND - PublishXRef.InbredSetId = InbredSet.Id AND - PublishFreeze.Id = ?" - trait-name - dataset-id))) - -(define view-publish - (action "view" - (lambda (data - params) - (select-publish (hash-ref data 'dataset) - (hash-ref data 'trait))) - '())) - -(define dataset-publish-data - (list (cons "no-access" no-access-action) - (cons "view" view-publish))) - -(define dataset-publish-actions - (hasheq 'data dataset-publish-data)) ;; The dataset-geno resource type ;; Currently only read actions @@ -304,32 +254,6 @@ default-mask (hasheq))) -(define (select-geno dataset-name trait-name) - (sql-result->json - (query-row (mysql-conn) - "SELECT Geno.Name, Geno.Chr, Geno.Mb, Geno.Source2, Geno.Sequence - FROM Geno, GenoFreeze, GenoXRef - WHERE GenoXRef.GenoFreezeId = GenoFreeze.Id AND - GenoXRef.GenoId = Geno.Id AND - GenoFreeze.Id = ? AND - Geno.Name = ?" - dataset-name - trait-name))) - -(define view-geno - (action "view" - (lambda (data - params) - (select-geno (hash-ref data 'dataset) - (dict-ref params 'trait))) - '(trait))) - -(define dataset-geno-data - (list (cons "no-access" no-access-action) - (cons "view" view-geno))) - -(define dataset-geno-actions - (hasheq 'data dataset-geno-data)) ;; The dataset-probeset resource type ;; Currently only read actions @@ -345,39 +269,6 @@ default-mask (hasheq))) -(define (select-probeset dataset-name trait-name) - (sql-result->json - (query-row (mysql-conn) - "SELECT ProbeSet.Name, ProbeSet.Symbol, ProbeSet.description, ProbeSet.Probe_Target_Description, - ProbeSet.Chr, ProbeSet.Mb, ProbeSet.alias, ProbeSet.GeneId, ProbeSet.GenbankId, ProbeSet.UniGeneId, - ProbeSet.OMIM, ProbeSet.RefSeq_TranscriptId, ProbeSet.BlatSeq, ProbeSet.TargetSeq, ProbeSet.ChipId, - ProbeSet.comments, ProbeSet.Strand_Probe, ProbeSet.Strand_Gene, ProbeSet.ProteinID, ProbeSet.UniProtID, - ProbeSet.Probe_set_target_region, ProbeSet.Probe_set_specificity, ProbeSet.Probe_set_BLAT_score, - ProbeSet.Probe_set_Blat_Mb_start, ProbeSet.Probe_set_Blat_Mb_end, ProbeSet.Probe_set_strand, - ProbeSet.Probe_set_Note_by_RW, ProbeSet.flag - FROM ProbeSet, ProbeSetFreeze, ProbeSetXRef - WHERE - ProbeSetXRef.ProbeSetFreezeId = ProbeSetFreeze.Id AND - ProbeSetXRef.ProbeSetId = ProbeSet.Id AND - ProbeSetFreeze.Id = ? AND - ProbeSet.Name = ?" - dataset-name - trait-name))) - -(define view-probeset - (action "view" - (lambda (data - params) - (select-probeset (hash-ref data 'dataset) - (dict-ref params 'trait))) - '(trait))) - -(define dataset-probeset-data - (list (cons "no-access" no-access-action) - (cons "view" view-probeset))) - -(define dataset-probeset-actions - (hasheq 'data dataset-probeset-data)) ;; The dataset-probe resource type ;; Currently only read actions @@ -396,33 +287,6 @@ default-mask (hasheq))) -(define (select-probe dataset-name trait-name) - (sql-result->json - (query-row (mysql-conn) - "SELECT Probe.Sequence, Probe.Name - FROM Probe, ProbeSet, ProbeSetFreeze, ProbeSetXRef - WHERE ProbeSetXRef.ProbeSetFreezeId = ProbeSetFreeze.Id AND - ProbeSetXRef.ProbeSetId = ProbeSet.Id AND - ProbeSetFreeze.Name = ? AND - ProbeSet.Name = ? AND - Probe.ProbeSetId = ProbeSet.Id order by Probe.SerialOrder" - dataset-name - trait-name))) - -(define view-probe - (action "view" - (lambda (data - params) - (select-probe (hash-ref data 'dataset) - (hash-ref data 'trait))) - '())) - -(define dataset-probe-data - (list (cons "no-access" no-access-action) - (cons "view" view-probe))) - -(define dataset-probe-actions - (hasheq 'data dataset-probe-data)) ;; Helpers for adding new resources to Redis diff --git a/server/resource/geno.rkt b/server/resource/geno.rkt new file mode 100644 index 0000000..ec718a0 --- /dev/null +++ b/server/resource/geno.rkt @@ -0,0 +1,39 @@ +#lang racket + +(require db + redis + json + threading + "../db.rkt" + "../privileges.rkt" + "util.rkt") + +(provide dataset-geno-actions) + + +(define (select-geno dataset-name trait-name) + (sql-result->json + (query-row (mysql-conn) + "SELECT Geno.Name, Geno.Chr, Geno.Mb, Geno.Source2, Geno.Sequence + FROM Geno, GenoFreeze, GenoXRef + WHERE GenoXRef.GenoFreezeId = GenoFreeze.Id AND + GenoXRef.GenoId = Geno.Id AND + GenoFreeze.Id = ? AND + Geno.Name = ?" + dataset-name + trait-name))) + +(define view-geno + (action "view" + (lambda (data + params) + (select-geno (hash-ref data 'dataset) + (dict-ref params 'trait))) + '(trait))) + +(define dataset-geno-data + (list (cons "no-access" no-access-action) + (cons "view" view-geno))) + +(define dataset-geno-actions + (hasheq 'data dataset-geno-data)) diff --git a/server/resource/probe.rkt b/server/resource/probe.rkt new file mode 100644 index 0000000..a8321dd --- /dev/null +++ b/server/resource/probe.rkt @@ -0,0 +1,40 @@ +#lang racket + +(require db + redis + json + threading + "../db.rkt" + "../privileges.rkt" + "util.rkt") + +(provide dataset-probe-actions) + + +(define (select-probe dataset-name trait-name) + (sql-result->json + (query-row (mysql-conn) + "SELECT Probe.Sequence, Probe.Name + FROM Probe, ProbeSet, ProbeSetFreeze, ProbeSetXRef + WHERE ProbeSetXRef.ProbeSetFreezeId = ProbeSetFreeze.Id AND + ProbeSetXRef.ProbeSetId = ProbeSet.Id AND + ProbeSetFreeze.Name = ? AND + ProbeSet.Name = ? AND + Probe.ProbeSetId = ProbeSet.Id order by Probe.SerialOrder" + dataset-name + trait-name))) + +(define view-probe + (action "view" + (lambda (data + params) + (select-probe (hash-ref data 'dataset) + (hash-ref data 'trait))) + '())) + +(define dataset-probe-data + (list (cons "no-access" no-access-action) + (cons "view" view-probe))) + +(define dataset-probe-actions + (hasheq 'data dataset-probe-data)) diff --git a/server/resource/probeset.rkt b/server/resource/probeset.rkt new file mode 100644 index 0000000..06f14f4 --- /dev/null +++ b/server/resource/probeset.rkt @@ -0,0 +1,46 @@ +#lang racket + +(require db + redis + json + threading + "../db.rkt" + "../privileges.rkt" + "util.rkt") + +(provide dataset-probeset-actions) + + +(define (select-probeset dataset-name trait-name) + (sql-result->json + (query-row (mysql-conn) + "SELECT ProbeSet.Name, ProbeSet.Symbol, ProbeSet.description, ProbeSet.Probe_Target_Description, + ProbeSet.Chr, ProbeSet.Mb, ProbeSet.alias, ProbeSet.GeneId, ProbeSet.GenbankId, ProbeSet.UniGeneId, + ProbeSet.OMIM, ProbeSet.RefSeq_TranscriptId, ProbeSet.BlatSeq, ProbeSet.TargetSeq, ProbeSet.ChipId, + ProbeSet.comments, ProbeSet.Strand_Probe, ProbeSet.Strand_Gene, ProbeSet.ProteinID, ProbeSet.UniProtID, + ProbeSet.Probe_set_target_region, ProbeSet.Probe_set_specificity, ProbeSet.Probe_set_BLAT_score, + ProbeSet.Probe_set_Blat_Mb_start, ProbeSet.Probe_set_Blat_Mb_end, ProbeSet.Probe_set_strand, + ProbeSet.Probe_set_Note_by_RW, ProbeSet.flag + FROM ProbeSet, ProbeSetFreeze, ProbeSetXRef + WHERE + ProbeSetXRef.ProbeSetFreezeId = ProbeSetFreeze.Id AND + ProbeSetXRef.ProbeSetId = ProbeSet.Id AND + ProbeSetFreeze.Id = ? AND + ProbeSet.Name = ?" + dataset-name + trait-name))) + +(define view-probeset + (action "view" + (lambda (data + params) + (select-probeset (hash-ref data 'dataset) + (dict-ref params 'trait))) + '(trait))) + +(define dataset-probeset-data + (list (cons "no-access" no-access-action) + (cons "view" view-probeset))) + +(define dataset-probeset-actions + (hasheq 'data dataset-probeset-data)) diff --git a/server/resource/publish.rkt b/server/resource/publish.rkt new file mode 100644 index 0000000..94c27ff --- /dev/null +++ b/server/resource/publish.rkt @@ -0,0 +1,51 @@ +#lang racket + +(require db + redis + json + threading + "../db.rkt" + "../privileges.rkt" + "util.rkt") + +(provide dataset-publish-actions) + + +(define (select-publish dataset-id trait-name) + (sql-result->json + (query-row (mysql-conn) + "SELECT + PublishXRef.Id, InbredSet.InbredSetCode, Publication.PubMed_ID, + Phenotype.Pre_publication_description, Phenotype.Post_publication_description, Phenotype.Original_description, + Phenotype.Pre_publication_abbreviation, Phenotype.Post_publication_abbreviation, PublishXRef.mean, + Phenotype.Lab_code, Phenotype.Submitter, Phenotype.Owner, Phenotype.Authorized_Users, + Publication.Authors, Publication.Title, Publication.Abstract, + Publication.Journal, Publication.Volume, Publication.Pages, + Publication.Month, Publication.Year, PublishXRef.Sequence, + Phenotype.Units, PublishXRef.comments + FROM + PublishXRef, Publication, Phenotype, PublishFreeze, InbredSet + WHERE + PublishXRef.Id = ? AND + Phenotype.Id = PublishXRef.PhenotypeId AND + Publication.Id = PublishXRef.PublicationId AND + PublishXRef.InbredSetId = PublishFreeze.InbredSetId AND + PublishXRef.InbredSetId = InbredSet.Id AND + PublishFreeze.Id = ?" + trait-name + dataset-id))) + +(define view-publish + (action "view" + (lambda (data + params) + (select-publish (hash-ref data 'dataset) + (hash-ref data 'trait))) + '())) + +(define dataset-publish-data + (list (cons "no-access" no-access-action) + (cons "view" view-publish))) + +(define dataset-publish-actions + (hasheq 'data dataset-publish-data)) diff --git a/server/resource/util.rkt b/server/resource/util.rkt new file mode 100644 index 0000000..086c340 --- /dev/null +++ b/server/resource/util.rkt @@ -0,0 +1,28 @@ +#lang racket + +(require db + redis + json + threading + "../privileges.rkt") + +(provide no-access-action + sql-result->json) + + + +;; Function that serializes an SQL result row into a stringified JSON +;; array. Probably doesn't work with all SQL types yet!! +(define (sql-result->json query-result) + (jsexpr->bytes + (map (lambda (x) + (if (sql-null? x) 'null x)) + (vector->list query-result)))) + + +;; The general "no access" action -- may change in the future +(define no-access-action + (action "no-access" + (lambda (data params) + 'no-access) + '())) From d92690bbf7c5cfbe0ae324b2392b7d090f2110c9 Mon Sep 17 00:00:00 2001 From: Christian Date: Sun, 31 May 2020 11:50:17 -0500 Subject: [PATCH 04/19] Start of improving endpoint error handling/responses --- server/rest.rkt | 40 +++++++++++++++++++++++++++++++++++++++- 1 file changed, 39 insertions(+), 1 deletion(-) diff --git a/server/rest.rkt b/server/rest.rkt index 929ea5d..829117c 100644 --- a/server/rest.rkt +++ b/server/rest.rkt @@ -19,6 +19,42 @@ "resource.rkt") +;;;; Endpoint exception handlers + +(struct + proxy:param-error + (expected-params)) + +;; For now the handler will just return a JSON list of the expected parameters +(define (response-param-error err) + (let ((expected (proxy:param-error-expected-params err))) + (jsexpr->bytes expected))) + +(define (testing-endpoint req) + (define binds (request-bindings/raw req)) + (define expected + (proxy:param-error + (list "resource" "user" "branch" "action"))) + (define message + (let ((binds* (list (bindings-assq #"resource" binds) + (bindings-assq #"user" binds) + (bindings-assq #"branch" binds) + (bindings-assq #"action" binds)))) + (with-handlers ([proxy:param-error? + response-param-error]) + (if (ormap false? binds*) + (raise expected) + (match binds* + [(list (binding:form _ res-id) + (binding:form _ user-id) + (binding:form _ branch) + (binding:form _ action)) + "this works"]))))) + (response/output + (lambda (out) + (displayln message out)))) + + ;;;; Endpoints ;; Get a JSON representation of the action set for a resource type, @@ -121,11 +157,13 @@ (displayln message out)))) + (define-values (app reverse-uri) (dispatch-rules [("available") query-available-endpoint] [("run-action") run-action-endpoint] - [("get-action-set") get-action-set-endpoint])) + [("get-action-set") get-action-set-endpoint] + [("testing") testing-endpoint])) ;; Run the server (define stop From 48129bbd92bb7aae96a44ab7b04de623f4665e53 Mon Sep 17 00:00:00 2001 From: Christian Date: Sun, 31 May 2020 21:01:38 -0500 Subject: [PATCH 05/19] Some improvement of endpoints (wip) --- server/rest.rkt | 93 +++++++++++++++++++++++++++---------------------- 1 file changed, 52 insertions(+), 41 deletions(-) diff --git a/server/rest.rkt b/server/rest.rkt index 829117c..189f7f4 100644 --- a/server/rest.rkt +++ b/server/rest.rkt @@ -28,7 +28,10 @@ ;; For now the handler will just return a JSON list of the expected parameters (define (response-param-error err) (let ((expected (proxy:param-error-expected-params err))) - (jsexpr->bytes expected))) + (response/output + (lambda (out) + + (displayln (jsexpr->bytes expected) out))))) (define (testing-endpoint req) (define binds (request-bindings/raw req)) @@ -62,16 +65,21 @@ ;; the proxy expects the masks in a redis resource to look like (define (get-action-set-endpoint req) (define binds (request-bindings/raw req)) + (define expected + (proxy:param-error + (list "resource-type"))) (define message - (match (list (bindings-assq #"resource-type" binds)) - [(list #f) - "Provide a resource type"] + (with-handlers ([proxy:param-error? + response-param-error]) + (match (list (bindings-assq #"resource-type" binds)) + [(list #f) + (raise expected)] [(list (binding:form _ res-type)) (let ((type (dict-ref resource-types (~> res-type (bytes->string/utf-8) (string->symbol))))) - (jsexpr->bytes (action-set->hash type)))])) + (jsexpr->bytes (action-set->hash type)))]))) (response/output (lambda (out) (displayln message out)))) @@ -80,22 +88,28 @@ ;; Query available actions for a resource, for a given user (define (query-available-endpoint req) (define binds (request-bindings/raw req)) + (define expected + (proxy:param-error + (list "resource" "user"))) (define message - (match (list (bindings-assq #"resource" binds) - (bindings-assq #"user" binds)) - [(list #f #f) - "provide resource and user id"] - [(list (binding:form _ res-id) - (binding:form _ user-id)) - (let* ((res (get-resource res-id)) - (mask (get-mask-for-user - res - (bytes->string/utf-8 user-id)))) - (~> (apply-mask (dict-ref resource-types - (resource-type res)) - mask) - (action-set->hash) - (jsexpr->bytes)))])) + (let ((binds* (list (bindings-assq #"resource" binds) + (bindings-assq #"user" binds)))) + (with-handlers ([proxy:param-error? + response-param-error]) + (if (ormap false? binds*) + (raise expected) + (match binds* + [(list (binding:form _ res-id) + (binding:form _ user-id)) + (let* ((res (get-resource res-id)) + (mask (get-mask-for-user + res + (bytes->string/utf-8 user-id)))) + (~> (apply-mask (dict-ref resource-types + (resource-type res)) + mask) + (action-set->hash) + (jsexpr->bytes)))]))))) (response/output (lambda (out) (displayln message out)))) @@ -112,6 +126,9 @@ (define (run-action-endpoint req) (define binds (request-bindings/raw req)) + (define expected + (proxy:param-error + (list "resource" "branch" "action"))) (define message (match (list (bindings-assq #"resource" binds) (bindings-assq #"user" binds) @@ -120,23 +137,7 @@ [(list #f #f #f #f) "provide resource id, user id, and action to perform"] [(list (binding:form _ res-id) - #f - (binding:form _ branch) - (binding:form _ action)) - (let* ((res (get-resource res-id)) - (branch (~> branch - (bytes->string/utf-8) - (string->symbol))) - (action (bytes->string/utf-8 action))) - (let ((action (access-action res - (cons branch action)))) - (if action - (run-action action - (resource-data res) - (action-params action binds)) - "no access")))] - [(list (binding:form _ res-id) - (binding:form _ user-id) + bind-user-id (binding:form _ branch) (binding:form _ action)) (let* ((res (get-resource res-id)) @@ -144,9 +145,15 @@ (bytes->string/utf-8) (string->symbol))) (action (bytes->string/utf-8 action))) - (let ((action (access-action res - (cons branch action) - #:user (bytes->string/utf-8 user-id)))) + (let ((action (if bind-user-id + (access-action + res + (cons branch action) + #:user (bytes->string/utf-8 + (binding:form-value bind-user-id))) + (access-action + res + (cons branch action))))) (if action (run-action action (resource-data res) @@ -169,7 +176,11 @@ (define stop (serve #:dispatch (sequencer:make - (dispatch/servlet app)) + (dispatch/servlet + + (with-handlers ([proxy:param-error? + response-param-error]) + app))) #:listen-ip "127.0.0.1" #:port (string->number (or (getenv "PORT") From 19b8e30a52af68402a0f07f87516e59a011a73a1 Mon Sep 17 00:00:00 2001 From: Christian Date: Sun, 31 May 2020 21:28:20 -0500 Subject: [PATCH 06/19] Error reporting using built in servlet --- server/rest.rkt | 90 ++++++++++++++++++++----------------------------- 1 file changed, 37 insertions(+), 53 deletions(-) diff --git a/server/rest.rkt b/server/rest.rkt index 189f7f4..e1e5e37 100644 --- a/server/rest.rkt +++ b/server/rest.rkt @@ -19,40 +19,32 @@ "resource.rkt") -;;;; Endpoint exception handlers +;;;; Endpoint exceptions -(struct - proxy:param-error - (expected-params)) - -;; For now the handler will just return a JSON list of the expected parameters -(define (response-param-error err) - (let ((expected (proxy:param-error-expected-params err))) - (response/output - (lambda (out) - - (displayln (jsexpr->bytes expected) out))))) +(define (response-param-error params) + (error + (string-join params + ", " + #:before-first "Expected parameters: "))) (define (testing-endpoint req) (define binds (request-bindings/raw req)) - (define expected - (proxy:param-error + (define raise-expected + (response-param-error (list "resource" "user" "branch" "action"))) (define message (let ((binds* (list (bindings-assq #"resource" binds) (bindings-assq #"user" binds) (bindings-assq #"branch" binds) (bindings-assq #"action" binds)))) - (with-handlers ([proxy:param-error? - response-param-error]) (if (ormap false? binds*) - (raise expected) + (raise-expected) (match binds* [(list (binding:form _ res-id) (binding:form _ user-id) (binding:form _ branch) (binding:form _ action)) - "this works"]))))) + "this works"])))) (response/output (lambda (out) (displayln message out)))) @@ -65,21 +57,19 @@ ;; the proxy expects the masks in a redis resource to look like (define (get-action-set-endpoint req) (define binds (request-bindings/raw req)) - (define expected - (proxy:param-error + (define raise-expected + (response-param-error (list "resource-type"))) (define message - (with-handlers ([proxy:param-error? - response-param-error]) - (match (list (bindings-assq #"resource-type" binds)) - [(list #f) - (raise expected)] + (match (list (bindings-assq #"resource-type" binds)) + [(list #f) + (raise-expected)] [(list (binding:form _ res-type)) (let ((type (dict-ref resource-types (~> res-type (bytes->string/utf-8) (string->symbol))))) - (jsexpr->bytes (action-set->hash type)))]))) + (jsexpr->bytes (action-set->hash type)))])) (response/output (lambda (out) (displayln message out)))) @@ -88,28 +78,26 @@ ;; Query available actions for a resource, for a given user (define (query-available-endpoint req) (define binds (request-bindings/raw req)) - (define expected - (proxy:param-error + (define raise-expected + (response-param-error (list "resource" "user"))) (define message (let ((binds* (list (bindings-assq #"resource" binds) (bindings-assq #"user" binds)))) - (with-handlers ([proxy:param-error? - response-param-error]) - (if (ormap false? binds*) - (raise expected) - (match binds* - [(list (binding:form _ res-id) - (binding:form _ user-id)) - (let* ((res (get-resource res-id)) - (mask (get-mask-for-user - res - (bytes->string/utf-8 user-id)))) - (~> (apply-mask (dict-ref resource-types - (resource-type res)) - mask) - (action-set->hash) - (jsexpr->bytes)))]))))) + (if (ormap false? binds*) + (raise-expected) + (match binds* + [(list (binding:form _ res-id) + (binding:form _ user-id)) + (let* ((res (get-resource res-id)) + (mask (get-mask-for-user + res + (bytes->string/utf-8 user-id)))) + (~> (apply-mask (dict-ref resource-types + (resource-type res)) + mask) + (action-set->hash) + (jsexpr->bytes)))])))) (response/output (lambda (out) (displayln message out)))) @@ -126,16 +114,16 @@ (define (run-action-endpoint req) (define binds (request-bindings/raw req)) - (define expected - (proxy:param-error + (define raise-expected + (response-param-error (list "resource" "branch" "action"))) (define message (match (list (bindings-assq #"resource" binds) (bindings-assq #"user" binds) (bindings-assq #"branch" binds) (bindings-assq #"action" binds)) - [(list #f #f #f #f) - "provide resource id, user id, and action to perform"] + [(list #f _ #f #f) + (raise-expected)] [(list (binding:form _ res-id) bind-user-id (binding:form _ branch) @@ -176,11 +164,7 @@ (define stop (serve #:dispatch (sequencer:make - (dispatch/servlet - - (with-handlers ([proxy:param-error? - response-param-error]) - app))) + (dispatch/servlet app)) #:listen-ip "127.0.0.1" #:port (string->number (or (getenv "PORT") From e16a11df93837b7f6105d8edf8dd5be94b57fd55 Mon Sep 17 00:00:00 2001 From: Christian Date: Sun, 31 May 2020 21:56:52 -0500 Subject: [PATCH 07/19] Custom servlet responder for errors --- server/rest.rkt | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/server/rest.rkt b/server/rest.rkt index e1e5e37..89f0247 100644 --- a/server/rest.rkt +++ b/server/rest.rkt @@ -3,6 +3,7 @@ (require db redis json + net/url threading racket/match web-server/http @@ -11,6 +12,7 @@ web-server/servlet-dispatch web-server/web-server web-server/dispatch + web-server/http/response-structs (prefix-in filter: web-server/dispatchers/dispatch-filter) (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer) "db.rkt" @@ -160,11 +162,25 @@ [("get-action-set") get-action-set-endpoint] [("testing") testing-endpoint])) + +;; Servlet responder for error handling +(define (internal-server-error url ex) + (log-error "~a ~~~~> ~a" + (url->string url) + (exn-message ex)) + (response/output + (lambda (out) + (displayln (exn-message ex) out)) + + #:code 500 + #:mime-type #"application/json; charset=utf-8")) + ;; Run the server (define stop (serve #:dispatch (sequencer:make - (dispatch/servlet app)) + (dispatch/servlet app + #:responders-servlet internal-server-error)) #:listen-ip "127.0.0.1" #:port (string->number (or (getenv "PORT") From f1c7d3182664ef2ff336fdb9f4c845ce1d9462c2 Mon Sep 17 00:00:00 2001 From: Christian Date: Mon, 1 Jun 2020 18:19:03 -0500 Subject: [PATCH 08/19] Greatly simplify testing endpoint to start with --- server/rest.rkt | 26 +++++++++----------------- 1 file changed, 9 insertions(+), 17 deletions(-) diff --git a/server/rest.rkt b/server/rest.rkt index 89f0247..9f8be04 100644 --- a/server/rest.rkt +++ b/server/rest.rkt @@ -25,28 +25,20 @@ (define (response-param-error params) (error - (string-join params + (string-join (map symbol->string params) ", " #:before-first "Expected parameters: "))) (define (testing-endpoint req) - (define binds (request-bindings/raw req)) - (define raise-expected - (response-param-error - (list "resource" "user" "branch" "action"))) + (define binds (request-bindings req)) + (define expected + (list 'resource 'user 'branch 'action)) (define message - (let ((binds* (list (bindings-assq #"resource" binds) - (bindings-assq #"user" binds) - (bindings-assq #"branch" binds) - (bindings-assq #"action" binds)))) - (if (ormap false? binds*) - (raise-expected) - (match binds* - [(list (binding:form _ res-id) - (binding:form _ user-id) - (binding:form _ branch) - (binding:form _ action)) - "this works"])))) + (if (not (andmap (curryr exists-binding? binds) expected)) + (response-param-error expected) + (let ((binds* (for/hash ([x (in-list binds)]) + (values (car x) (cdr x))))) + (jsexpr->bytes binds*)))) (response/output (lambda (out) (displayln message out)))) From 2fca496fffbbf8aee83f6f17ae343551a3d7002f Mon Sep 17 00:00:00 2001 From: Christian Date: Mon, 1 Jun 2020 18:26:43 -0500 Subject: [PATCH 09/19] Simplify two more endpoints --- server/rest.rkt | 58 +++++++++++++++++++++---------------------------- 1 file changed, 25 insertions(+), 33 deletions(-) diff --git a/server/rest.rkt b/server/rest.rkt index 9f8be04..6bd5b36 100644 --- a/server/rest.rkt +++ b/server/rest.rkt @@ -50,20 +50,18 @@ ;; can be useful when resource types start changing so we know what ;; the proxy expects the masks in a redis resource to look like (define (get-action-set-endpoint req) - (define binds (request-bindings/raw req)) - (define raise-expected - (response-param-error - (list "resource-type"))) + (define binds (request-bindings req)) + (define expected (list 'resource-type)) (define message - (match (list (bindings-assq #"resource-type" binds)) - [(list #f) - (raise-expected)] - [(list (binding:form _ res-type)) - (let ((type (dict-ref resource-types - (~> res-type - (bytes->string/utf-8) - (string->symbol))))) - (jsexpr->bytes (action-set->hash type)))])) + (if (not (andmap (curryr exists-binding? binds) expected)) + (response-param-error expected) + (let* ((binds* (for/hash ([x (in-list binds)]) + (values (car x) (cdr x)))) + (res-type (hash-ref binds* 'resource-type))) + (jsexpr->bytes + (action-set->hash + (dict-ref resource-types + (string->symbol res-type))))))) (response/output (lambda (out) (displayln message out)))) @@ -71,27 +69,21 @@ ;; Query available actions for a resource, for a given user (define (query-available-endpoint req) - (define binds (request-bindings/raw req)) - (define raise-expected - (response-param-error - (list "resource" "user"))) + (define binds (request-bindings req)) + (define expected (list 'resource 'user)) (define message - (let ((binds* (list (bindings-assq #"resource" binds) - (bindings-assq #"user" binds)))) - (if (ormap false? binds*) - (raise-expected) - (match binds* - [(list (binding:form _ res-id) - (binding:form _ user-id)) - (let* ((res (get-resource res-id)) - (mask (get-mask-for-user - res - (bytes->string/utf-8 user-id)))) - (~> (apply-mask (dict-ref resource-types - (resource-type res)) - mask) - (action-set->hash) - (jsexpr->bytes)))])))) + (if (not (andmap (curryr exists-binding? binds) expected)) + (response-param-error expected) + (let* ((binds* (for/hash ([x (in-list binds)]) + (values (car x) (cdr x)))) + (res (get-resource (hash-ref binds* 'resource))) + (mask (get-mask-for-user res + (hash-ref binds* 'user)))) + (~> (apply-mask (dict-ref resource-types + (resource-type res)) + mask) + (action-set->hash) + (jsexpr->bytes))))) (response/output (lambda (out) (displayln message out)))) From 1faa22114a1c051136be217420dbb992399810a7 Mon Sep 17 00:00:00 2001 From: Christian Date: Mon, 1 Jun 2020 18:35:07 -0500 Subject: [PATCH 10/19] Even cleaner --- server/rest.rkt | 45 +++++++++++++++++++++------------------------ 1 file changed, 21 insertions(+), 24 deletions(-) diff --git a/server/rest.rkt b/server/rest.rkt index 6bd5b36..dbd3973 100644 --- a/server/rest.rkt +++ b/server/rest.rkt @@ -29,16 +29,19 @@ ", " #:before-first "Expected parameters: "))) +(define (extract-expected binds expected) + (if (not (andmap (curryr exists-binding? binds) expected)) + (response-param-error expected) + (for/hash ([x (in-list binds)]) + (values (car x) (cdr x))))) + (define (testing-endpoint req) (define binds (request-bindings req)) (define expected (list 'resource 'user 'branch 'action)) (define message - (if (not (andmap (curryr exists-binding? binds) expected)) - (response-param-error expected) - (let ((binds* (for/hash ([x (in-list binds)]) - (values (car x) (cdr x))))) - (jsexpr->bytes binds*)))) + (let ((binds* (extract-expected binds expected))) + (jsexpr->bytes binds*))) (response/output (lambda (out) (displayln message out)))) @@ -53,15 +56,12 @@ (define binds (request-bindings req)) (define expected (list 'resource-type)) (define message - (if (not (andmap (curryr exists-binding? binds) expected)) - (response-param-error expected) - (let* ((binds* (for/hash ([x (in-list binds)]) - (values (car x) (cdr x)))) - (res-type (hash-ref binds* 'resource-type))) - (jsexpr->bytes + (let* ((binds* (extract-expected binds expected)) + (res-type (hash-ref binds* 'resource-type))) + (jsexpr->bytes (action-set->hash (dict-ref resource-types - (string->symbol res-type))))))) + (string->symbol res-type)))))) (response/output (lambda (out) (displayln message out)))) @@ -72,18 +72,15 @@ (define binds (request-bindings req)) (define expected (list 'resource 'user)) (define message - (if (not (andmap (curryr exists-binding? binds) expected)) - (response-param-error expected) - (let* ((binds* (for/hash ([x (in-list binds)]) - (values (car x) (cdr x)))) - (res (get-resource (hash-ref binds* 'resource))) - (mask (get-mask-for-user res - (hash-ref binds* 'user)))) - (~> (apply-mask (dict-ref resource-types - (resource-type res)) - mask) - (action-set->hash) - (jsexpr->bytes))))) + (let* ((binds* (extract-expected binds expected)) + (res (get-resource (hash-ref binds* 'resource))) + (mask (get-mask-for-user res + (hash-ref binds* 'user)))) + (~> (apply-mask (dict-ref resource-types + (resource-type res)) + mask) + (action-set->hash) + (jsexpr->bytes)))) (response/output (lambda (out) (displayln message out)))) From 716b306470438f829d185fa95ba092656f3a1cea Mon Sep 17 00:00:00 2001 From: Christian Date: Mon, 1 Jun 2020 18:46:59 -0500 Subject: [PATCH 11/19] Finish simplifying endpoints --- server/rest.rkt | 59 ++++++++++++++----------------------------------- 1 file changed, 17 insertions(+), 42 deletions(-) diff --git a/server/rest.rkt b/server/rest.rkt index dbd3973..a19a489 100644 --- a/server/rest.rkt +++ b/server/rest.rkt @@ -88,54 +88,31 @@ (define (action-params action binds) (for/hash ([k (action-req-params action)]) - (values k - (~> k - (symbol->string) - (string->bytes/utf-8) - (bindings-assq _ binds) - (binding:form-value))))) + (values k (dict-ref binds k)))) (define (run-action-endpoint req) - (define binds (request-bindings/raw req)) - (define raise-expected - (response-param-error - (list "resource" "branch" "action"))) + (define binds (request-bindings req)) + (define expected + (list 'resource 'branch 'action)) (define message - (match (list (bindings-assq #"resource" binds) - (bindings-assq #"user" binds) - (bindings-assq #"branch" binds) - (bindings-assq #"action" binds)) - [(list #f _ #f #f) - (raise-expected)] - [(list (binding:form _ res-id) - bind-user-id - (binding:form _ branch) - (binding:form _ action)) - (let* ((res (get-resource res-id)) - (branch (~> branch - (bytes->string/utf-8) - (string->symbol))) - (action (bytes->string/utf-8 action))) - (let ((action (if bind-user-id - (access-action - res - (cons branch action) - #:user (bytes->string/utf-8 - (binding:form-value bind-user-id))) - (access-action - res - (cons branch action))))) - (if action - (run-action action - (resource-data res) - (action-params action binds)) - "no access")))])) + (let* ((binds* (extract-expected binds expected)) + (res (get-resource (hash-ref binds* 'resource))) + (branch (string->symbol (hash-ref binds* 'branch))) + (action (hash-ref binds* 'action)) + (user (hash-ref binds* 'user #f))) + (let ((action (access-action res + (cons branch action) + #:user user))) + (if action + (run-action action + (resource-data res) + (action-params action binds)) + "no access")))) (response/output (lambda (out) (displayln message out)))) - (define-values (app reverse-uri) (dispatch-rules [("available") query-available-endpoint] @@ -143,7 +120,6 @@ [("get-action-set") get-action-set-endpoint] [("testing") testing-endpoint])) - ;; Servlet responder for error handling (define (internal-server-error url ex) (log-error "~a ~~~~> ~a" @@ -152,7 +128,6 @@ (response/output (lambda (out) (displayln (exn-message ex) out)) - #:code 500 #:mime-type #"application/json; charset=utf-8")) From 7edf43acb10ec35d0870eebb13b6de32f1c73b46 Mon Sep 17 00:00:00 2001 From: Christian Date: Mon, 1 Jun 2020 21:16:00 -0500 Subject: [PATCH 12/19] Errors for resource, user, group missing from redis --- server/groups.rkt | 22 ++++++++++++++-------- server/resource.rkt | 10 +++++++--- 2 files changed, 21 insertions(+), 11 deletions(-) diff --git a/server/groups.rkt b/server/groups.rkt index 6b9697a..23a675b 100644 --- a/server/groups.rkt +++ b/server/groups.rkt @@ -23,10 +23,12 @@ ;; Retrieve the given user by ID from Redis; deserializes from JSON ;; TODO update this when we update the user struct (define (get-user dbc id) - (let ((user-hash (bytes->jsexpr - (redis-hash-ref dbc "users" id)))) - (user id - (dict-ref user-hash 'email_address)))) + (let ((user-hash (redis-hash-ref dbc "users" id))) + (if (false? user-hash) + (error (format "User not found in Redis: ~a" + id)) + (user id + (dict-ref user-hash 'email_address))))) ;; Add a user with the given ID and name to the "users" hash in Redis. @@ -56,10 +58,14 @@ ;; Retrieve the given group by ID from Redis (define (get-group dbc id) - (deserialize-group id - (redis-hash-ref dbc - "groups" - id))) + (let ((grp (redis-hash-ref dbc + "groups" + id))) + (if (false? grp) + (error (format "Group not found in Redis: ~a" + id)) + (deserialize-group id grp)))) + ;; NB: like add-user, for testing in the REPL (define (add-group dbc id admins members) diff --git a/server/resource.rkt b/server/resource.rkt index 2becb79..080c117 100644 --- a/server/resource.rkt +++ b/server/resource.rkt @@ -85,9 +85,13 @@ (define (get-resource id) - (~> (redis-hash-ref (redis-conn) "resources" id) - (deserialize-resource))) - + (let ((res (redis-hash-ref (redis-conn) + "resources" + id))) + (if (false? res) + (error (format "Resource not found in Redis: ~a" + id)) + (deserialize-resource res)))) ;; Given a resource and a user ID, derive the access mask for that user ;; based on their group membership as stored in Redis, and return From 2dd3b679cfd87edec9a113b95a55379d30bd9958 Mon Sep 17 00:00:00 2001 From: Christian Date: Tue, 2 Jun 2020 15:02:19 -0500 Subject: [PATCH 13/19] Cleaning up --- server/resource.rkt | 22 ---------------------- 1 file changed, 22 deletions(-) diff --git a/server/resource.rkt b/server/resource.rkt index 080c117..649a444 100644 --- a/server/resource.rkt +++ b/server/resource.rkt @@ -39,24 +39,6 @@ #:transparent) -;; The Racket JSON library can only transform hashes that have -;; symbol keys -- but Redis only deals with strings and bytestrings. -;; These functions transform the keys of a hash between the two. - -(define (hash-symbol->string h) - (for/hash ([(k v) (in-hash h)]) - (values (~> k - (symbol->string) - (string->bytes/utf-8)) - v))) - -(define (hash-string->symbol h) - (for/hash ([(k v) (in-hash h)]) - (values (~> k - (bytes->string/utf-8) - (string->symbol)) - v))) - ;; Serializes a resource into a JSON bytestring for storage in Redis. (define (serialize-resource res) (jsexpr->bytes (hash 'name (resource-name res) @@ -351,9 +333,5 @@ 'dataset-probeset dataset-probeset-actions 'dataset-probe dataset-probe-actions)) ;; future resource types, for reference (c.f. genenetwork datasets etc.) - ;; dataset-publish - ;; dataset-probeset - ;; dataset-probe - ;; dataset-geno ;; dataset-temp ;; collection From 115dea27e46ca4fc7745ebcb3537d27f85de0160 Mon Sep 17 00:00:00 2001 From: Christian Date: Tue, 2 Jun 2020 15:02:26 -0500 Subject: [PATCH 14/19] Fix is-mask-for? and test it --- server/privileges.rkt | 42 ++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 40 insertions(+), 2 deletions(-) diff --git a/server/privileges.rkt b/server/privileges.rkt index 096fa84..90ab4a3 100644 --- a/server/privileges.rkt +++ b/server/privileges.rkt @@ -59,8 +59,10 @@ ;; the case if both have the same keys, and each value in the mask ;; exists in the list at the corresponding key in the action set hash. (define (is-mask-for? actions mask) - (for/and ([(k v) (in-hash actions)]) - (not (false? (assoc (dict-ref mask k) v))))) + (and (for/and ([(k v) (in-hash actions)]) + (not (false? (assoc (dict-ref mask k #f) v)))) + (for/and ([(k v) (in-hash mask)]) + (not (false? (dict-ref actions k #f)))))) ;; Return the mask for an action set that provides the least possible ;; level of access, i.e. only the first action in each branch. @@ -100,3 +102,39 @@ (let ((ix (+ 1 ((mask-index v) (dict-ref mask k))))) (values k (take v ix)))) (error 'incompatible-action-mask))) + + +(module+ test + (require rackunit) + ;; is-mask-for? + (define action-set + (hasheq 'a (list (cons "a1" 'a1) + (cons "a2" 'a2)) + 'b (list (cons "b1" 'b1) + (cons "b2" 'b2)))) + (define correct-mask + (hasheq 'a "a1" + 'b "b2")) + (test-case + "Every branch in the action set is represented by the mask" + (let ((mask-missing-branch (hasheq 'a "a1"))) + (check-equal? #t + (is-mask-for? action-set + correct-mask)) + (check-equal? #f + (is-mask-for? action-set + mask-missing-branch)))) + (test-case + "Masks with additional branches are incorrect" + (let ((mask-extra-branch (hash-set correct-mask + 'c "c1"))) + (check-equal? #f + (is-mask-for? action-set + mask-extra-branch)))) + (test-case + "Masks with a branch that has an action not in the set are incorrect" + (let ((mask-wrong-action (hash-set correct-mask + 'a "a3"))) + (check-equal? #f + (is-mask-for? action-set + mask-wrong-action))))) From 2175551ba25464cca56f355091d7cfadb9a9f67a Mon Sep 17 00:00:00 2001 From: Christian Date: Tue, 2 Jun 2020 15:34:46 -0500 Subject: [PATCH 15/19] Barebones tests for min/max access masks, mask-join --- server/privileges.rkt | 45 +++++++++++++++++++++++++++++++------------ 1 file changed, 33 insertions(+), 12 deletions(-) diff --git a/server/privileges.rkt b/server/privileges.rkt index 90ab4a3..55c1821 100644 --- a/server/privileges.rkt +++ b/server/privileges.rkt @@ -118,23 +118,44 @@ (test-case "Every branch in the action set is represented by the mask" (let ((mask-missing-branch (hasheq 'a "a1"))) - (check-equal? #t - (is-mask-for? action-set - correct-mask)) - (check-equal? #f - (is-mask-for? action-set - mask-missing-branch)))) + (check-true (is-mask-for? action-set + correct-mask)) + (check-false (is-mask-for? action-set + mask-missing-branch)))) (test-case "Masks with additional branches are incorrect" (let ((mask-extra-branch (hash-set correct-mask 'c "c1"))) - (check-equal? #f - (is-mask-for? action-set - mask-extra-branch)))) + (check-false (is-mask-for? action-set + mask-extra-branch)))) (test-case "Masks with a branch that has an action not in the set are incorrect" (let ((mask-wrong-action (hash-set correct-mask 'a "a3"))) - (check-equal? #f - (is-mask-for? action-set - mask-wrong-action))))) + (check-false (is-mask-for? action-set + mask-wrong-action)))) + + ;; minimum/maximum-access-mask + (test-case + "Minimum/maximum access masks are masks for the action set" + (let ((min-mask (minimum-access-mask action-set)) + (max-mask (maximum-access-mask action-set))) + (check-true (is-mask-for? action-set min-mask)) + (check-true (is-mask-for? action-set max-mask)))) + + ;; mask-join + (test-case + "The join of a number of masks for an action set is a mask for +that action set, and is the union of the access levels" + (let ((action-set (hash-set action-set + 'c + (list (cons "c1" 'c1) + (cons "c2" 'c2)))) + (mask1 (hash-set correct-mask + 'c "c1")) + (mask2 (hash-set correct-mask + 'c "c2"))) + (let ((joined (mask-join action-set mask1 mask2))) + (check-true (is-mask-for? action-set joined)) + (check-equal? "c2" + (hash-ref joined 'c)))))) From 8ca40db680e2039064115d722b87ad422e3f648c Mon Sep 17 00:00:00 2001 From: Christian Date: Wed, 3 Jun 2020 11:36:06 -0500 Subject: [PATCH 16/19] Remove the id from the action struct; wasn't useful --- server/privileges.rkt | 3 +-- server/resource.rkt | 14 +++++--------- server/resource/geno.rkt | 3 +-- server/resource/probe.rkt | 3 +-- server/resource/probeset.rkt | 3 +-- server/resource/publish.rkt | 3 +-- server/resource/util.rkt | 3 +-- 7 files changed, 11 insertions(+), 21 deletions(-) diff --git a/server/privileges.rkt b/server/privileges.rkt index 55c1821..d134192 100644 --- a/server/privileges.rkt +++ b/server/privileges.rkt @@ -19,8 +19,7 @@ ;; See resource.rkt for examples (struct action - (id - fun + (fun req-params) #:transparent) diff --git a/server/resource.rkt b/server/resource.rkt index 649a444..f636a01 100644 --- a/server/resource.rkt +++ b/server/resource.rkt @@ -134,7 +134,7 @@ ;; Return the action, as defined by a pair of a branch name and action ;; name, for a given resource, as accessible by the given user. -;; Returns #f if the user does not have access. +;; Returns the no-access-action if the user does not have access. (define (access-action res action-pair #:user [user-id 'anonymous]) @@ -154,14 +154,12 @@ ;; Actions for file-based resources (define view-file - (action "view" - (lambda (data params) + (action (lambda (data params) (file->string (hash-ref data 'path) #:mode 'text)) '())) (define edit-file - (action "edit" - (lambda (data + (action (lambda (data params) (write-to-file (dict-ref params 'contents) (hash-ref data 'path) @@ -175,16 +173,14 @@ ;; TODO the dbc should be passed as a Racket parameter rather than an ;; action param params should be provided as keyword arguments (define view-metadata - (action "view" - (lambda (data + (action (lambda (data params) (redis-bytes-get (redis-conn) (hash-ref data 'key))) '())) (define edit-metadata - (action "edit" - (lambda (data + (action (lambda (data params) (redis-bytes-set! (redis-conn) (hash-ref data 'key) diff --git a/server/resource/geno.rkt b/server/resource/geno.rkt index ec718a0..06dcd41 100644 --- a/server/resource/geno.rkt +++ b/server/resource/geno.rkt @@ -24,8 +24,7 @@ trait-name))) (define view-geno - (action "view" - (lambda (data + (action (lambda (data params) (select-geno (hash-ref data 'dataset) (dict-ref params 'trait))) diff --git a/server/resource/probe.rkt b/server/resource/probe.rkt index a8321dd..8368997 100644 --- a/server/resource/probe.rkt +++ b/server/resource/probe.rkt @@ -25,8 +25,7 @@ trait-name))) (define view-probe - (action "view" - (lambda (data + (action (lambda (data params) (select-probe (hash-ref data 'dataset) (hash-ref data 'trait))) diff --git a/server/resource/probeset.rkt b/server/resource/probeset.rkt index 06f14f4..d752726 100644 --- a/server/resource/probeset.rkt +++ b/server/resource/probeset.rkt @@ -31,8 +31,7 @@ trait-name))) (define view-probeset - (action "view" - (lambda (data + (action (lambda (data params) (select-probeset (hash-ref data 'dataset) (dict-ref params 'trait))) diff --git a/server/resource/publish.rkt b/server/resource/publish.rkt index 94c27ff..d7cec0f 100644 --- a/server/resource/publish.rkt +++ b/server/resource/publish.rkt @@ -36,8 +36,7 @@ dataset-id))) (define view-publish - (action "view" - (lambda (data + (action (lambda (data params) (select-publish (hash-ref data 'dataset) (hash-ref data 'trait))) diff --git a/server/resource/util.rkt b/server/resource/util.rkt index 086c340..732b150 100644 --- a/server/resource/util.rkt +++ b/server/resource/util.rkt @@ -22,7 +22,6 @@ ;; The general "no access" action -- may change in the future (define no-access-action - (action "no-access" - (lambda (data params) + (action (lambda (data params) 'no-access) '())) From 6fd03beb12e1c015147148dcb6acc5f191d13165 Mon Sep 17 00:00:00 2001 From: Christian Date: Wed, 3 Jun 2020 12:19:36 -0500 Subject: [PATCH 17/19] Better errors when branch or action does not exist --- server/resource.rkt | 21 +++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/server/resource.rkt b/server/resource.rkt index f636a01..ac8cd31 100644 --- a/server/resource.rkt +++ b/server/resource.rkt @@ -144,10 +144,23 @@ (resource-default-mask res) (get-mask-for-user res user-id))) - (action-set (apply-mask (dict-ref resource-types - (resource-type res)) - mask))) - (let ((action (assoc action-id (hash-ref action-set branch-id)))) + (type (resource-type res)) + (unmasked (dict-ref resource-types type)) + (masked (apply-mask unmasked mask))) + (let ((action (assoc action-id + (hash-ref masked + branch-id + (lambda () + (error (format "Action branch '~a' does not exist in resource type '~a'" + branch-id + type))))))) + (when (false? (assoc action-id + (hash-ref unmasked + branch-id))) + (error (format "Action '~a' does not exist in branch '~a' of resource type '~a'" + action-id + branch-id + type))) (if action (cdr action) no-access-action)))) From f2bbea27ab825d4a515ff20ff1aa7f58aab52e89 Mon Sep 17 00:00:00 2001 From: Christian Date: Wed, 3 Jun 2020 12:24:13 -0500 Subject: [PATCH 18/19] Correct mime type on all endpoints, remove testing endpoint --- server/rest.rkt | 23 +++++++---------------- 1 file changed, 7 insertions(+), 16 deletions(-) diff --git a/server/rest.rkt b/server/rest.rkt index a19a489..f8c5bcb 100644 --- a/server/rest.rkt +++ b/server/rest.rkt @@ -35,17 +35,6 @@ (for/hash ([x (in-list binds)]) (values (car x) (cdr x))))) -(define (testing-endpoint req) - (define binds (request-bindings req)) - (define expected - (list 'resource 'user 'branch 'action)) - (define message - (let ((binds* (extract-expected binds expected))) - (jsexpr->bytes binds*))) - (response/output - (lambda (out) - (displayln message out)))) - ;;;; Endpoints @@ -64,7 +53,8 @@ (string->symbol res-type)))))) (response/output (lambda (out) - (displayln message out)))) + (displayln message out)) + #:mime-type #"application/json; charset=utf-8")) ;; Query available actions for a resource, for a given user @@ -83,7 +73,8 @@ (jsexpr->bytes)))) (response/output (lambda (out) - (displayln message out)))) + (displayln message out)) + #:mime-type #"application/json; charset=utf-8")) (define (action-params action binds) @@ -110,15 +101,15 @@ "no access")))) (response/output (lambda (out) - (displayln message out)))) + (displayln message out)) + #:mime-type #"application/json; charset=utf-8")) (define-values (app reverse-uri) (dispatch-rules [("available") query-available-endpoint] [("run-action") run-action-endpoint] - [("get-action-set") get-action-set-endpoint] - [("testing") testing-endpoint])) + [("get-action-set") get-action-set-endpoint])) ;; Servlet responder for error handling (define (internal-server-error url ex) From 68947cacf11748810ddf5f9c32272297b6cbb0b0 Mon Sep 17 00:00:00 2001 From: Christian Date: Wed, 3 Jun 2020 18:05:36 -0500 Subject: [PATCH 19/19] Change readme examples to be more accurate --- readme.org | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/readme.org b/readme.org index a9cee29..fe1d3f0 100644 --- a/readme.org +++ b/readme.org @@ -43,7 +43,7 @@ on the resource type. #+begin_src js { "name": "r1", - "owner_id": 0, + "owner_id": "7733c380-b83f-45de-a8b5-17e1bc3738a9", "data": { "path": "test1.txt", "metadata": "test1" }, "type": "dataset-file", @@ -77,7 +77,7 @@ action, namely viewing data. A JSON example: #+begin_src js { "name": "some-resource", - "owner_id": 0, + "owner_id": "7733c380-b83f-45de-a8b5-17e1bc3738a9", "data": { "dataset": "BXDGeno", "trait": "rs365781" }, "type": "dataset-geno", @@ -100,7 +100,7 @@ dataset-geno. A JSON example: #+begin_src js { "name": "some-resource", - "owner_id": 0, + "owner_id": "7733c380-b83f-45de-a8b5-17e1bc3738a9", "data": { "dataset": "1", "trait": "17465" }, "type": "dataset-publish",