(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)
             (config)
             (config api)
             (config parser sexp)
             (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) "")))

;; Look into moving this into a config file.
(define +local-repo-checkout-path+ (getenv "CURRENT_REPO_PATH"))
(define +remote-repo-url+ (getenv "CGIT_REPO_PATH"))
(define +working-branch+ (getenv "GN_GUILE_WORKING_BRANCH"))

(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 local-repo working-branch 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
                 (begin
                   (git-invoke local-repo "fetch" "origin" working-branch)
                   (git-invoke local-repo "reset" "--hard"
                               (string-append "origin/" working-branch))
                   (build-json-response 200
                                        (fetch-file local-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 +local-repo-checkout-path+
							 file-name
							 content
							 commit-message
							 username
							 email
							 prev-commit)))
				       (git-invoke +local-repo-checkout-path+ "push" +remote-repo-url+)
				       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 +local-repo-checkout-path+ +working-branch+ request))
    (('POST "commit")
     (commit-file-handler +local-repo-checkout-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 string->exact (compose inexact->exact string->number))

(define (user-port? parsed)
  ;; (let ((parsed (string->exact val))))
  (and (positive? parsed) (>= parsed 1024) (<= parsed 49151)))


(define (parse-cli-options cmd-line)
  (let ((config (configuration (name 'gn-guile)
                               (synopsis "gn-guile web service: provide services
 to main Genenetwork service.")
                               (description "gn-guile web service is a small
service, written in GNU Guile, that provides some functionality to the main
Genenetwork service in the background. This is not meant for direct user
interaction.")
                               (keywords (list
                                          (switch (name 'write)
                                                  (default #f)
                                                  (test boolean?)
                                                  (character #f))
                                          (setting (name 'port)
                                                   (default 8091)
                                                   (test user-port?)
                                                   (handler string->exact))
                                          (setting (name 'remote-url)
                                                   (default "git@git.genenetwork.org:/home/git/public/gn-docs")
                                                   (test string?))
                                          (setting (name 'local-repo-path)
                                                   (default (string-append (dirname (getcwd)) "/gn-guile-files/gn-docs"))
                                                   (test file-exists?))))
                               (parser sexp-parser)
                               (directory (list (in-cwd ".instance/"))))))
    (getopt-config-auto cmd-line config)))

(define (main args)
  (write (string-append "Starting Guile REST API " get-version " server!"))
  (write args)
  (newline)
  (let* ((options (parse-cli-options args))
         (listen (option-ref options 'port)))
    (when (option-ref options 'write)
      (options-write options))
    (display `("listening on" ,listen))
    (start-web-server "127.0.0.1" listen)))