projects/guix·blob python-team · refs

252 lines · 8.8 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2018 Mathieu Othacehe <[email protected]>
3;;; Copyright © 2019, 2020 Ludovic Courtès <[email protected]>
4;;;
5;;; This file is part of GNU Guix.
6;;;
7;;; GNU Guix is free software; you can redistribute it and/or modify it
8;;; under the terms of the GNU General Public License as published by
9;;; the Free Software Foundation; either version 3 of the License, or (at
10;;; your option) any later version.
11;;;
12;;; GNU Guix is distributed in the hope that it will be useful, but
13;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;;; GNU General Public License for more details.
16;;;
17;;; You should have received a copy of the GNU General Public License
18;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19
20(define-module (gnu installer newt network)
21 #:use-module (gnu installer connman)
22 #:use-module (gnu installer steps)
23 #:use-module (gnu installer utils)
24 #:use-module (gnu installer newt ethernet)
25 #:use-module (gnu installer newt page)
26 #:use-module (gnu installer newt wifi)
27 #:use-module (guix i18n)
28 #:use-module (srfi srfi-1)
29 #:use-module (srfi srfi-11)
30 #:use-module (srfi srfi-26)
31 #:use-module (srfi srfi-34)
32 #:use-module (srfi srfi-35)
33 #:use-module (ice-9 match)
34 #:use-module (web client)
35 #:use-module (web response)
36 #:use-module (newt)
37 #:export (run-network-page))
38
39;; Maximum length of a technology name.
40(define technology-name-max-length (make-parameter 20))
41
42(define (technology->text technology)
43 "Return a string describing the given TECHNOLOGY."
44 (let* ((name (technology-name technology))
45 (padded-name (string-pad-right name
46 (technology-name-max-length))))
47 (format #f "~a~%" padded-name)))
48
49(define (run-technology-page)
50 "Run a page to ask the user which technology shall be used to access
51Internet and return the selected technology. For now, only technologies with
52\"ethernet\" or \"wifi\" types are supported."
53 (define (technology-items)
54 (filter (lambda (technology)
55 (let ((type (technology-type technology)))
56 (or
57 (string=? type "ethernet")
58 (string=? type "wifi"))))
59 (connman-technologies)))
60
61 (match (technology-items)
62 (()
63 (case (choice-window
64 (G_ "Internet access")
65 (G_ "Continue")
66 (G_ "Exit")
67 (G_ "The install process requires Internet access but no \
68network devices were found. Do you want to continue anyway?"))
69 ((1) (abort-to-prompt 'installer-step 'break))
70 ((2) (abort-to-prompt 'installer-step 'abort))))
71 ((technology)
72 ;; Since there's only one technology available, skip the selection
73 ;; screen.
74 technology)
75 ((items ...)
76 (run-listbox-selection-page
77 #:info-text (G_ "The install process requires Internet access.\
78 Please select a network device.")
79 #:title (G_ "Internet access")
80 #:listbox-items items
81 #:listbox-item->text technology->text
82 #:listbox-height (min (+ (length items) 2) 5)
83 #:button-text (G_ "Exit")
84 #:button-callback-procedure
85 (lambda _
86 (abort-to-prompt 'installer-step 'abort))))))
87
88(define (find-technology-by-type technologies type)
89 "Find and return a technology with the given TYPE in TECHNOLOGIES list."
90 (find (lambda (technology)
91 (string=? (technology-type technology)
92 type))
93 technologies))
94
95(define (wait-technology-powered technology)
96 "Wait and display a progress bar until the given TECHNOLOGY is powered."
97 (let ((name (technology-name technology))
98 (full-value 5))
99 (run-scale-page
100 #:title (G_ "Powering technology")
101 #:info-text (format #f (G_ "Waiting for technology ~a to be powered.")
102 name)
103 #:scale-full-value full-value
104 #:scale-update-proc
105 (lambda (value)
106 (let* ((technologies (connman-technologies))
107 (type (technology-type technology))
108 (updated-technology
109 (find-technology-by-type technologies type))
110 (technology-powered? updated-technology))
111 (sleep 1)
112 (if technology-powered?
113 full-value
114 (+ value 1)))))))
115
116(define* (url-alive? url #:key (ensure-ok-status? #f))
117 (false-if-exception
118 (let ((response (http-request url)))
119 (or (not ensure-ok-status?)
120 (= (response-code response)
121 200)))))
122
123(define* (common-urls-alive? urls #:key (ensure-ok-status? #f))
124 "Return #t if at least some of the given URLS are alive,
125meaning that they do respond to a HTTP request. If ENSURE-OK-STATUS? is
126#t, return #t only if the code is 200."
127 (dynamic-wind
128 (lambda ()
129 (sigaction SIGALRM
130 (lambda _ #f))
131 (alarm 3))
132 (lambda ()
133 (any (cut url-alive? <> #:ensure-ok-status? ensure-ok-status?)
134 urls))
135 (lambda ()
136 (alarm 0))))
137
138(define (wait-service-online)
139 "Display a newt scale until connman detects an Internet access. Do
140FULL-VALUE tentatives, spaced by 1 second."
141 (define (online?)
142 (or (and (connman-online?)
143 (common-urls-alive?
144 (list
145 "https://bordeaux.guix.gnu.org"
146 "https://ci.guix.gnu.org"
147 "https://guix.gnu.org"
148 "https://gnu.org")
149 ;; Any HTTP response means the users is online.
150 #:ensure-ok-status? #f))
151 (file-exists? "/tmp/installer-assume-online")))
152
153 (let* ((full-value 5))
154 (run-scale-page
155 #:title (G_ "Checking connectivity")
156 #:info-text (G_ "Waiting for Internet access establishment...")
157 #:scale-full-value full-value
158 #:scale-update-proc
159 (lambda (value)
160 (sleep 1)
161 (if (online?)
162 full-value
163 (+ value 1))))
164 (unless (online?)
165 (case (choice-window
166 (G_ "Internet access")
167 (G_ "Continue")
168 (G_ "Try again?")
169 (G_ "
170The selected network does not seem to provide access to the \
171Internet. The install process requires Internet access. \
172Do you want to continue anyway?"))
173 ((2) (abort-to-prompt 'installer-step 'abort))))))
174
175(define (check-substitute-availability)
176 "Check that at least one of the Guix substitute servers is available."
177 (define (substitutes-available?)
178 (or
179 (file-exists? "/tmp/installer-assume-online")
180 (common-urls-alive?
181 (list
182 "https://bordeaux.guix.gnu.org/nix-cache-info"
183 "https://ci.guix.gnu.org/nix-cache-info")
184 #:ensure-ok-status? #t)))
185
186 (let* ((full-value 5))
187 (run-scale-page
188 #:title (G_ "Checking substitutes")
189 #:info-text (G_ "Checking if Guix substitutes are available...")
190 #:scale-full-value full-value
191 #:scale-update-proc
192 (lambda (value)
193 (sleep 1)
194 (if (substitutes-available?)
195 full-value
196 (+ value 1))))
197 (unless (substitutes-available?)
198 (case (choice-window
199 (G_ "Substitute availability")
200 (G_ "Continue")
201 (G_ "Try again?")
202 (G_ "
203None of the Guix substitute servers are available.
204You can proceed with the install, but you will
205have to build most of the packages you install locally."))
206 ((2) (abort-to-prompt 'installer-step 'abort))))))
207
208(define (run-network-page)
209 "Run a page to allow the user to configure connman so that it can access the
210Internet."
211 (define network-steps
212 (list
213 ;; Ask the user to choose between ethernet and wifi technologies.
214 (installer-step
215 (id 'select-technology)
216 (compute
217 (lambda _
218 (run-technology-page))))
219 ;; Enable the previously selected technology.
220 (installer-step
221 (id 'power-technology)
222 (compute
223 (lambda (result _)
224 (let ((technology (result-step result 'select-technology)))
225 (connman-enable-technology technology)
226 (wait-technology-powered technology)))))
227 ;; Propose the user to connect to one of the service available for the
228 ;; previously selected technology.
229 (installer-step
230 (id 'connect-service)
231 (compute
232 (lambda (result _)
233 (let* ((technology (result-step result 'select-technology))
234 (type (technology-type technology)))
235 (cond
236 ((string=? "wifi" type)
237 (run-wifi-page))
238 ((string=? "ethernet" type)
239 (run-ethernet-page)))))))
240 ;; Wait for connman status to switch to 'online, which means it can
241 ;; access Internet.
242 (installer-step
243 (id 'wait-online)
244 (compute (lambda _
245 (wait-service-online))))
246 (installer-step
247 (id 'check-substitutes)
248 (compute (lambda _
249 (check-substitute-availability))))))
250 (run-installer-steps
251 #:steps network-steps
252 #:rewind-strategy 'start))