(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-13)
(srfi srfi-19)
(srfi srfi-26)
(rnrs io ports)
(rnrs bytevectors)
(web http)
(web client)
(web request)
(web response)
(web uri)
(web server)
(gn cache memoize)
(web gn-uri)
(gn db sparql)
(gn data dataset)
(gn data species)
(gn data group)
(gn runner gemma)
(web sxml)
(web view view)
(web view doc)
(web view markdown))
(define (get-extension filename)
(let ((dot-pos (string-rindex filename #\.)))
(if dot-pos
(substring filename dot-pos) "")))
(define +current-repo-path+
(getenv "CURRENT_REPO_PATH"))
(define +cgit-repo-path+
(getenv "CGIT_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 (get-bxd-publish)
"Return a list of published datasets by their record ID. We add the dataset ID and phenotype ID for quick reference"
(list->vector (get-bxd-publish-list)))
(define* (get-bxd-publish-dataid-values dataid #:optional used-for-mapping?)
(get-bxd-publish-dataid-name-value-dict dataid used-for-mapping?))
(define* (get-bxd-publish-values dataid #:optional used-for-mapping?)
(get-bxd-publish-name-value-dict dataid used-for-mapping?))
(define (get-gene-aliases genename)
"Return a vector of aliases for genename."
(list->vector (memo-sparql-wd-gene-aliases (memo-sparql-wd-geneids genename))))
(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 #\.))) ;; FIXME: does not handle files with multiple dots
(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-string str)
(list '((content-type application/txt))
(lambda (port)
(put-string port str))))
(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 (render-sparql request prefix val)
(let* ((mime (negotiate-mime request))
(resp-mime (if (or (string-contains (symbol->string mime) "html")
(string-contains (symbol->string mime) "microdata"))
'text/html
mime)))
(receive (sparql-header sparql-resp)
(sparql-http-get
(or (getenv "SPARQL-ENDPOINT") "http://localhost:8890/sparql/")
(sparql-by-term prefix val)
(symbol->string mime))
(list `((content-type ,resp-mime))
(lambda (port)
(let ((resp (if (string? sparql-resp)
sparql-resp
(utf8->string sparql-resp))))
(put-string port resp)))))))
(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
((lambda ()
(let ((message
(commit-file +current-repo-path+
file-name
content
commit-message
username
email
prev-commit)))
(git-invoke +current-repo-path+ "push" +cgit-repo-path+)
message))))))
(lambda (key . args)
(let ((msg (car args)))
(build-json-response 400
`(("error" . ,key)
("msg" . ,msg)))))))
(define (negotiate-mime request)
(let* ((headers (request-headers request))
(accept (caar (assoc-ref headers 'accept))))
(if (or (eq? (string->symbol "*/*") accept)
(eq? (string->symbol "text/html") accept))
'application/x-nice-microdata
accept)))
(define (controller request body)
(match-lambda
(('GET)
(render-json +info+))
(('GET "version")
(render-json get-version))
(('GET "css" fn)
(render-static-file (string-append (dirname (current-filename)) "/css/" fn)))
(('GET "map" fn)
(render-static-file (string-append (dirname (current-filename)) "/css/" fn)))
(('GET "static" "images" fn)
(render-static-image (string-append (dirname (current-filename)) "/static/images/" fn)))
(('GET "home" path)
(render-brand path)) ; branding route for /home/aging, /home/msk etc
(('GET "home" "aging" path)
(render-brand (string-append "aging/" path))) ; branding route subs of /home/aging/...
(('GET "dataset" "bxd-publish" "list")
(render-json (get-bxd-publish)))
(('GET "dataset" "bxd-publish" "dataid" "values" page)
(match (get-extension page)
(".json"
(render-json (get-bxd-publish-dataid-values (basename page ".json"))))
(else (display "ERROR: unknown file extension"))))
(('GET "dataset" "bxd-publish" "values" page)
(match (get-extension page)
(".json"
(render-json (get-bxd-publish-values (basename page ".json"))))
;; (".tsv" (render-string "TEST1\nTEST2"))
;; (".gemma" (render-string (string-join (gemma-pheno-txt "BXD" (get-bxd-publish-values (basename page ".gemma"))) "")))
(else (display "ERROR: unknown file extension"))))
(('GET "dataset" "bxd-publish" "mapping" "values" (string-append dataid ".json"))
(render-json (get-bxd-publish-values dataid #t)))
(('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 "gene" "aliases" genename)
(render-json (get-gene-aliases genename)))
(('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 +current-repo-path+ request))
(('POST "commit")
(commit-file-handler +current-repo-path+ 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")))))
;; RDF End-points
(('GET "v1" "id" id)
(render-sparql request 'gn id))
(('GET "v1" "category" category)
(render-sparql request 'gnc category))
(('GET "v1" "term" term)
(render-sparql request 'gnt term))
(_ (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 <> <>)
'http
(list #: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)))
