#!/usr/bin/env guile \ -e main -s !# ;; Minimal web server can be started from command line. Current example routes: ;; ;; localhost:8080/ ;; (use-modules (json) (ice-9 match) (ice-9 format) (ice-9 iconv) (ice-9 receive) (ice-9 string-fun) (ice-9 exceptions) ;; (ice-9 debugger) ;; (ice-9 breakpoints) ;; (ice-9 source) (srfi srfi-1) (srfi srfi-11) ; let-values (srfi srfi-19) ; time (srfi srfi-26) (rnrs io ports) ; bytevector-all (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 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))))) ;; ---- REST API web server handler (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-query query) (if (not query) '() (map decode-query-component (string-split query #\&)))) (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* ((params (decode-query (uri-query (request-uri request)))) (query_path (assoc-ref params 'file_path))) (if query_path (build-json-response 400 (fetch-file repo query_path)) (throw 'file-error (string-append "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 global-repo (getenv "REPO_PATH")) ;; handle this better way (define (is-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) (is-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)))