;;; Copyright © 2018 Julien Lepiller <address@hidden>
;;; Copyright © 2018 swedebugia <address@hidden>
;;;
;;; This file is part of guile-npm-explorer.
;;;
;;; guile-npm-explorer is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; guile-npm-explorer is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with guile-npm-explorer.  If not, see <http://www.gnu.org/licenses/>.

;; Usage:
;; $guile -s npm-explorer.scm >mocha.dot (later you pipe these
;; dot-files into graphviz to produce the actual graph.
;;
;; or
;;
;; Do it all at once:
;; guile -s npm-explorer.scm |dot -Tsvg > mocha.svg
;;
;; or
;;
;; Do it all at once and show it with no nonsense in between:
;; guile -s npm-explorer.scm |dot -Tsvg > mocha.svg && eog mocha.svg

(define-module (npm-explorer) 
  #:use-module (guix import json)
  #:use-module (guix build utils)
  #:use-module (guix import utils)
  #:use-module (guix http-client)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-34)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 textual-ports)
  #:use-module (json)
  #:export (output-dot
	    ;; for debugging:
	    parse-semver
	    cache-handler
	    generate-dot))

;; from
;; https://gitlab.com/swedebugia/guix/blob/08fc0ec6fa76d95f4b469aa85033f1b0148f7fa3/guix/import/npm.scm
;; imported here unchanged because it is not avaliable in upstream guix yet.
(define (node->package-name name)
    "Given the NAME of a package on npmjs, return a Guix-compliant
name for the
package. We remove the '@' and keep the '/' in scoped
packages. E.g. @mocha/test -> node-mocha/test"
    (cond ((and (string-prefix? "@" name)
		(string-prefix? "node-" name))
	   (snake-case (string-drop name 1)))
	  ((string-prefix? "@" name)
	            (string-append "node-" (snake-case (string-drop
							name 1))))
	  ((string-prefix? "node-" name)
	   (snake-case name))
	  (else
	   (string-append "node-" (snake-case name)))))

(define (slash->_ name)
  "Sanitize slashes to avoid cli-problems"
  (if (string-match "[/]" name)
      (regexp-substitute #f (string-match "/+" name)
			 'pre "_slash_" 'post)
      ;;else
      name))

;; FIXME this does not return #f if the file is empty.
(define (read-file file)
  "RETURN hashtable from JSON-file in cache."
  (if (< (stat:size (stat file)) 10)
      ;; size is less than 10 bytes, return #f
      #f
      ;; return file parsed to hashtables with (json)
      (call-with-input-file file
	(lambda (port)
	  (json->scm port)))))

;; from
;; http://git.savannah.gnu.org/cgit/guix.git/tree/guix/import/json.scm
;; adapted to return unaltered JSON
(define* (npm-http-fetch url
                     ;; Note: many websites returns 403 if we omit a
                     ;; 'User-Agent' header.
                     #:key (headers `((user-agent . "GNU Guile")
                                      (Accept . "application/json"))))
  "Return a JSON resource URL, or
