#lang racket/base
(require db/private/pre
         racket/format
         racket/serialize
         "main-doc.rkt")

(provide doc-db-available?
         doc-db-clear-provides
         doc-db-add-provides
         doc-db-set-provides-timestamp
         doc-db-get-provides-timestamp
         doc-db-clear-dependencies
         doc-db-add-dependencies
         doc-db-clear-searches
         doc-db-add-searches
         doc-db-key->path
         doc-db-key->path+pkg
         doc-db-check-duplicates
         doc-db-check-unsatisfied
         doc-db-get-dependencies
         doc-db-file->connection
         doc-db-disconnect
         doc-db-clean-files
         doc-db-init-pause
         doc-db-pause
         log-doc-db-info)

(define-logger doc-db)

(define (doc-db-available?)
  (sqlite3-available?))

(define (doc-db-file->connection db-file [write? #f])
  (define exists? (file-exists? db-file))
  (define db (sqlite3-connect #:database db-file 
                              #:mode (if write? 'create 'read-only)
                              #:busy-retry-limit 0))
  (unless exists?
    (call-with-retry/transaction
     'prepare-tables
     db
     #t
     (lambda ()
       (prepare-tables db))))
  ;; we don't need to survive a catastrophic failure:
  (call-with-retry
   'synchronous-off
   db
   (lambda ()
     (query-exec db "pragma synchronous = off")))
  db)

(define (doc-db-disconnect db)
  (disconnect db))

(define select-pathid-vq
  (virtual-statement "SELECT pathid FROM documented WHERE stag=$1"))

(define select-path+pkg-vq
  (virtual-statement "SELECT atmain, path, pkg FROM pathids WHERE pathid=$1"))
(define select-other-path+pkg-vq
  (virtual-statement "SELECT atmain, path, pkg FROM other.pathids WHERE pathid=$1"))
(define select-path-vq
  (virtual-statement "SELECT atmain, path, '' FROM pathids WHERE pathid=$1"))
(define select-other-path-vq
  (virtual-statement "SELECT atmain, path, '' FROM other.pathids WHERE pathid=$1"))

(define (doc-db-init-pause)
  0.01)
(define (doc-db-pause who pause)
  (log-doc-db-info "database locked at ~a; now waiting ~a seconds" 
                   who
                   pause)
  (sleep pause)
  (min 2 (* 2 pause)))

(define (call-with-database who db-file proc 
                            #:write? [write? #f]
                            #:setup [setup void]
                            #:teardown [teardown void])
  (define db (if (connection? db-file)
                 db-file
                 (doc-db-file->connection db-file write?)))
  (setup db)
  (begin0
   (call-with-retry/transaction
    who
    db
    write?
    (lambda () (proc db)))
   (teardown db)
   (unless (connection? db-file)
     (disconnect db))))

(define (doc-db-key->path db-file key
                          #:main-doc-relative-ok? [main-doc-relative-ok? #f])
  (define-values (path pkg) (doc-db-key->path+pkg db-file key
                                                  #:main-doc-relative-ok? main-doc-relative-ok?))
  path)

(define (doc-db-key->path+pkg db-file key
                              #:main-doc-relative-ok? [main-doc-relative-ok? #f])
  (call-with-database
   'doc-db-key->path
   db-file
   (lambda (db)
     (define rows (query-rows db select-pathid-vq
                              (->string key)))
     (define pathid (and (pair? rows)
                         (vector-ref (car rows) 0)))
     (cond
       [pathid
        (pathid->filename+pkg db pathid #f main-doc-relative-ok?)]
       [else
        (values #f #f)]))))

(define (add who db-file elems filename pkg callback)
  (call-with-database
   who
   db-file
   #:write? #t
   (lambda (db)
     (prepare-tables db)
     (define pathid (filename->pathid db filename #:pkg pkg))
     (for ([p (in-list elems)])
       (define stag (->string p))
       (callback db stag pathid)))))

(define (clear who db-file filename pkg statement)
  (call-with-database
   who
   db-file
   #:write? #t
   (lambda (db)
     (prepare-tables db)
     (define pathid (filename->pathid db filename #:pkg pkg))
     (query-exec db statement
                 pathid))))

(define (doc-db-add-provides db-file provides filename #:pkg [pkg #f])
  (add 'doc-db-add-provides
       db-file provides filename pkg
       (lambda (db stag pathid)
         (query-exec db "INSERT INTO documented VALUES ($1, $2)"
                     stag
                     pathid))))
       

(define (doc-db-clear-provides db-file filename #:pkg [pkg #f])
  (clear 'doc-db-clear-provides
         db-file filename pkg
         "DELETE FROM documented WHERE pathid=$1"))

(define (doc-db-set-provides-timestamp db-file filename seconds #:pkg [pkg #f])
  (call-with-database
   'doc-db-set-provides-timestamp
   db-file
   #:write? #t
   (lambda (db)
     (prepare-tables db)
     (define pathid (filename->pathid db filename #:pkg pkg))
     (query-exec db "DELETE FROM timestamps WHERE pathid=$1"
                 pathid)
     (query-exec db "INSERT INTO timestamps VALUES ($1, $2)"
                 pathid seconds))))

(define (doc-db-get-provides-timestamp db-file filename)
  (call-with-database
   'doc-db-get-provides-timestamp
   db-file
   (lambda (db)
     (define pathid (filename->pathid db filename #f))
     (define row
       (query-maybe-row db (~a "SELECT seconds FROM timestamps"
                               " WHERE pathid=$1")
                        pathid))
     (and row (vector-ref row 0)))))

(define (doc-db-add-dependencies db-file depends filename #:pkg [pkg #f])
  (add 'doc-db-add-dependencies
       db-file depends filename pkg
       (lambda (db stag pathid)
         (query-exec db "INSERT INTO dependencies VALUES ($1, $2)"
                     pathid
                     stag))))


(define (doc-db-clear-dependencies db-file filename #:pkg [pkg #f])
  (clear 'doc-db-clear-dependencies
         db-file filename pkg
         "DELETE FROM dependencies WHERE pathid=$1"))

(define (doc-db-add-searches db-file searches filename #:pkg [pkg #f])
  (call-with-database
   'doc-db-add-searches
   db-file
   #:write? #t
   (lambda (db)
     (prepare-tables db)
     (define pathid (filename->pathid db filename #:pkg pkg))
     (for ([(sk s) (in-hash searches)]
           [setid (in-naturals)])
       (query-exec db "INSERT INTO searchSets VALUES ($1, $2, $3)"
                   pathid
                   setid
                   (->string sk))
       (for ([k (in-hash-keys s)])
         (define stag (->string k))
         (query-exec db "INSERT INTO searches VALUES ($1, $2, $3)"
                     pathid
                     setid
                     stag))))))

(define (doc-db-clear-searches db-file filename #:pkg [pkg #f])
  (call-with-database
   'doc-db-clear-searches
   db-file
   #:write? #t
   (lambda (db)
     (prepare-tables db)
     (define pathid (filename->pathid db filename #:pkg pkg))
     (query-exec db "DELETE FROM searchSets WHERE pathid=$1"
                 pathid)
     (query-exec db "DELETE FROM searches WHERE pathid=$1"
                 pathid))))

(define (maybe-attach attach-db-path)
  (lambda (db)
    (when attach-db-path
      (attach-db db attach-db-path))))
(define (maybe-detach attach-db-path)
  (lambda (db)
    (when attach-db-path
      (detach-db db attach-db-path))))

(define (doc-db-check-duplicates db-file
                                 #:attach [attach-db-path #f]
                                 #:main-doc-relative-ok? [main-doc-relative-ok? #f])
  (call-with-database
   'doc-db-check-duplicates
   db-file
   #:setup (maybe-attach attach-db-path)
   #:teardown (maybe-detach attach-db-path)
   (lambda (db)
     (define rows
       (append
        (query-rows db (~a "SELECT stag"
                           " FROM documented"
                           " GROUP BY stag"
                           " HAVING COUNT(pathid) > 1"))
        (if attach-db-path
            ;; duplicates across tables:
            (query-rows db (~a "SELECT D.stag"
                               " FROM documented D, other.documented OD"
                               " WHERE D.stag = OD.stag"
                               " GROUP BY D.stag"))
            null)))
     (for/list ([row (in-list rows)])
       (define stag (vector-ref row 0))
       (define pathid-rows (query-rows db (~a "SELECT pathid"
                                              " FROM documented"
                                              " WHERE stag=$1")
                                       stag))
       (define other-pathid-rows 
         (if attach-db-path
             (query-rows db (~a "SELECT pathid"
                                " FROM other.documented"
                                " WHERE stag=$1")
                         stag)
             null))
       (cons (<-string (if (bytes? stag)
                           (open-input-bytes stag)
                           (open-input-string stag)))
             (append
              (for/list ([pathid-row (in-list pathid-rows)])
                (pathid->filename db (vector-ref pathid-row 0) #f main-doc-relative-ok?))
              (for/list ([pathid-row (in-list other-pathid-rows)])
                (pathid->filename db (vector-ref pathid-row 0) #t main-doc-relative-ok?))))))))

(define (doc-db-check-unsatisfied filename db-file
                                  #:attach [attach-db-path #f])
  (call-with-database
   'doc-db-check-unsatisfied
   db-file
   #:setup (maybe-attach attach-db-path)
   #:teardown (maybe-detach attach-db-path)
   (lambda (db)
     (define pathid (filename->pathid db filename #f))
     ;; Items with no `searches' entries:
     (define rows
       (query-rows db (~a "SELECT P.stag "
                          " FROM dependencies P"
                          " LEFT OUTER JOIN documented D ON D.stag = P.stag"
                          " LEFT OUTER JOIN searches S ON S.stag = P.stag"
                          (if attach-db-path
                              (~a " LEFT OUTER JOIN other.documented OD ON OD.stag = P.stag"
                                  " LEFT OUTER JOIN other.searches OS ON OS.stag = P.stag")
                              "")
                          " WHERE P.pathid = $1"
                          " AND   D.stag IS NULL"
                          " AND   S.stag is NULL"
                          (if attach-db-path
                              (~a " AND   OD.stag IS NULL"
                                  " AND   OS.stag is NULL")
                              ""))
                   pathid))
     ;; Items with `searches' entries, but no documentation:
     (define more-rows
       (query-rows db (~a "SELECT SS.stag "
                          " FROM searchSets SS"
                          " WHERE SS.pathid = $1"
                          " AND NOT EXISTS"
                          " (SELECT S.stag"
                          "  FROM documented D, searches S"
                          "  WHERE D.stag = S.stag"
                          "  AND   S.setid = SS.setid"
                          "  AND   S.pathid = SS.pathid)"
                          (if attach-db-path
                              (~a " AND NOT EXISTS"
                                  " (SELECT S.stag"
                                  "  FROM other.documented OD, searches S"
                                  "  WHERE OD.stag = S.stag"
                                  "  AND   S.setid = SS.setid"
                                  "  AND   S.pathid = SS.pathid)")
                              "")
                          " GROUP BY SS.stag")
                   pathid))
     (map (lambda (s)
            (<-string (open-input-string (vector-ref s 0))))
          (append
           rows
           more-rows)))))

(define (attach-db db attach-db-path)
  (query-exec db "ATTACH $1 AS other"
              (path->bytes (cleanse-path 
                            (path->complete-path attach-db-path)))))
(define (detach-db db attach-db-path)
  (query-exec db "DETACH other"))
               

(define (doc-db-get-dependencies filename db-file
                                 #:attach [attach-db-path #f]
                                 #:main-doc-relative-ok? [main-doc-relative-ok? #f]
                                 #:include-tags? [include-tags? #f])
  (call-with-database
   'doc-db-get-dependencies
   db-file
   #:setup (maybe-attach attach-db-path)
   #:teardown (maybe-detach attach-db-path)
   (lambda (db)
     (define pathid (filename->pathid db filename #f))
     (define ((rows->paths in-other?) rows)
       (for/list ([row (in-list rows)])
         (define v (pathid->filename db (vector-ref row 0) in-other? main-doc-relative-ok?))
         (if include-tags?
             (cons v (vector-ref row 1))
             v)))
     (append
      ((rows->paths #f)
       (query-rows db (~a "SELECT D.pathid, D.stag"
                          " FROM dependencies P, documented D"
                          " WHERE P.pathid = $1"
                          "   AND D.stag = P.stag"
                          " GROUP BY D.pathid")
                   pathid))
      (if attach-db-path
          ((rows->paths #t)
           (query-rows db (~a "SELECT D.pathid, D.stag "
                              " FROM dependencies P, other.documented D"
                              " WHERE P.pathid = $1"
                              "   AND D.stag = P.stag"
                              " GROUP BY D.pathid")
                       pathid))
          null)))))

(define (doc-db-clean-files db-file ok-files)
  (call-with-database
   'doc-db-clean-files
   db-file
   #:write? #t
   (lambda (db)
     (prepare-tables db)
     (define rows (query-rows db "SELECT atmain, path, pathid FROM pathids"))
     (for ([row (in-list rows)])
       (define bstr (vector-ref row 1))
       (define path (cond
                     [(equal? "y" (vector-ref row 0))
                      (main-doc-relative->path
                       (cons 'doc (or (hash-ref reader-cache bstr #f)
                                      (let ([v (<-string (open-input-bytes bstr))])
                                        (hash-set! reader-cache bstr v)
                                        v))))]
                     [(bytes? bstr)
                      (bytes->path bstr)]
                     [else ; "placeholder"
                      #f]))
       (unless (or (not path)
                   (hash-ref ok-files path #f))
         (define pathid (vector-ref row 2))
         (query-exec db "DELETE FROM documented WHERE pathid=$1"
                     pathid)
         (query-exec db "DELETE FROM timestamps WHERE pathid=$1"
                     pathid)
         (query-exec db "DELETE FROM searches WHERE pathid=$1"
                     pathid)
         (query-exec db "DELETE FROM searchSets WHERE pathid=$1"
                     pathid)
         (query-exec db "DELETE FROM dependencies WHERE pathid=$1"
                     pathid)
         (query-exec db "DELETE FROM pathids WHERE pathid=$1"
                     pathid)
         (query-exec db "INSERT INTO pathids VALUES ($1, 'n', 'placeholder', '')"
                     pathid))))))
         

(define (filename->pathid db filename [write? #t] #:pkg [pkg #f])
  (define filename* (path->main-doc-relative filename))
  (define filename-bytes (cond
                          [(pair? filename*)
                           (string->bytes/utf-8 (->string (cdr filename*)))]
                          [(path? filename*)
                           (path->bytes filename*)]
                          [else (path->bytes (string->path filename*))]))
  (define id (query-maybe-row db
                              (~a "SELECT pathid, " (if write? "pkg" "''") " FROM pathids"
                                  " WHERE atmain=$1 AND path=$2")
                              (if (pair? filename*) "y" "n")
                              filename-bytes))
  (cond
   [(not id)
    (define num (vector-ref (query-row db "SELECT COUNT(pathid) FROM pathids") 0))
    (when write?
      (query-exec db "INSERT INTO pathids VALUES ($1, $2, $3, $4)"
                  (add1 num)
                  (if (pair? filename*) "y" "n")
                  filename-bytes
                  (or pkg "")))
    ;; If we can't write, then this result is bogus, but it should lead
    ;; to empty query results in a transaction:
    (add1 num)]
   [(and write? pkg (let ([pkg (vector-ref id 1)])
                      (and (not (equal? pkg ""))
                           (not (sql-null? pkg))
                           pkg)))
    ;; Transitioning from table before pkg was included?
    (define pathid (vector-ref id 0))
    (query-exec db "DELETE FROM pathids where pathid = $1" pathid)
    (query-exec db "INSERT INTO pathids VALUES ($1, $2, $3, $4)"
                pathid
                (if (pair? filename*) "y" "n")
                filename-bytes
                pkg)
      pathid]
   [else (vector-ref id 0)]))

(define reader-cache (make-weak-hash))

(define (pathid->filename+pkg db pathid in-other? main-doc-relative-ok?)
  (define row (query-maybe-row db
                               (if (old-pathids-table? db)
                                   (if in-other?
                                       select-other-path-vq
                                       select-path-vq)
                                   (if in-other?
                                       select-other-path+pkg-vq
                                       select-path+pkg-vq))
                               pathid))
  (if row
      (let ([path (vector-ref row 1)]
            [pkg (vector-ref row 2)])
        (values
         (if (equal? "y" (vector-ref row 0))
             ((if main-doc-relative-ok? values main-doc-relative->path)
              (cons 'doc (or (hash-ref reader-cache path #f)
                             (let ([v (<-string (open-input-bytes path))])
                               (hash-set! reader-cache path v)
                               v))))
             (bytes->path path))
         (and (not (equal? pkg ""))
              (not (sql-null? pkg))
              pkg)))
      (values #f #f)))

(define (pathid->filename db pathid in-other? main-doc-relative-ok?)
  (define-values (path pkg) (pathid->filename+pkg db pathid in-other? main-doc-relative-ok?))
  path)

(define (prepare-tables db)
  (when (null? 
         (query-rows db (~a "SELECT name FROM sqlite_master"
                            " WHERE type='table' AND name='documented'")))
    (query-exec db (~a "CREATE TABLE documented "
                       "(stag VARCHAR(256),"
                       " pathid SMALLINT,"
                       " UNIQUE (stag, pathid))"))
    (query-exec db (~a "CREATE INDEX documentedStags "
                       "on documented (stag)"))
    (query-exec db (~a "CREATE TABLE dependencies "
                       "(pathid SMALLINT,"
                       " stag VARCHAR(256))"))
    (query-exec db (~a "CREATE TABLE searchSets "
                       "(pathid SMALLINT, "
                       " setid SMALLINT, "
                       " stag VARCHAR(256),"
                       " PRIMARY KEY (pathid, setid))"))
    (query-exec db (~a "CREATE TABLE searches "
                       "(pathid SMALLINT,"
                       " setid SMALLINT, "
                       " stag VARCHAR(256))"))
    (query-exec db (~a "CREATE TABLE pathids "
                       "(pathid SMALLINT,"
                       " atmain CHAR(1),"
                       " path VARCHAR(1024),"
                       " pkg VARCHAR(1024),"
                       " PRIMARY KEY (pathid))"))
    (query-exec db (~a "CREATE INDEX dependenciesPath "
                       "on dependencies (pathid)"))
    (query-exec db (~a "CREATE INDEX searchSetsPath "
                       "on searchSets (pathid)"))
    (query-exec db (~a "CREATE INDEX searchesTag "
                       "on searches (stag)"))
    (query-exec db (~a "CREATE INDEX searchesPathId "
                       "on searches (pathid, setid)")))
  (when (null? 
         (query-rows db (~a "SELECT name FROM sqlite_master"
                            " WHERE type='table' AND name='timestamps'")))
    (query-exec db (~a "CREATE TABLE timestamps "
                       "(pathid SMALLINT,"
                       " seconds BIGINT,"
                       " PRIMARY KEY (pathid))")))
  (when (old-pathids-table? db)
    (query-exec db "ALTER TABLE pathids ADD COLUMN pkg VARCHAR(1024)")))

(define (old-pathids-table? db)
  (= 3 (length (query-rows db (~a "pragma table_info(pathids)")))))

(define (exn:fail:retry? v)
  (and (exn:fail:sql? v)
       (let ([s (exn:fail:sql-sqlstate v)])
         (or (eq? s 'busy)
             (eq? s 'ioerr-blocked)
             (eq? s 'ioerr-lock)
             ;; The `SQLITE_READONLY_ROLLBACK` result is supposed
             ;; to mean that a hot journal exists due to a crash,
             ;; but it seems to happen even without crashes, so
             ;; treat it is a reason to retry:
             (eq? s 'readonly-rollback)))))

(define (call-with-lock-handler handler thunk)
  (with-handlers* ([exn:fail:retry?
                    (lambda (exn) (handler))])
    (thunk)))

(define (call-with-retry/transaction who db write? thunk)
  (let loop ([pause (doc-db-init-pause)])
    ((let/ec esc
       (define at-commit? #f)
       (define success? #f)
       (dynamic-wind
        (lambda ()
          (call-with-lock-handler
           (lambda () (esc (lambda ()
                             (loop (doc-db-pause `(start ,who) pause)))))
           (lambda () (start-transaction db #:option (if write? 'immediate #f)))))
        (lambda ()
          (call-with-lock-handler
           (lambda () (esc (lambda ()
                             (loop (doc-db-pause `(,(if at-commit? 'commit 'query)
                                                   ,who)
                                                 pause)))))
           (lambda ()
             (define l (call-with-values thunk list))
             (set! at-commit? #t)
             (commit-transaction db)
             (set! success? #t)
             (lambda () (apply values l)))))
        (lambda ()
          (unless success?
            (rollback db 1))))))))

(define (rollback db count)
  (when (in-transaction? db)
    (with-handlers* ([exn:fail:retry?
                      (lambda (exn)
                        (log-doc-db-info "database locked on rollback; tried ~a times so far"
                                         count)
                        (rollback db (add1 count)))])
      (rollback-transaction db))))

(define (call-with-retry who db thunk)
  (let loop ([pause (doc-db-init-pause)])
    (call-with-lock-handler
     (lambda () (loop (doc-db-pause `(query ,who) pause)))
     thunk)))

(define (readable? s)
  (or (string? s)
      (bytes? s)
      (symbol? s)
      (number? s)
      (boolean? s)
      (and (list? s) (andmap readable? s))
      (and (vector? s) (for/and ([v (in-vector s)]) (readable? s)))))

(define (->string v)
  (if (and (not (box? v))
           (readable? v))
      (~s v)
      (~s (box (serialize v)))))

(define (<-string p)
  (with-handlers ([exn:fail:read?
                   (lambda (exn)
                     (error 'read
                            (~a "error unmarshaling from database\n"
                                "  original error: ~e")
                            (exn-message exn)))])
    (define v (read p))
    (if (box? v)
        ;; A box indicates serialization:
        (deserialize (unbox v))
        ;; Normal value:
        v)))
