#!/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 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 (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)) (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)) ("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-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) ;; (display "ThthxST" port) (format port "~a" "foo") ))) (define (controller request body) (match-lambda (('GET) (render-json info)) (('GET "version") (render-json get-version)) (('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 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)) ;; (write listen) ;; (run-server hello-world-handler 'http `(#:port ,listen)))) (start-web-server "127.0.0.1" listen)))