#f if URL returns 403 or 404.  HEADERS is a list of HTTP headers to pass in
the query."
  (guard (c ((and (http-get-error? c)
                  (let ((error (http-get-error-code c)))
                    (or (= 403 error)
                        (= 404 error))))
             #f))
    (let* ((port   (http-fetch url #:headers headers))
	      ;; changed the upstream here to return unaltered json:
              (result (get-string-all port)))
      (close-port port)
      result)))

(define (cache-handler name)
  "Check if cached in cache-dir. RETURN direct from cache or fetch and return
from cache."
  (let* ((cache-dir (string-append (getenv "HOME") "/.cache/npm-explorer"))
	 ;; sanitize name to fit in cli-context on disk
	 ;; it can contain @ and /
	 (cache-name (slash->_ (node->package-name name)))
	 (filename (string-append cache-dir "/" cache-name ".package.json")))
    (if (file-exists? filename)
	;;yes
	;;check if empty
	(if (read-file filename)
	    (read-file filename)
	    ;;file empty
	    (begin
	      (format
	       (current-error-port)
	       "cache for ~a was empty, trying to download again..." name)
	      (delete-file filename)
	      ;; call handler again to try fetching again
	      (cache-handler name)))
	;;no
	(begin
	  (when (not (directory-exists? cache-dir))
	    (mkdir-p cache-dir))
	  ;; port closes when this closes
	  (call-with-output-file filename
	    (lambda (port)
	      (format port "~a"
		      ;; this gives os the result-closure and we write it out
		      (npm-http-fetch
		       (string-append
			"https://registry.npmjs.org/"
			name)))))
	  ;; get the content and close
	  (read-file filename)))))

;; FIXME consider even the patch versions.
;; See https://stackoverflow.com/questions/22343224/whats-the-difference-between-tilde-and-caret-in-package-json
(define (parse-semver hashtable version)
  "return the newest version within the same major or minor version"
  (define (split list)
    (string-split list #\.))
  (define (version-list hashtable)
    (map split
	 (map first
	      (hash-table->alist (hash-ref hashtable "versions")))))
  (define (major list)
    (first list))
  (define (minor list)
    (second list))
  (define (minor->number list)
    (string->number (minor (split list))))
  ;; Return latest minor with same major version.
  ;; e.g. ^1.1.0 -> 1.4.0 even though 2.0.0 is availiable
  (let* ((version (split (string-drop version 1)))
	 (version-list
	  (map first
	       (hash-table->alist (hash-ref hashtable "versions"))))
	 (same-major
	  (if (equal? 3 (length version))
	      (fold
	       ;; recurse through version-list
	       (lambda (ver lst)
		 (if (string-prefix? (major version) ver)
		     (cons ver lst)
		     lst))
	       '()
	       version-list)
	      ;; not a version triplet
	      #f)))
    ;; From
    ;; https://www.gnu.org/software/guile/manual/html_node/SRFI_002d1-Fold-and-Map.html#SRFI_002d1-Fold-and-Map
    (fold-right
     (lambda (str prev)
       (if (> (minor->number str) (minor->number prev))
      	   str
      	   prev))
     ;;init with 0.0.0 work with minor->number
     "0.0.0"
     same-major)))

;;debug
;; (display (parse-semver (cache-handler "request") "~1.87.0"))
;; (display (parse-semver (cache-handler "request") "^1.1.0"))

(define (choose-version hashtable version)
  (cond
   ((or (string-prefix? "*" version)
	(string-prefix? "~" version))
    "latest")
   ;; Specific version needed. This is rare...
   ((string-prefix? "=" version)
    (string-drop version 1))
   ;; Conditionally later versions
   ((string-prefix? "^" version)
    (if (parse-semver hashtable version)
	(parse-semver hashtable version)
	;; could not parse
	(error (string-append "parse-semver: could not parse" version))))
   (else
    ;; FIXME: could this default to "latest"?
    ;; No recognized prefix. Return the version specified.
    version)))

(define (lookup-latest hashtable)
  "RETURN string with the latest release version."
  (hash-ref (hash-ref hashtable "dist-tags") "latest"))

(define (extract-version hashtable version)
  "Return extract from hashtable corresponding to version or #f if not
found."
  (cond
   ((string-prefix? "^" version)
    (parse-semver hashtable version))
   ((or
     (equal? version "latest")
     (equal? version "*"))
    (let ((latest (hash-ref (hash-ref hashtable "dist-tags") "latest")))
      (hash-ref (hash-ref hashtable "versions") latest)))
   (else
    ;;extract the version specified
    (hash-ref (hash-ref hashtable "versions") version))))

(define (extract-deps hashtable version)
  "Return extract of dependencies from hashtable corresponding to
version or #f if none."
  (cond
   ((or
     (equal? version "latest")
     (equal? version "*"))
    (let* ((latest (lookup-latest hashtable))
	  (data (hash-ref (hash-ref hashtable "versions") latest)))
      (hash-ref data "dependencies")))
   (else
    ;;extract the version specified
    (let ((data (hash-ref (hash-ref hashtable "versions") version)))
      (hash-ref data "dependencies")))))

(define* (output-dot name
		    #:optional
		    (version "latest"))
  (begin
    (format #t "digraph dependencies {~%")
    (format #t "overlap=false;~%")
    (format #t "splines=true;~%")
    (generate-dot name '() 0 version)
    (format (current-error-port) "~%")
    (format #t "}~%")))

;;test
;;(output-dot "mocha") ;broken

;; Originally from Julien.
;; This is 
;; Heavily modified to get specific version.
(define* (generate-dot name done level
		       #:optional
		       (version "latest"))
  "RETURN package count and level to std-error and dot-formatted data
to std-out."

  ;;
  ;; Internal definitions
  ;;

  (define (status-line level acc)
    (format
     (current-error-port)
     "level ~a: ~a packages    \r" level (length acc)))
  
  (define (dot-line name version key value)
    (format #t
	    "\"address@hidden" -> \"address@hidden";~%"
	    name version key value))

  ;; Note, this was factored out because it got too hard to overview
  ;; given the limitations on line length.
  (define (my-catch package-hashtable wanted-version)
    "Extract the version from the hashtable and recurse through the
dependencies calling generate-dot each time until done. The output
from format are sent to current-error-port (status information) and
current-output (dot-line)."
    (catch #t
      ;; Thunk
      (lambda ()
	(let* (	;; Extract dependencies corresponding to version
	       (dependencies (extract-deps package-hashtable wanted-version)))
	  (if dependencies
	      ;; Fold through all the elements in the
	      ;; hashtable
	      (hash-fold
	       (lambda (key value acc)
		 ;; key value = name and version-string
		 ;; directly from the hashtable
		 (begin
	    	   (status-line level acc)
	    	   (if (equal? "latest" wanted-version)
		       ;; lookup latest
		       (let ((latest
			      (lookup-latest package-hashtable)))
			 (dot-line name latest key value))
		       ;; no lookups needed
		       (dot-line name wanted-version key value)))
		 ;; call recursively with the version
		 ;; of the dep from the hashtable
	    	 (generate-dot		;closure of lambda
		  key acc (+ 1 level) value))
	       ;; fold recursive - closure of hash-fold
	       (cons name done) dependencies)
	      ;; else, add to done
	      (cons name done))))
      ;; Handler if thunk throws #t
      ;; not found!
      (lambda _
	(error
	 (string-append
	  "something went wrong. please report an issue here:
https://gitlab.com/swedebugia/guile-npm-explorer/issues")))))

  ;;
  ;; Entry
  ;; 

  (if (member name done)
      done
      ;; Convert return from cache to hashtable instead of fetching
      ;; everything multiple times for packages with shared dependency
      ;; tails. This results in a significant speedup when file is in
      ;; the cache.
      ;; NOTE: The cache has no TTL implemented yet so you should
      ;; clear it from to time manually if you want newer versions to appear.
      (let* ((package-hashtable (cache-handler name))
	     ;; Choose latest version
	     (wanted-version (choose-version package-hashtable version))
	     ;; Extract hashtable corresponding to version
	     (extracted-version (extract-version package-hashtable wanted-version)))
	;; Process the version specified if found
	(if extracted-version
	    (my-catch package-hashtable wanted-version)
	    ;; else
	    (cons name done)))))

;; (format #t "digraph dependencies {~%")
;; (format #t "overlap=false;~%")
;; (format #t "splines=true;~%")
(generate-dot "mocha" '() 0 version)
;; (format (current-error-port) "~%")
;; (format #t "}~%")