blob: 73df6127df4e70dd073c80bf58bfa1ee757f6f2a (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
|
(define-module (guix-data-service model license)
#:use-module (srfi srfi-1)
#:use-module (ice-9 vlist)
#:use-module (squee)
#:use-module (guix inferior)
#:use-module (guix-data-service model utils)
#:export (inferior-packages->license-id-lists))
(define inferior-package-id
(@@ (guix inferior) inferior-package-id))
(define (inferior-packages->license-data inf packages)
(define (proc packages)
`(map (lambda (inferior-package-id)
(let ((package (hashv-ref %package-table inferior-package-id)))
(match (package-license package)
((? license? license)
(list
(list (license-name license)
(license-uri license)
(license-comment license))))
((values ...)
(map (match-lambda
((? license? license)
(list (license-name license)
(license-uri license)
(license-comment license)))
(x
(simple-format
(current-error-port)
"error: unknown license value ~A for package ~A"
x package)
'()))
values))
(x
(simple-format
(current-error-port)
"error: unknown license value ~A for package ~A"
x package)
'()))))
(list ,@(map inferior-package-id packages))))
(inferior-eval '(use-modules (guix licenses)) inf)
(inferior-eval (proc packages) inf))
(define (insert-licenses values)
(string-append
"INSERT INTO licenses "
"(name, uri, comment) "
"VALUES "
(string-join
(map (lambda (license-values)
(string-append
"("
(string-join
(map value->quoted-string-or-null
license-values)
", ")
")"))
values)
", ")
" RETURNING id"))
(define (inferior-packages->license-id-lists conn inf packages)
(define license-data
(inferior-packages->license-data inf packages))
(define (sort-license-ids ids)
(map number->string
(sort (map string->number ids) <)))
(define (non-string-to-false lst)
(map (lambda (value)
(if (string? value)
value
#f))
lst))
(define (empty-string-to-false lst)
;; TODO squee returns empty strings for null values, which will probably
;; cause problems
(map (lambda (value)
(if (string? value)
(if (string-null? value)
#f
value)
value))
lst))
(let* ((unique-license-tuples
(filter (lambda (license-tuple)
(not (null? license-tuple)))
(delete-duplicates
(map
(lambda (lst)
(non-string-to-false
(empty-string-to-false lst)))
(concatenate license-data)))))
(existing-license-entries
(exec-query->vhash conn
"SELECT id, name, uri, comment FROM licenses"
(lambda (vals)
(non-string-to-false
(empty-string-to-false (cdr vals))))
first)) ;; id
(missing-license-entries
(delete-duplicates
(filter (lambda (values)
(not (vhash-assoc values
existing-license-entries)))
unique-license-tuples)))
(new-license-entries
(if (null? missing-license-entries)
'()
(map first
(exec-query conn
(insert-licenses missing-license-entries)))))
(new-entries-id-lookup-vhash
(two-lists->vhash missing-license-entries
new-license-entries)))
(map (lambda (license-value-lists)
(sort-license-ids
(map (lambda (license-values)
(cdr
(or (vhash-assoc license-values
existing-license-entries)
(vhash-assoc license-values
new-entries-id-lookup-vhash)
(begin
(error "missing license entry"
license-values)))))
(map (lambda (lst)
(non-string-to-false
(empty-string-to-false lst)))
license-value-lists))))
license-data)))
|