#!/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"))

(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)))