(use-modules (rnrs io ports)
             (srfi srfi-1)
             (srfi srfi-26)
             (srfi srfi-28)
             (srfi srfi-71)
             (srfi srfi-171)
             (ice-9 match)
             (sxml simple)
             (sparql driver)
             (sparql lang)
             (sparql util)
             (dump string-similarity)
             (dump table))

(define rdfs
  (prefix "http://www.w3.org/2000/01/rdf-schema#"))

(define rdf
  (prefix "http://www.w3.org/1999/02/22-rdf-syntax-ns#"))

(define gn
  (prefix "http://genenetwork.org/"))

(define (sparql-query-records . args)
  ;; TODO: Use the JSON query results so that types can be converted
  ;; correctly.
  (query-results->list (apply sparql-query
                              (append args
                                  (list #:host "127.0.0.1"
                                        #:port 8891)))
                       #t))

(define (floor-log1024 x)
  "Return the floor of the base 1024 logarithm of X."
  (if (< x 1024)
      0
      (1+ (floor-log1024 (/ x 1024)))))

(define (human-units bytes)
  "Return number of BYTES as a string with human-readable units."
  (let* ((integer-log (floor-log1024 bytes)))
    (format "~a ~a"
            (round-quotient bytes (expt 1024 (min integer-log 3)))
            (case integer-log
              ((0) "B")
              ((1) "KiB")
              ((2) "MiB")
              (else "GiB")))))

(define (human-units-color bytes)
  "Return the table header color coding for a table of size BYTES."
  (let* ((color-scheme "purd4"))
    (format "/~a/~a"
            color-scheme
            (1+ (min (floor-log1024 bytes) 3)))))

(define (sxml->xml-string tree)
  "Serialize sxml TREE to a string. Return the serialized string."
  (call-with-output-string
    (cut sxml->xml tree <>)))

(define (sxml->graphviz-html tree)
  "Convert sxml TREE to a graphviz <html-string>, and return it."
  ((@@ (ccwl graphviz) html-string) (sxml->xml-string tree)))

(define (table-label table)
  "Return HTML string label for TABLE."
  (sxml->graphviz-html
   `(table (@ (cellborder 0)
              (bgcolor "white"))
           (tr (td (@ (border 1)
                      (bgcolor ,(human-units-color (table-size table))))
                   ,(format "~a (~a)"
                            (table-name table)
                            (human-units (table-size table)))))
           ,@(map (lambda (column)
                    `(tr (td (@ (port ,(column-name column)))
                             ,(column-name column))))
                  (table-columns table)))))

(define (string-remove-suffix-ci suffix str)
  "Remove SUFFIX from STR if present. Suffix check is
case-insensitive."
  (if (string-suffix-ci? suffix str)
      (substring str 0 (- (string-length str)
                          (string-length suffix)))
      str))

(define (column->foreign-table table column all-tables)
  "If COLUMN in TABLE is a foreign key, return the table it refers to. Else,
return #f. ALL-TABLES is a list of all tables in the database."
  (cond
   ((and (string=? (column-name column) "UserId")
         (string=? (table-name table) "UserPrivilege"))
    'User)
   ((string-ci=? (column-name column) "GenbankID")
    'Genbank)
   ((not (or (string-prefix? "int" (column-type column))
             (string-prefix? "smallint" (column-type column))))
    #f)
   ((let ((string-similarity-threshold 0.8)
          (target-table
           (or (and=> (find (lambda (suffix)
                              (string-suffix-ci? suffix (column-name column)))
                            (list "id1" "id2" "_id" "id"))
                      (cut string-remove-suffix-ci <> (column-name column)))
               (column-name column))))
      (and (not (jaccard-string-similar? target-table
                                         (table-name table)))
           (find (lambda (table)
                   (jaccard-string-similar?
                    target-table (table-name table)))
                 all-tables)))
    => table-name)
   (else #f)))

(define (tables)
  "Return list of all tables in DB. Each element of the returned list
is a <table> object."
  (map (match-lambda
         ((table size fields field-types field-dumped)
          (make-table table
                      (string->number size)
                      (map make-column
                           (string-split fields #\,)
                           (string-split field-types #\,)
                           (map (cut string=? <> "1")
                                (string-split field-dumped #\,))))))
       (sparql-query-records
        "PREFIX gn: <http://genenetwork.org/>
SELECT SAMPLE(?tablename) SAMPLE(?size) GROUP_CONCAT(?fieldname ; separator=\",\") GROUP_CONCAT(?fieldtype ; separator=\",\") GROUP_CONCAT(EXISTS{ ?dump rdf:type gn:dump . ?dump gn:dependsOn ?field .} ; separator=\",\")
WHERE
{
  ?table rdf:type gn:sqlTable ;
         gn:name ?tablename ;
         gn:hasSize ?size ;
         gn:hasField ?field .
  ?field rdf:type gn:sqlTableField ;
         gn:name ?fieldname ;
         gn:sqlFieldType ?fieldtype .
} GROUP BY ?table")))

(define (foreign-key-graphviz-edges tables)
  "Return the list of graphviz edges representing foreign key
relations in TABLES."
  (append-map (lambda (table)
                (filter-map (lambda (column)
                              (and=> (column->foreign-table table column tables)
                                     (cut cons
                                          ((@@ (ccwl graphviz) graph-port)
                                           (table-name table)
                                           (column-name column))
                                          <>)))
                            (table-columns table)))
              tables))

(let ((all-tables (tables)))
  ((@@ (ccwl graphviz) graph->dot)
   ((@@ (ccwl graphviz) graph) 'schema
    #:nodes (map (lambda (table)
                   ((@@ (ccwl graphviz) graph-node)
                    (table-name table)
                    `((shape . "none")
                      (label . ,(table-label table)))))
                 all-tables)
    #:edges (foreign-key-graphviz-edges all-tables))))