suzanne.soy/racket-pkg-website
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial sketch of package catalog server kernel

Browse Source
This commit is contained in:
Tony Garnock-Jones 2015-01-27 00:09:08 -05:00
parent d50341d4ae
commit b7bccd00a6
5 changed files with 506 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/package-catalog/api.rkt Normal file
View File

@ -0,0 +1,2 @@
#lang racket/base

46
src/package-catalog/db.rkt Normal file
View File

@ -0,0 +1,46 @@
#lang racket/base
(provide make-db
db?
db-has-key?
db-ref
db-set!
db-remove!
db-keys)
(require racket/file)
(struct db (name path serializer deserializer) #:transparent)
(define (make-db name path serializer deserializer)
(make-directory* path)
(db name path serializer deserializer))
(define (check-key what db key)
(unless (string? key)
(error what "Invalid key for db ~a: ~v" (db-name db) key)))
(define (db-has-key? db key)
(check-key 'db-has-key? db key)
(file-exists? (build-path (db-path db) key)))
(define (db-ref db key default-thunk)
(check-key 'db-ref db key)
(define p (build-path (db-path db) key))
(if (file-exists? p)
((db-deserializer db) (file->value p))
(default-thunk)))
(define (db-set! db key value)
(check-key 'db-set! db key)
(write-to-file value (build-path (db-path db) key)
#:exists 'replace))
(define (db-remove! db key)
(check-key 'db-remove! db key)
(define p (build-path (db-path db) key))
(when (file-exists? p)
(delete-file p)))
(define (db-keys db)
(map path->string (directory-list (db-path db))))

7
src/package-catalog/main.rkt Normal file
View File

@ -0,0 +1,7 @@
#lang racket/base
(provide (all-from-out "structs.rkt")
(all-from-out "source.rkt"))
(require "structs.rkt")
(require "source.rkt")

182
src/package-catalog/source.rkt Normal file
View File

@ -0,0 +1,182 @@
#lang racket/base
(provide (struct-out url-source)
(struct-out git-source)
package-source?
string->package-source
package-source->string
github-source?
github-user+repo)
(require racket/match)
(require net/url)
(require pkg/name)
(require pkg/private/repo-path)
(require (only-in racket/string string-join))
(struct url-source (url ;; String
)
#:prefab)
(struct git-source (host ;; String
port ;; Nat or #f
repo ;; String (e.g. for github.com, "/user/repo")
branch ;; String
path ;; Relative URL String
)
#:prefab)
(define (package-source? x)
(or (url-source? x)
(git-source? x)))
(define (string->package-source str)
(define u (string->url str))
(define-values (_name type) (package-source->name+type str #f))
(cond
[(memq type '(git github))
(define-values (host port repo branch path)
(if (equal? "github" (url-scheme u))
(match (split-github-url u)
[(list* user repo branch path)
(values "github.com" #f (string-append user "/" repo) branch path)]
[(list user repo)
(values "github.com" #f (string-append user "/" repo) "master" '())]
[_ (error 'string->package-source "Invalid github url: ~v" str)])
(split-git-url u)))
;; TODO: clean this up in repo-path.rkt
(git-source host
port
repo
branch
(string-join path "/"))]
;; [(and (member (url-scheme u) '("http" "https"))
;; (equal? (url-host u) "github.com"))
;; ;; ... parse the path, etc., and turn it into a git-source ...
;; ]
[else
(url-source (url->string u))]))
(define (package-source->string s)
(match s
[(url-source u) u]
[(git-source host port repo branch path)
(url->string (url "git"
#f
host
port
#t
(url-path (path->url repo))
(if (string=? path "")
'()
(list (cons 'path path)))
branch))]))
(define (github-source? s)
(unless (package-source? s) (error 'github-source? "Expected package-source: ~v" s))
(match s
[(git-source "github.com" #f (regexp "^([^/]+)/([^/]+)/*$") _ _) #t]
[_ #f]))
(define (github-user+repo s)
(unless (github-source? s) (error 'github-user+repo "Expected github package-source: ~v" s))
(match (regexp-match "^([^/]+)/([^/]+)/*$" (git-source-repo s))
[(list _ user repo) (values user repo)]
[#f (error 'github-user+repo "Invalid github repo path: ~v" (git-source-repo s))]))
(module+ test
(require rackunit)
(check-equal? (string->package-source "https://github.com/user/repo")
(url-source "https://github.com/user/repo"))
(check-equal? (string->package-source "http://example.com/some/path/to/package.zip")
(url-source "http://example.com/some/path/to/package.zip"))
(check-equal? (string->package-source "git://github.com/user/repo")
(git-source "github.com" #f "user/repo" "master" ""))
(check-equal? (string->package-source "git://github.com/user/repo#master")
(git-source "github.com" #f "user/repo" "master" ""))
(check-equal? (string->package-source "git://github.com/user/repo?path=/subdir1/subdir2#master")
(git-source "github.com" #f "user/repo" "master" "subdir1/subdir2"))
(check-equal? (string->package-source "git://github.com/user/repo?path=subdir1/subdir2#master")
(git-source "github.com" #f "user/repo" "master" "subdir1/subdir2"))
(check-equal? (string->package-source "git://github.com/user/repo?path=%2fsubdir1%2fsubdir2#master")
(git-source "github.com" #f "user/repo" "master" "subdir1/subdir2"))
(check-equal? (string->package-source "git://github.com/user/repo?path=subdir1%2fsubdir2#master")
(git-source "github.com" #f "user/repo" "master" "subdir1/subdir2"))
(check-equal? (string->package-source "git://github.com/user/repo#otherbranch")
(git-source "github.com" #f "user/repo" "otherbranch" ""))
(check-equal? (string->package-source "git://github.com/user/repo?path=/subdir1/subdir2#otherbranch")
(git-source "github.com" #f "user/repo" "otherbranch" "subdir1/subdir2"))
(check-equal? (string->package-source "git://github.com/user/repo?path=subdir1/subdir2#otherbranch")
(git-source "github.com" #f "user/repo" "otherbranch" "subdir1/subdir2"))
(check-equal? (string->package-source "git://github.com/user/repo?path=%2fsubdir1%2fsubdir2#otherbranch")
(git-source "github.com" #f "user/repo" "otherbranch" "subdir1/subdir2"))
(check-equal? (string->package-source "git://github.com/user/repo?path=subdir1%2fsubdir2#otherbranch")
(git-source "github.com" #f "user/repo" "otherbranch" "subdir1/subdir2"))
(check-exn #px"Invalid github url"
(lambda () (string->package-source "github://github.com/user/")))
(check-equal? (string->package-source "github://github.com/user/repo")
(git-source "github.com" #f "user/repo" "master" ""))
(check-equal? (string->package-source "github://github.com/user/repo/")
(git-source "github.com" #f "user/repo" "master" ""))
(check-equal? (string->package-source "github://github.com/user/repo/master")
(git-source "github.com" #f "user/repo" "master" ""))
(check-equal? (string->package-source "github://github.com/user/repo/master/")
(git-source "github.com" #f "user/repo" "master" ""))
(check-equal? (string->package-source "github://github.com/user/repo/master/subdir1/subdir2")
(git-source "github.com" #f "user/repo" "master" "subdir1/subdir2"))
(check-equal? (string->package-source "github://github.com/user/repo/otherbranch")
(git-source "github.com" #f "user/repo" "otherbranch" ""))
(check-equal? (string->package-source "github://github.com/user/repo/otherbranch/")
(git-source "github.com" #f "user/repo" "otherbranch" ""))
(check-equal? (string->package-source "github://github.com/user/repo/otherbranch/subdir1/subdir2")
(git-source "github.com" #f "user/repo" "otherbranch" "subdir1/subdir2"))
(check-equal? (package-source->string
(git-source "github.com" #f "user/repo" "master" "subdir1/subdir2"))
"git://github.com/user/repo?path=subdir1%2Fsubdir2#master")
(check-equal? (package-source->string
(git-source "github.com" #f "user/repo" "otherbranch" "subdir1/subdir2"))
"git://github.com/user/repo?path=subdir1%2Fsubdir2#otherbranch")
(define (roundtrip str)
(check-equal? (package-source->string (string->package-source str)) str))
(roundtrip "https://github.com/user/repo")
(roundtrip "http://example.com/some/path/to/package.zip")
(roundtrip "git://github.com/user/repo#master")
(roundtrip "git://github.com/user/repo#otherbranch")
(check-equal? (github-source? (string->package-source "github://github.com/user/repo")) #t)
(check-equal? (github-source? (string->package-source "github://github.com/user/repo/master")) #t)
(check-equal? (github-source? (string->package-source "github://github.com/user/repo/master/subdir")) #t)
(check-equal? (github-source? (string->package-source "git://github.com/user/repo")) #t)
(check-equal? (github-source? (string->package-source "git://github.com/user/repo#master")) #t)
(check-equal? (github-source? (string->package-source "git://github.com/user/repo?path=subdir#master")) #t)
(check-equal? (github-source? (string->package-source "git://github.com/user/repo/more")) #f)
(check-equal? (github-source? (string->package-source "git://github.com/user/repo/more#master")) #f)
(check-equal? (github-source? (string->package-source "git://github.com/user/repo/more?path=subdir#master")) #f)
(check-equal? (github-source? (string->package-source "git://github.com/user")) #f)
(check-equal? (github-source? (string->package-source "git://github.com/user#master")) #f)
(check-equal? (github-source? (string->package-source "git://github.com/user?path=subdir#master")) #f)
(check-equal? (github-source? (string->package-source "git://example.com/user/repo")) #f)
(check-equal? (github-source? (string->package-source "git://example.com/user/repo#master")) #f)
(check-equal? (github-source? (string->package-source "git://example.com/user/repo?path=subdir#master")) #f)
(define (extract-user+repo str)
(define-values (user repo) (github-user+repo (string->package-source str)))
(list user repo))
(check-equal? (extract-user+repo "github://github.com/user/repo") (list "user" "repo"))
(check-equal? (extract-user+repo "github://github.com/user/repo/master") (list "user" "repo"))
(check-equal? (extract-user+repo "github://github.com/user/repo/master/subdir") (list "user" "repo"))
(check-equal? (extract-user+repo "git://github.com/user/repo") (list "user" "repo"))
(check-equal? (extract-user+repo "git://github.com/user/repo#master") (list "user" "repo"))
(check-equal? (extract-user+repo "git://github.com/user/repo?path=subdir#master") (list "user" "repo"))
)

269
src/package-catalog/structs.rkt Normal file
View File

@ -0,0 +1,269 @@
#lang racket/base
(provide (struct-out package)
package-author
serialize-package
deserialize-package
(struct-out computed-info)
serialize-computed-info
deserialize-computed-info
(struct-out github-info)
serialize-github-info
deserialize-github-info)
(require racket/set)
(require racket/match)
(require (only-in racket/string string-split string-join))
(require "source.rkt")
;; A Time here is milliseconds-since-epoch - e.g. a result from
;; (current-inexact-milliseconds).
(define package-format-version 0) ;; IMPORTANT - UPDATE THIS AND CHANGE SERIALIZATION
;; WHENEVER THE STRUCT DEFINITION FOR package CHANGES
(struct package (name ;; String
source ;; PackageSource
description ;; String
tags ;; (Listof String)
authors ;; (Listof String)
versions ;; (HashTable String PackageSource)
ring ;; Nat
last-edit ;; Time
)
#:prefab)
(define (package-author p)
(string-join (package-authors p) " "))
(define computed-info-format-version 0) ;; IMPORTANT - UPDATE THIS AND CHANGE SERIALIZATION
;; WHENEVER THE STRUCT DEFINITION FOR computed-info CHANGES
(struct computed-info (package-name ;; String
last-updated ;; Time, most recent change to package source
last-checked ;; Time, when package source was most recently checked
checksums ;; (HashTable String String), including "default" key
checksum-errors ;; (HashTable String String), including "default" key
github-info ;; GithubInfo or #f
declared-conflicts ;; (Setof String), package names
modules ;; (Listof ModulePath)
dependencies ;; (Listof String), package names
)
#:prefab)
(define github-info-format-version 0) ;; IMPORTANT - UPDATE THIS AND CHANGE SERIALIZATION
;; WHENEVER THE STRUCT DEFINITION FOR github-info CHANGES
(struct github-info (readme-exists? ;; Boolean
)
#:prefab)
;;---------------------------------------------------------------------------
;; This is the kind of stupid repetitive code our struct system should
;; allow us to automate.
(define (serialize-package p)
(match-define (package name source description tags authors versions ring last-edit) p)
(list 'package package-format-version
(hash 'name name
'source (package-source->string source)
'description description
'tags tags
'authors authors
'versions (for/hash [((version source) (in-hash versions))]
(values version (package-source->string source)))
'ring ring
'last-edit last-edit)))
(define (deserialize-package p)
(match p
[(? hash?)
(package (hash-ref p 'name)
(string->package-source (hash-ref p 'source))
(hash-ref p 'description "")
(hash-ref p 'tags '())
(string-split (hash-ref p 'author ""))
(for/hash [((version fields) (in-hash (hash-ref p 'versions (hash))))]
(values version (string->package-source (hash-ref fields 'source))))
(hash-ref p 'ring 2)
(hash-ref p 'last-edit 0))]
[(list 'package 0
(hash-table ['name (? string? name)]
['source (? string? source0)]
['description (? string? description)]
['tags (and (list (? string?) ...) tags)]
['authors (and (list (? string?) ...) authors)]
['versions versions0]
['ring (? number? ring)]
['last-edit (? number? last-edit)]))
(define source (string->package-source source0))
(define versions (for/hash [((version source) (in-hash versions0))]
(values version (string->package-source source))))
(package name source description tags authors versions ring last-edit)]
[_
(error 'deserialize-package "Unrecognized serialized package: ~v" p)]))
(define (serialize-computed-info ci)
(match-define (computed-info package-name
last-updated
last-checked
checksums
checksum-errors
github-info
declared-conflicts
modules
dependencies)
ci)
(list 'computed-info computed-info-format-version
(hash 'package-name package-name
'last-updated last-updated
'last-checked last-checked
'checksums checksums
'checksum-errors checksum-errors
'github-info (and github-info (serialize-github-info github-info))
'declared-conflicts declared-conflicts
'modules modules
'dependencies dependencies)))
(define (deserialize-computed-info ci)
(match ci
[(? hash?)
(computed-info (hash-ref ci 'name)
(hash-ref ci 'last-updated 0)
(hash-ref ci 'last-checked 0)
(let ((cs (for/hash [((v fs) (in-hash (hash-ref ci 'versions (hash))))
#:when (hash-has-key? fs 'checksum)]
(values v (hash-ref fs 'checksum)))))
(if (hash-has-key? ci 'checksum)
(hash-set cs "default" (hash-ref ci 'checksum))
cs))
(let ((err (hash-ref ci 'checksum-error #f)))
(if err
(hash "default" err)
(hash)))
#f
(list->set (hash-ref ci 'conflicts '()))
(hash-ref ci 'modules '())
(hash-ref ci 'dependencies '()))]
[(list 'computed-info 0
(hash-table ['package-name (? string? package-name)]
['last-updated (? number? last-updated)]
['last-checked (? number? last-checked)]
['checksums checksums]
['checksum-errors checksum-errors]
['github-info github-info0]
['declared-conflicts declared-conflicts]
['modules (and (list (? module-path?) ...) modules)]
['dependencies (and (list (? string?) ...) dependencies)]))
(define github-info (and github-info0 (deserialize-github-info github-info0)))
(computed-info package-name
last-updated
last-checked
checksums
checksum-errors
github-info
declared-conflicts
modules
dependencies)]
[_
(error 'deserialize-computed-info "Unrecognized serialized computed-info: ~v" ci)]))
(define (serialize-github-info gi)
(match-define (github-info readme-exists?) gi)
(list 'github-info github-info-format-version
(hash 'readme-exists? readme-exists?)))
(define (deserialize-github-info gi)
(match gi
[(list 'github-info 0
(hash-table ['readme-exists? readme-exists?]))
(github-info readme-exists?)]
[_
(error 'deserialize-github-info "Unrecognized serialized github-info: ~v" gi)]))
;;---------------------------------------------------------------------------
(module+ test
(require rackunit)
(define empty-zip "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip")
(define empty-zip-checksum "9f098dddde7f217879070816090c1e8e74d49432")
(define xrepl-lib-hash
#hash((name . "xrepl-lib")
(source . "git://github.com/racket/xrepl/?path=xrepl-lib")
(author . "eli@racket-lang.org")
(last-updated . 1417912075)
(last-edit . 1417659583)
(last-checked . 1421095102)
(versions
. #hash(("5.3.5"
. #hash((source
. "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip")
(checksum . "9f098dddde7f217879070816090c1e8e74d49432")))
("5.3.4"
. #hash((source
. "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip")
(checksum . "9f098dddde7f217879070816090c1e8e74d49432")))
("5.3.6"
. #hash((source
. "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip")
(checksum . "9f098dddde7f217879070816090c1e8e74d49432")))))
(tags . ("main-distribution"))
(checksum-error . #f)
(ring . 0)
(checksum . "c88f8430b054d8a207a95acb0d1de0efece33510")
(description . "implementation (no documentation) part of \"xrepl\"")
(modules . ((lib "xrepl/saved-values.rkt")
(lib "xrepl/xrepl.rkt")
(lib "xrepl/main.rkt")))
(dependencies . ("base" "readline-lib" "scribble-text-lib"))
(conflicts . ())))
(define xrepl-lib (package "xrepl-lib"
(git-source "github.com"
#f
"racket/xrepl"
"master"
"xrepl-lib")
"implementation (no documentation) part of \"xrepl\""
'("main-distribution")
'("eli@racket-lang.org")
(hash "5.3.4" (url-source empty-zip)
"5.3.5" (url-source empty-zip)
"5.3.6" (url-source empty-zip))
0
1417659583))
(define xrepl-lib-info (computed-info "xrepl-lib"
1417912075
1421095102
(hash "5.3.4" empty-zip-checksum
"5.3.5" empty-zip-checksum
"5.3.6" empty-zip-checksum
"default" "c88f8430b054d8a207a95acb0d1de0efece33510")
(hash)
#f
(set)
(list '(lib "xrepl/saved-values.rkt")
'(lib "xrepl/xrepl.rkt")
'(lib "xrepl/main.rkt"))
(list "base" "readline-lib" "scribble-text-lib")))
(check-equal? (deserialize-package xrepl-lib-hash) xrepl-lib)
(check-equal? (serialize-package xrepl-lib)
(list 'package package-format-version
(hash 'name "xrepl-lib"
'source "git://github.com/racket/xrepl?path=xrepl-lib#master"
'tags '("main-distribution")
'description "implementation (no documentation) part of \"xrepl\""
'last-edit 1417659583
'versions (hash "5.3.4" empty-zip
"5.3.5" empty-zip
"5.3.6" empty-zip)
'ring 0
'authors '("eli@racket-lang.org"))))
(check-equal? (deserialize-package (serialize-package xrepl-lib)) xrepl-lib)
(check-equal? (deserialize-computed-info xrepl-lib-hash) xrepl-lib-info)
(check-equal? (deserialize-computed-info (serialize-computed-info xrepl-lib-info)) xrepl-lib-info)
)