(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 +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 (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
((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 (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)) ; branding route for /home/aging, /home/msk etc
(('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 +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")))))
(_ (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)))
