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
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
| | (define-module (guix scripts publish)
#:use-module ((system repl server) #:prefix repl:)
#:use-module (ice-9 binary-ports)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (rnrs io ports)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-37)
#:use-module (web http)
#:use-module (web request)
#:use-module (web response)
#:use-module (web server)
#:use-module (web uri)
#:use-module (guix base32)
#:use-module (guix base64)
#:use-module (guix config)
#:use-module (guix derivations)
#:use-module (guix hash)
#:use-module (guix pki)
#:use-module (guix pk-crypto)
#:use-module (guix store)
#:use-module (guix serialization)
#:use-module (guix ui)
#:export (guix-publish))
(define (show-help)
(display (_ "Usage: guix publish [OPTION]...
Publish the store directory over HTTP.\n"))
(display (_ "
-p, --port=PORT listen on PORT"))
(display (_ "
-r, --repl[=PORT] spawn REPL server on PORT"))
(newline)
(display (_ "
-h, --help display this help and exit"))
(display (_ "
-V, --version display version information and exit"))
(newline)
(show-bug-report-information))
(define %options
(list (option '(#\h "help") #f #f
(lambda _
(show-help)
(exit 0)))
(option '(#\V "version") #f #f
(lambda _
(show-version-and-exit "guix publish")))
(option '(#\p "port") #t #f
(lambda (opt name arg result)
(alist-cons 'port (string->number* arg) result)))
(option '(#\r "repl") #f #t
(lambda (opt name arg result)
;; If port unspecified, use default Guile REPL port.
(let ((port (and arg (string->number* arg))))
(alist-cons 'repl (or port 37146) result))))))
(define %default-options
'((port . 8080)
(repl . #f)))
(define %store (open-connection))
(define %private-key
(call-with-input-file %private-key-file
(compose string->canonical-sexp
get-string-all)))
(define %public-key
(call-with-input-file %public-key-file
(compose string->canonical-sexp
get-string-all)))
(define %nix-cache-info
`(("StoreDir" . ,%store-directory)
("WantMassQuery" . 0)
("Priority" . 100)))
(define (load-derivation file-name)
"Read the derivation located at FILE-NAME."
(with-input-from-file file-name
(lambda ()
(read-derivation (current-input-port)))))
(define (false-if-empty-string str)
(and (not (string-null? str)) str))
(define (sign-string s)
"Sign the hash of the string S with the daemon's key."
(let ((hash (bytevector->hash-data (sha256 (string->utf8 s)))))
(signature-sexp hash %private-key %public-key)))
(define base64-encode-string
(compose base64-encode string->utf8))
(define (narinfo-string store-path path-info derivation deriver key)
(let* ((url (string-append "nar/" (basename store-path)))
(nar-hash (bytevector->base32-string
(path-info-hash path-info)))
(nar-size (path-info-nar-size path-info))
(references (string-join (map basename (path-info-refs path-info))
" "))
(system (derivation-system derivation))
(deriver (basename deriver))
(info (format #f
"StorePath: ~a
URL: ~a
Compression: none
NarHash: sha256:~a
NarSize: ~d
References: ~a
System: ~a
Deriver: ~a~%"
store-path url nar-hash nar-size references
system deriver))
(signature (base64-encode-string
(canonical-sexp->string (sign-string info)))))
(format #f "~aSignature: 1;~a;~a~%" info (gethostname) signature)))
(define (not-found request)
"Render 404 response for REQUEST."
(values (build-response #:code 404)
(string-append "Resource not found: "
(uri-path (request-uri request)))))
(define (render-nix-cache-info)
"Render server information."
(values '((content-type . (text/plain)))
(lambda (port)
(for-each (match-lambda
((key . value)
(format port "~a: ~a~%" key value)))
%nix-cache-info))))
(define (render-narinfo request hash)
"Render metadata for the store path corresponding to HASH."
(apply values
(or (and-let* ((store-path (false-if-empty-string
(hash-part->path %store hash)))
(path-info (query-path-info %store store-path))
(deriver (let ((d (path-info-deriver path-info)))
(if (string-null? d) store-path d)))
(drv (and (file-exists? deriver)
(load-derivation deriver)))
(info (narinfo-string store-path path-info drv
deriver %private-key)))
(list '((content-type . (application/x-nix-narinfo)))
(lambda (port)
(display info port))))
(call-with-values (lambda () (not-found request)) list))))
(define (render-nar request store-item)
"Render archive of the store path corresponding to STORE-ITEM."
(let ((store-path (string-append %store-directory "/" store-item)))
(values '((content-type . (application/x-nix-archive
(charset . "ISO-8859-1"))))
(lambda (port)
(write-file store-path port)))))
(define extract-narinfo-hash
(let ((regexp (make-regexp "^([a-df-np-sv-z0-9]{32}).narinfo$")))
(lambda (str)
"Return the hash within the narinfo resource string STR, or false if STR
is invalid."
(and=> (regexp-exec regexp str)
(cut match:substring <> 1)))))
(define (get-request? request)
"Return #t if REQUEST uses the GET method."
(eq? (request-method request) 'GET))
(define (request-path-components request)
"Split the URI path of REQUEST into a list of component strings. For
example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
(split-and-decode-uri-path (uri-path (request-uri request))))
(define (request-handler request body)
(format #t "~a ~a~%"
(request-method request)
(uri-path (request-uri request)))
(if (get-request? request) ; reject POST, PUT, etc.
(match (request-path-components request)
(("nix-cache-info") ; /nix-cache-info
(render-nix-cache-info))
(((= extract-narinfo-hash (? string? hash))) ; /<hash>.narinfo
(render-narinfo request hash))
(("nar" store-path) ; /nar/<hash-part>
(render-nar request store-path))
(_ (not-found request)))
(not-found request)))
(define (run-publish-server port)
(run-server (lambda args (apply request-handler args))
'http
`(#:addr ,INADDR_ANY
#:port ,port)))
(define (guix-publish . args)
(with-error-handling
(let* ((opts (parse-command-line args %options (list %default-options)))
(port (assoc-ref opts 'port))
(repl-port (assoc-ref opts 'repl)))
(format #t "Publishing store on port ~d~%" port)
(when repl-port
(repl:spawn-server (repl:make-tcp-server-socket #:port repl-port)))
(run-publish-server (assoc-ref opts 'port)))))
|