(use-modules (json) (ice-9 match) (ice-9 format) (ice-9 iconv) (ice-9 receive) (ice-9 string-fun) (ice-9 exceptions) (srfi srfi-1) (srfi srfi-11) (srfi srfi-19) (srfi srfi-26) (rnrs io ports) (rnrs bytevectors) (web http) (web client) (web request) (web response) (web uri) (fibers web server) (gn cache memoize) (web gn-uri) (gn db sparql) (gn data species) (gn data group) (web sxml) (web view view) (web view doc) (web view markdown)) (define +global-repo+ (getenv "REPO_PATH")) (define +info+ `(("name" . "GeneNetwork REST API") ("version" ,get-version) ("comment" . "This is the official REST API for the GeneNetwork service hosted at https://genenetwork.org/") ("license" ("source code (unless otherwise specified)" . "Affero GNU Public License 3.0 (AGPL3)") ("data (unless otherwise specified)" . "Attribution-NonCommercial-NoDerivatives 4.0 International (CC BY-NC-ND 4.0)")) ("note" . "This is work in progress (WIP). Note that the final base URL will change! The temporary prefix is:") ("prefix" ,(prefix)) ("links" ("species" ,(mk-meta "species"))))) (define +info-meta+ `(("doc" ,(mk-html "info")) ("API" ((,(mk-url "species")) . "Get a list of all species") ((,(mk-url "mouse")) . "Get information on mouse") ((,(mk-url "datasets")) . "Get a list of datasets")))) (define (get-id-data id) "Get data based on identifier id. If it is a taxon return the taxon data, otherwise search for set/group data" (let ((taxoninfo (get-expanded-taxon-data id))) (if taxoninfo taxoninfo (cdr (get-group-data id))))) (define (not-found2 request) (values (build-response #:code 404) (string-append "Resource X not found: " (uri->string (request-uri request))))) (define (not-found uri) (list (build-response #:code 404) (string-append "Resource not found: " (uri->string uri)))) (define file-mime-types '(("css" text/css) ("js" text/javascript) ("svg" image/svg+xml) ("png" image/png) ("gif" image/gif) ("jpg" image/jpg) ("woff" application/font-woff) ("ttf" application/octet-stream) ("map" text/json) ("html" text/html))) (define (file-extension file-name) (last (string-split file-name #\.))) (define* (render-static-image file-name #:key (extra-headers '())) (let* ((stat (stat file-name #f)) (modified (and stat (make-time time-utc 0 (stat:mtime stat))))) (list `((content-type ,(assoc-ref file-mime-types (file-extension file-name))) (last-modified ,(time-utc->date modified))) (call-with-input-file file-name get-bytevector-all)))) (define* (render-static-file path #:optional rec #:key (extra-headers '())) (let* ((stat (stat path #f)) (modified (and stat (make-time time-utc 0 (stat:mtime stat))))) (list `((content-type ,(assoc-ref file-mime-types (file-extension path))) (last-modified ,(time-utc->date modified))) (call-with-input-file path get-bytevector-all)))) (define* (render-doc path page #:optional rec #:key (extra-headers '())) (list (append extra-headers '((content-type text/html))) (lambda (port) (sxml->html (view-doc path page rec) port)))) (define* (render-brand path #:optional rec #:key (extra-headers '())) (list (append extra-headers '((content-type text/html))) (lambda (port) (sxml->html (view-brand path) port)))) (define (render-json json) (list '((content-type application/json)) (lambda (port) (scm->json json port)))) (define (render-json-string2 json) (list '((content-type text/plain)) (lambda (port) (format port "~a" "foo")))) (define (build-json-response status-code json) (list (build-response #:code status-code #:headers `((content-type application/json))) (lambda (port) (scm->json json port)))) (define (decode-request-json body) (if (not body) '() (json-string->scm (utf8->string body)))) (define (decode-query-component component) (let* ((index (string-index component #\=)) (key (if index (substring component 0 index) component)) (value (if index (substring component (1+ index)) ""))) (cons (string->symbol (uri-decode key)) (uri-decode value)))) (define (edit-file-handler repo request) (catch 'file-error (lambda () (let* ((query (uri-query (request-uri request))) (params (if (not query) '() (map decode-query-component (string-split query #\&)))) (query-path (assoc-ref params 'file_path))) (if query-path (build-json-response 200 (fetch-file repo query-path)) (throw 'file-error "Please provide a valid file path in the query")))) (lambda (key . args) (let ((msg (car args))) (build-json-response 400 `(("error" ,key) ("msg" ,msg))))))) (define (invalid-data? data target) (if (string? (assoc-ref data target)) (if (string-null? (assoc-ref data target)) (throw 'system-error (format #f "Value for Key *** ~a *** Cannot be Empty" target)) (assoc-ref data target)) (throw 'system-error (format #f "The Key *** ~a *** is missing in your Json Data" target)))) (define (commit-file-handler repo request body) (catch 'system-error (lambda () (let* ((post-data (decode-request-json body)) (_ (for-each (lambda (target) (invalid-data? post-data target)) '("filename" "content" "username" "email" "prev_commit"))) (file-name (assoc-ref post-data "filename")) (content (assoc-ref post-data "content")) (username (assoc-ref post-data "username")) (email (assoc-ref post-data "email")) (commit-message (assoc-ref post-data "commit_message")) (prev-commit (assoc-ref post-data "prev_commit"))) (build-json-response 200 (commit-file repo file-name content commit-message username email prev-commit)))) (lambda (key . args) (let ((msg (car args))) (build-json-response 400 `(("error" ,key) ("msg" ,msg))))))) (define (controller request body) (match-lambda (('GET) (render-json +info+)) (('GET "version") (render-json get-version)) (('GET "css" fn) (render-static-file (string-append "css/" fn))) (('GET "map" fn) (render-static-file (string-append "css/" fn))) (('GET "static" "images" fn) (render-static-image (string-append "static/images/" fn))) (('GET "home" path) (render-brand path)) (('GET "doc" "species.html") (render-doc "doc" "species.html" (get-species-meta))) (('GET "doc" taxon) (match (string->list taxon) ((name ... #\. #\h #\t #\m #\l) (render-doc "doc" taxon (get-expanded-taxon-meta (list->string name)))))) (('GET "doc" path ... page) ;; serve documents from /doc/ (render-doc path page)) (('GET "species.json") (render-json (get-species-data))) (('GET "species.meta.json") (render-json (get-species-meta))) (('GET "species") (render-json (get-species-meta))) (('GET "edit") (edit-file-handler +global-repo+ request)) (('POST "commit") (commit-file-handler +global-repo+ request body)) (('GET id) (let ((names (get-species-shortnames (get-expanded-species)))) (match (string->list id) ((name ... #\. #\m #\e #\t #\a #\. #\j #\s #\o #\n) (render-json (get-expanded-taxon-meta (list->string name)))) ((name ... #\. #\j #\s #\o #\n) (render-json (get-id-data (list->string name)))) (rest (render-json "NOP"))))) (_ (not-found (request-uri request))))) (define (request-path-components request) (split-and-decode-uri-path (uri-path (request-uri request)))) (define (handler request body) (format #t "~a ~a\n" (request-method request) (uri-path (request-uri request))) (apply values ((controller request body) (cons (request-method request) (request-path-components request))))) (define (start-web-server address port) (format (current-error-port) "GN REST API web server listening on http://~a:~a/~%" address port) ;; Wrap handler in another function to support live hacking via the ;; REPL. If handler is passed as is and is then redefined via the ;; REPL, the web server will still be using the old handler. The ;; only way to update the handler reference held by the web server ;; would be to restart the web server. (run-server (cut handler <> <>) #:addr (inet-pton AF_INET address) #:port port)) (define (main args) (write (string-append "Starting Guile REST API " get-version " server!")) (write args) (newline) (let ((listen (inexact->exact (string->number (car (cdr args)))))) (display `("listening on" ,listen)) (start-web-server "127.0.0.1" listen)))