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", 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/privileges.rkt b/server/privileges.rkt index a7badd0..d134192 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 @@ -18,8 +19,7 @@ ;; See resource.rkt for examples (struct action - (id - fun + (fun req-params) #:transparent) @@ -40,6 +40,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. @@ -49,8 +58,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. @@ -90,3 +101,60 @@ (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-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-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-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)))))) diff --git a/server/resource.rkt b/server/resource.rkt index 9d8d16d..ac8cd31 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 @@ -34,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) @@ -80,9 +67,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 @@ -143,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]) @@ -153,33 +144,35 @@ (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)))) - ;; (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" - (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) @@ -193,16 +186,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) @@ -243,52 +234,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 +249,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 +264,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 +282,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 @@ -483,9 +342,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 diff --git a/server/resource/geno.rkt b/server/resource/geno.rkt new file mode 100644 index 0000000..06dcd41 --- /dev/null +++ b/server/resource/geno.rkt @@ -0,0 +1,38 @@ +#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 (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..8368997 --- /dev/null +++ b/server/resource/probe.rkt @@ -0,0 +1,39 @@ +#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 (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..d752726 --- /dev/null +++ b/server/resource/probeset.rkt @@ -0,0 +1,45 @@ +#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 (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..d7cec0f --- /dev/null +++ b/server/resource/publish.rkt @@ -0,0 +1,50 @@ +#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 (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..732b150 --- /dev/null +++ b/server/resource/util.rkt @@ -0,0 +1,27 @@ +#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 (lambda (data params) + 'no-access) + '())) diff --git a/server/rest.rkt b/server/rest.rkt index 888e793..f8c5bcb 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 @@ -10,6 +11,8 @@ web-server/http/bindings 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" @@ -18,103 +21,113 @@ "resource.rkt") +;;;; Endpoint exceptions + +(define (response-param-error params) + (error + (string-join (map symbol->string params) + ", " + #: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))))) + + ;;;; 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 req)) + (define expected (list 'resource-type)) + (define message + (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)))))) + (response/output + (lambda (out) + (displayln message out)) + #:mime-type #"application/json; charset=utf-8")) + + ;; 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 binds (request-bindings req)) + (define expected (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) - (masked-actions) - (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)))) + (displayln message out)) + #:mime-type #"application/json; charset=utf-8")) -(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)]) - (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 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 #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) - (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) - #:user (bytes->string/utf-8 user-id)))) - (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)))) + (displayln message out)) + #:mime-type #"application/json; charset=utf-8")) + -(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])) + +;; 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 - (filter:make #rx"^/available/" - query-available-dispatcher) - (filter:make #rx"^/run-action/" - run-action-dispatcher)) + (dispatch/servlet app + #:responders-servlet internal-server-error)) #:listen-ip "127.0.0.1" #:port (string->number (or (getenv "PORT")