fc54bbba3c
This termonology change affects lots of function names from `pkg/lib' and `pkg/db' (former `pkg/pnr-db'), and it also affects some `raco pkg' commands. Existing package installations that are marked as 'pnr in a local configuration are converted automatically to 'catalog, but any existing "indexes" configuration must be changed to "catalogs".
522 lines
17 KiB
Racket
522 lines
17 KiB
Racket
#lang racket/base
|
|
(require racket/contract/base
|
|
racket/format
|
|
racket/set
|
|
racket/path
|
|
racket/file
|
|
db)
|
|
|
|
(provide
|
|
(struct-out pkg)
|
|
(contract-out
|
|
[current-pkg-catalog-file
|
|
(parameter/c path-string?)]
|
|
|
|
[get-catalogs (-> (listof string?))]
|
|
[set-catalogs! ((listof string?) . -> . void?)]
|
|
|
|
[set-pkgs! ((string? (listof (or/c pkg? string?)))
|
|
(#:clear-other-checksums? boolean?)
|
|
. ->* .
|
|
void?)]
|
|
|
|
[get-pkgs (()
|
|
(#:name (or/c #f string?)
|
|
#:catalog (or/c #f string?))
|
|
. ->* .
|
|
(listof pkg?))]
|
|
[set-pkg! ((string? string? string? string? string? string?)
|
|
(#:clear-other-checksums? boolean?)
|
|
. ->* .
|
|
void?)]
|
|
|
|
[get-pkg-modules (string? string? string?
|
|
. -> . (listof module-path?))]
|
|
[set-pkg-modules! (string? string? string?
|
|
(listof module-path?)
|
|
. -> . void?)]
|
|
|
|
[get-pkg-tags (string? string?
|
|
. -> . (listof string?))]
|
|
[set-pkg-tags! (string? string? (listof string?)
|
|
. -> . void?)]
|
|
|
|
[get-module-pkgs (module-path? . -> . (listof pkg?))]
|
|
|
|
[get-pkgs-without-modules (()
|
|
(#:catalog string?)
|
|
. ->* .
|
|
(listof pkg?))]))
|
|
|
|
(struct pkg (name catalog author source checksum desc)
|
|
#:transparent)
|
|
|
|
(define (prepare-catalog-table db)
|
|
(prepare-table db
|
|
"catalog"
|
|
(~a "(id SMALLINT,"
|
|
" url TEXT,"
|
|
" pos SMALLINT)")))
|
|
|
|
(define (prepare-pkg-table db)
|
|
(prepare-table db
|
|
"pkg"
|
|
(~a "(name TEXT,"
|
|
" catalog SMALLINT,"
|
|
" author TEXT,"
|
|
" source TEXT,"
|
|
" checksum TEXT,"
|
|
" desc TEXT)")))
|
|
|
|
(define (prepare-tags-table db)
|
|
(prepare-table db
|
|
"tags"
|
|
(~a "(pkg TEXT,"
|
|
" catalog TEXT,"
|
|
" tag TEXT)")))
|
|
|
|
(define (prepare-modules-table db)
|
|
(prepare-table db
|
|
"modules"
|
|
(~a "(name TEXT,"
|
|
" pkg TEXT,"
|
|
" catalog SMALLINT,"
|
|
" checksum TEXT)")))
|
|
|
|
(define current-pkg-catalog-file
|
|
(make-parameter (build-path
|
|
(find-system-path 'addon-dir)
|
|
(version)
|
|
"pkgs"
|
|
"catalog.sqlite")))
|
|
|
|
(define (call-with-catalog-db proc)
|
|
(define db #f)
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(define file (current-pkg-catalog-file))
|
|
(define dir (path-only file))
|
|
(unless (directory-exists? dir)
|
|
(make-directory* dir))
|
|
(set! db (sqlite3-connect #:database file
|
|
#:mode 'create
|
|
#:busy-retry-limit +inf.0)))
|
|
(lambda () (proc db))
|
|
(lambda ()
|
|
(disconnect db))))
|
|
|
|
(define (get-pkgs #:name [name #f]
|
|
#:catalog [catalog #f])
|
|
(call-with-catalog-db
|
|
(lambda (db)
|
|
(prepare-catalog-table db)
|
|
(prepare-pkg-table db)
|
|
(for/list ([row (in-list
|
|
(apply
|
|
query-rows
|
|
db
|
|
(~a "SELECT K.name, N.url, K.author, K.source, K.checksum, K.desc"
|
|
" FROM pkg K, catalog N"
|
|
" WHERE N.id = K.catalog"
|
|
(if catalog
|
|
" AND N.url = $1"
|
|
"")
|
|
(if name
|
|
(~a " AND K.name = "
|
|
(if catalog "$2" "$1"))
|
|
"")
|
|
" ORDER BY N.pos")
|
|
(append
|
|
(if catalog
|
|
(list catalog)
|
|
null)
|
|
(if name
|
|
(list name)
|
|
null))))])
|
|
(pkg (vector-ref row 0)
|
|
(vector-ref row 1)
|
|
(vector-ref row 2)
|
|
(vector-ref row 3)
|
|
(vector-ref row 4)
|
|
(vector-ref row 5))))))
|
|
|
|
(define (set-pkg! name catalog author source checksum desc
|
|
#:clear-other-checksums? [clear-other-checksums? (not (equal? checksum ""))])
|
|
(call-with-catalog-db
|
|
(lambda (db)
|
|
(prepare-catalog-table db)
|
|
(prepare-pkg-table db)
|
|
(call-with-transaction
|
|
db
|
|
(lambda ()
|
|
(define catalog-id (url->catalog db catalog))
|
|
(query db
|
|
(~a "UPDATE pkg"
|
|
" SET author=$1, source=$2, checksum=$3, desc=$4"
|
|
" WHERE name=$5"
|
|
" AND catalog=$6")
|
|
author source checksum desc
|
|
name catalog-id)
|
|
(when clear-other-checksums?
|
|
(query-exec db
|
|
(~a "DELETE FROM modules"
|
|
" WHERE catalog=$1 AND pkg=$2 AND checksum<>$3")
|
|
catalog-id
|
|
name
|
|
checksum))
|
|
(void))))))
|
|
|
|
(define (get-pkg-tags name catalog)
|
|
(call-with-catalog-db
|
|
(lambda (db)
|
|
(prepare-catalog-table db)
|
|
(prepare-pkg-table db)
|
|
(prepare-tags-table db)
|
|
(define catalog-id (url->catalog db catalog))
|
|
(query-list db
|
|
(~a "SELECT tag FROM tags"
|
|
" WHERE catalog=$1"
|
|
" AND pkg=$2")
|
|
catalog-id
|
|
name))))
|
|
|
|
(define (set-pkg-tags! name catalog tags)
|
|
(call-with-catalog-db
|
|
(lambda (db)
|
|
(prepare-catalog-table db)
|
|
(prepare-pkg-table db)
|
|
(prepare-tags-table db)
|
|
(call-with-transaction
|
|
db
|
|
(lambda ()
|
|
(define catalog-id (url->catalog db catalog))
|
|
(query-exec db
|
|
(~a "DELETE FROM tags"
|
|
" WHERE catalog=$1"
|
|
" AND pkg=$2")
|
|
catalog-id
|
|
name)
|
|
(for ([tag (in-list tags)])
|
|
(query db
|
|
(~a "INSERT INTO tags"
|
|
" VALUES ($1, $2, $3)")
|
|
name catalog-id tag)))))))
|
|
|
|
(define (get-pkg-modules name catalog checksum)
|
|
(call-with-catalog-db
|
|
(lambda (db)
|
|
(prepare-catalog-table db)
|
|
(prepare-pkg-table db)
|
|
(prepare-modules-table db)
|
|
(define catalog-id (url->catalog db catalog))
|
|
(map
|
|
string->mod
|
|
(query-list db
|
|
(~a "SELECT name FROM modules"
|
|
" WHERE catalog=$1"
|
|
" AND pkg=$2"
|
|
" AND checksum=$3")
|
|
catalog-id
|
|
name
|
|
checksum)))))
|
|
|
|
(define (set-pkg-modules! name catalog checksum modules)
|
|
(call-with-catalog-db
|
|
(lambda (db)
|
|
(prepare-catalog-table db)
|
|
(prepare-pkg-table db)
|
|
(prepare-modules-table db)
|
|
(call-with-transaction
|
|
db
|
|
(lambda ()
|
|
(define catalog-id (url->catalog db catalog))
|
|
(query-exec db
|
|
(~a "DELETE FROM modules"
|
|
" WHERE catalog=$1"
|
|
" AND pkg=$2"
|
|
" AND checksum=$3")
|
|
catalog-id
|
|
name
|
|
checksum)
|
|
(for ([mod (in-list modules)])
|
|
(query db
|
|
(~a "INSERT INTO modules"
|
|
" VALUES ($1, $2, $3, $4)")
|
|
(mod->string mod) name catalog-id checksum)))))))
|
|
|
|
(define (get-module-pkgs mod)
|
|
(call-with-catalog-db
|
|
(lambda (db)
|
|
(define rows
|
|
(query-rows db
|
|
(~a "SELECT M.pkg, P.url, M.checksum"
|
|
" FROM modules M, catalog P"
|
|
" WHERE M.name = $1"
|
|
" AND M.catalog = P.id")
|
|
(mod->string mod)))
|
|
(for/list ([row (in-list rows)])
|
|
(pkg (vector-ref row 0)
|
|
(vector-ref row 1)
|
|
""
|
|
""
|
|
(vector-ref row 2)
|
|
"")))))
|
|
|
|
(define (mod->string mp) (~s mp))
|
|
(define (string->mod str) (read (open-input-string str)))
|
|
|
|
(define (get-pkgs-without-modules #:catalog [catalog #f])
|
|
(call-with-catalog-db
|
|
(lambda (db)
|
|
(prepare-catalog-table db)
|
|
(prepare-pkg-table db)
|
|
(prepare-modules-table db)
|
|
(define rows
|
|
(apply
|
|
query-rows
|
|
db
|
|
(~a "SELECT K.name, N.url, K.checksum"
|
|
" FROM pkg K, catalog N"
|
|
" WHERE N.id = K.catalog"
|
|
(if catalog
|
|
" AND N.url = $1"
|
|
"")
|
|
" AND NOT EXISTS"
|
|
" (SELECT M.name"
|
|
" FROM modules M"
|
|
" WHERE M.pkg = K.name"
|
|
" AND M.catalog = K.catalog"
|
|
" AND M.checksum = K.checksum)")
|
|
(append
|
|
(if catalog
|
|
(list catalog)
|
|
null))))
|
|
(for/list ([row (in-list rows)])
|
|
(pkg (vector-ref row 0)
|
|
(vector-ref row 1)
|
|
""
|
|
""
|
|
(vector-ref row 2)
|
|
"")))))
|
|
|
|
(define (get-catalogs)
|
|
(call-with-catalog-db
|
|
(lambda (db)
|
|
(prepare-catalog-table db)
|
|
(query-list db (~a "SELECT url FROM catalog"
|
|
" ORDER BY pos")))))
|
|
|
|
(define (set-catalogs! urls)
|
|
(call-with-catalog-db
|
|
(lambda (db)
|
|
(prepare-catalog-table db)
|
|
(prepare-pkg-table db)
|
|
(prepare-tags-table db)
|
|
(prepare-modules-table db)
|
|
(call-with-transaction
|
|
db
|
|
(lambda ()
|
|
(define current-url+ids
|
|
(query-rows db "SELECT url, id FROM catalog"))
|
|
(define old-urls (for/list ([old (in-list current-url+ids)])
|
|
(vector-ref old 0)))
|
|
(for ([old (in-list current-url+ids)])
|
|
(define old-url (vector-ref old 0))
|
|
(define old-id (vector-ref old 1))
|
|
(unless (member old-url urls)
|
|
(query-exec db
|
|
"DELETE FROM catalog WHERE id=$1"
|
|
old-id)
|
|
(query-exec db
|
|
"DELETE FROM pkg WHERE catalog=$1"
|
|
old-id)
|
|
(query-exec db
|
|
"DELETE FROM tags WHERE catalog=$1"
|
|
old-id)
|
|
(query-exec db
|
|
"DELETE FROM modules WHERE catalog=$1"
|
|
old-id)))
|
|
(for ([new-url (in-list urls)])
|
|
(unless (member new-url old-urls)
|
|
(let loop ([id 0])
|
|
(if (query-maybe-row db
|
|
"SELECT url FROM catalog WHERE id=$1"
|
|
id)
|
|
(loop (add1 id))
|
|
(query-exec db "INSERT INTO catalog VALUES ($1, $2, 0)"
|
|
id
|
|
new-url)))))
|
|
(for ([new-url (in-list urls)]
|
|
[pos (in-naturals)])
|
|
(query-exec db (~a "UPDATE catalog"
|
|
" SET pos = $1"
|
|
" WHERE url = $2")
|
|
pos
|
|
new-url)))))))
|
|
|
|
(define (url->catalog db url)
|
|
(query-value db
|
|
"SELECT id FROM catalog WHERE url=$1"
|
|
url))
|
|
|
|
(define (set-pkgs! url pkgs
|
|
#:clear-other-checksums? [clear-other-checksums? #t])
|
|
(call-with-catalog-db
|
|
(lambda (db)
|
|
(prepare-catalog-table db)
|
|
(prepare-pkg-table db)
|
|
(prepare-modules-table db)
|
|
(call-with-transaction
|
|
db
|
|
(lambda ()
|
|
(define catalog (url->catalog db url))
|
|
(define pkg-names (for/list ([p (in-list pkgs)])
|
|
(if (pkg? p)
|
|
(pkg-name p)
|
|
p)))
|
|
(define current-pkgs
|
|
(query-list db "SELECT name FROM pkg WHERE catalog=$1"
|
|
catalog))
|
|
(define new-pkgs (list->set pkg-names))
|
|
(define old-pkgs (list->set current-pkgs))
|
|
(for ([old (in-list current-pkgs)])
|
|
(unless (set-member? new-pkgs old)
|
|
(query-exec db
|
|
"DELETE FROM pkg WHERE catalog=$1 AND name=$2"
|
|
catalog
|
|
old)
|
|
(query-exec db
|
|
"DELETE FROM tags WHERE catalog=$1 AND pkg=$2"
|
|
catalog
|
|
old)
|
|
(query-exec db
|
|
"DELETE FROM modules WHERE catalog=$1 AND pkg=$2"
|
|
catalog
|
|
old)))
|
|
(for ([new0 (in-list pkgs)])
|
|
(define new (if (pkg? new0)
|
|
new0
|
|
(pkg new0 "" "" "" "" "")))
|
|
(when (and clear-other-checksums?
|
|
(not (equal? "" (pkg-checksum new))))
|
|
(query-exec db
|
|
(~a "DELETE FROM modules"
|
|
" WHERE catalog=$1 AND pkg=$2 AND checksum<>$3")
|
|
catalog
|
|
(pkg-name new)
|
|
(pkg-checksum new)))
|
|
(unless (and (string? new0)
|
|
(set-member? old-pkgs new0))
|
|
(if (set-member? old-pkgs (pkg-name new))
|
|
(query-exec db
|
|
(~a "UPDATE pkg"
|
|
" SET author=$1, source=$2, checksum=$3, desc=$4"
|
|
" WHERE name=$5"
|
|
" AND catalog=$6")
|
|
(pkg-author new)
|
|
(pkg-source new)
|
|
(pkg-checksum new)
|
|
(pkg-desc new)
|
|
(pkg-name new)
|
|
catalog)
|
|
(query-exec db
|
|
"INSERT INTO pkg VALUES ($1, $2, $3, $4, $5, $6)"
|
|
(pkg-name new)
|
|
catalog
|
|
(pkg-author new)
|
|
(pkg-source new)
|
|
(pkg-checksum new)
|
|
(pkg-desc new))))))))))
|
|
|
|
(define (prepare-table db which desc)
|
|
(when (null?
|
|
(query-rows db (~a "SELECT name FROM sqlite_master"
|
|
" WHERE type='table' AND name='" which "'")))
|
|
(query-exec db (~a "CREATE TABLE " which " "
|
|
desc))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(module+ main
|
|
(require rackunit
|
|
racket/file)
|
|
|
|
(define (pkg<? a b)
|
|
(if (string=? (pkg-name a) (pkg-name b))
|
|
(string<? (pkg-catalog a) (pkg-catalog b))
|
|
(string<? (pkg-name a) (pkg-name b))))
|
|
|
|
(parameterize ([current-pkg-catalog-file (make-temporary-file
|
|
"~a.sqlite")])
|
|
(check-equal? (get-catalogs) '())
|
|
|
|
(set-catalogs! '("http://a" "http://b"))
|
|
(check-equal? (get-catalogs)
|
|
'("http://a" "http://b"))
|
|
|
|
(check-equal? (get-pkgs) '())
|
|
|
|
|
|
(set-pkgs! "http://a" '("p1"))
|
|
(check-equal? (get-pkgs)
|
|
(list
|
|
(pkg "p1" "http://a" "" "" "" "")))
|
|
|
|
(set-pkgs! "http://b" '("p2"))
|
|
(check-equal? (get-pkgs)
|
|
(list
|
|
(pkg "p1" "http://a" "" "" "" "")
|
|
(pkg "p2" "http://b" "" "" "" "")))
|
|
(check-equal? (get-pkgs #:catalog "http://a")
|
|
(list
|
|
(pkg "p1" "http://a" "" "" "" "")))
|
|
(check-equal? (get-pkgs #:name "p1")
|
|
(list
|
|
(pkg "p1" "http://a" "" "" "" "")))
|
|
|
|
(set-pkg! "p1" "http://a" "github:a" "adam" "123" "the first package")
|
|
(check-equal? (get-pkgs)
|
|
(list
|
|
(pkg "p1" "http://a" "github:a" "adam" "123" "the first package")
|
|
(pkg "p2" "http://b" "" "" "" "")))
|
|
|
|
;; reverse order of catalogs:
|
|
(set-catalogs! '("http://b" "http://a"))
|
|
(check-equal? (get-catalogs)
|
|
'("http://b" "http://a"))
|
|
(check-equal? (get-pkgs)
|
|
(list
|
|
(pkg "p2" "http://b" "" "" "" "")
|
|
(pkg "p1" "http://a" "github:a" "adam" "123" "the first package")))
|
|
|
|
(check-equal? (get-pkg-tags "p2" "http://b")
|
|
'())
|
|
(set-pkg-tags! "p2" "http://b" '("2x" "2y" "2z"))
|
|
(check-equal? (sort (get-pkg-tags "p2" "http://b") string<?)
|
|
'("2x" "2y" "2z"))
|
|
(check-equal? (get-pkg-tags "p1" "http://a")
|
|
'())
|
|
|
|
(set-pkg-modules! "p1" "http://a" "123" (list '(lib "lib1/main.rkt")
|
|
'(lib "lib2/main.rkt")))
|
|
(check-equal? (sort (get-pkg-modules "p1" "http://a" "123")
|
|
string<?
|
|
#:key cadr)
|
|
(list '(lib "lib1/main.rkt")
|
|
'(lib "lib2/main.rkt")))
|
|
(check-equal? (get-module-pkgs '(lib "lib1/main.rkt"))
|
|
(list
|
|
(pkg "p1" "http://a" "" "" "123" "")))
|
|
|
|
(set-catalogs! '("http://a" "http://c"))
|
|
(check-equal? (sort (get-catalogs) string<?)
|
|
'("http://a" "http://c"))
|
|
|
|
(check-equal? (get-pkgs)
|
|
(list
|
|
(pkg "p1" "http://a" "github:a" "adam" "123" "the first package")))
|
|
|
|
(delete-file (current-pkg-catalog-file))
|
|
|
|
(void)))
|