path: root/web/webserver.scm

(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 +info+
  `(("name" . "GeneNetwork REST API") ("version" unquote 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" unquote
     (prefix))
    ("links" ("species" unquote
              (mk-meta "species")))))

(define +info-meta+
  `(("doc" unquote
     (mk-html "info"))
    ("API" ((unquote (mk-url "species")) . "Get a list of all species")
     ((unquote (mk-url "mouse")) . "Get information on mouse")
     ((unquote (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 unquote
                          (assoc-ref file-mime-types
                                     (file-extension file-name)))
            (last-modified unquote
                           (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 unquote
                          (assoc-ref file-mime-types
                                     (file-extension path)))
            (last-modified unquote
                           (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 400
                                      (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" unquote key)
                                    ("msg" unquote msg)))))))

(define +global-repo+
  (getenv "REPO_PATH"))

(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" unquote key)
                                    ("msg" unquote 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)))