/pliant/fullpliant/debian.pli
1	abstract
2	[This modules implements direct handling of Debian packages]
3	doc
4	[You can think about it as a replacement of 'dpkg' and 'apt-get']
5
6	module "/pliant/language/unsafe.pli"
7	module "/pliant/language/stream.pli"
8	module "/pliant/admin/file.pli"
9	module "/pliant/admin/md5.pli"
10	module "/pliant/admin/execute.pli"
11	submodule "computer.pli"
12
13	module "/pliant/protocol/http/client.pli"
14	module "/pliant/protocol/ftp/client.pli"
15
16	(gvar TraceSlot debian_trace) configure "Debian install"
17
18
19
20
21
22	doc
23	['DebianPackage' type stores a record of a Debian .deb file.] ; eol
24
25
26	type DebianPackage
27	field Str name version
28	field Str repository section
29	field Str priority ; field Float ring
30	field Int size ; field Str md5
31	field Str predepends depends
32	field Str provides conflicts
33	field Str url
34
35	type DebianDistribution
36	field Str ftp_server <- "ftp.uk.debian.org"
37	field Dictionary packages
38	field Data:Computer computer
39
40
41	method p base_filename -> n
42	arg DebianPackage p ; arg Str n
43	n := p:name+"_"+(shunt (p:version parse any ":" any:(var Str v)) v p:version)+".deb"
44
45	method p base_section -> n
46	arg DebianPackage p ; arg Str n
47	n := shunt (p:section parse any "/" any:(var Str s)) s p:section
48
49	method p local_filename -> n
50	arg DebianPackage p ; arg Str n
51	n := "file:/fullpliant/debian/"+p:base_filename
52
53	method p alternate_filename -> n
54	arg DebianPackage p ; arg Str n
55	n := "file:/fullpliant/debian_old/"+p:base_filename
56
57	method p remote_filename -> n
58	arg DebianPackage p ; arg Str n
59	n := p url
60
61
62
63
64
65	method debian load repository ring url
66	arg_rw DebianDistribution debian ; arg Str repository ; arg Int ring ; arg Str url
67	(var Stream list) open "gzip:file:/fullpliant/debian/packages_"+repository+".gz" in+safe
68	var Link:DebianPackage p :> new DebianPackage
69	while not list:atend
70	var Str l := list readline
71	if (l parse "Package" ":" any:(var Str name))
72	p :> new DebianPackage
73	p name := name
74	p repository := repository
75	p ring := ring
76	debian:packages insert name false addressof:p
77	if (l parse "Version" ":" any:(var Str version))
78	p version := version
79	if (l parse "Section" ":" any:(var Str section))
80	p section := section
81	if (l parse "Size" ":" (var Int size))
82	p size := size
83	if (l parse "MD5sum" ":" any:(var Str md5))
84	p md5 := md5
85	if (l parse "Pre-Depends" ":" any:(var Str predepends))
86	p predepends := predepends
87	if (l parse "Depends" ":" any:(var Str depends))
88	p depends := depends
89	if (l parse "Provides" ":" any:(var Str provides))
90	p provides := provides
91	while provides<>""
92	if not (provides parse any:(var Str name) "," any:(var Str remain))
93	name := provides ; remain := ""
94	debian:packages insert name false addressof:p
95	provides := remain
96	if (l parse "Conflicts" ":" any (var Str conflicts))
97	p conflicts := conflicts
98	if (l parse "Priority" ":" any:(var Str priority))
99	p priority := priority
100	p ring := ring+(shunt priority="extra" 0.25 0)
101	if (l parse "Filename" ":" any:(var Str path))
102	if (url parse any:(var Str root) "/dists/" any)
103	p url := root+"/"+path
104	eif (url search ":" -1)<>(-1)
105	p url := url+(path (path search_last "/" -1)+1 path:len)
106	else
107	p url := "ftp://"+debian:ftp_server+"/debian/"+path
108	list close
109
110
111
112
113	doc
114	link "Debian version numbering" "http://www.debian.org/doc/packaging-manuals/packaging.html/ch-versions.html"
115
116
117	function reorder s -> s2
118	arg Str s s2
119	if true
120	s2 := s
121	else
122	s2 := ""
123	for (var Int i) 0 s:len-1
124	if s:i>="-"
125	s2 += "0"+s:i
126	eif s:i>="a" and s:i<="z"
127	s2 += "1"+s:i
128	eif s:i>="A" and s:i<="Z"
129	s2 += "1"+(lower s:i)
130	else
131	s2 += "2"+(lower s:i)
132
133	function compare_version v1 v2 -> c
134	arg Str v1 v2 ; arg Int c
135	var Str s1 := replace v1 "-" "[0]" ; var Str s2 := replace v2 "-" "[0]"
136	if (s1 search ":" -1)=(-1)
137	s1 := "0:"+s1
138	if (s2 search ":" -1)=(-1)
139	s2 := "0:"+s2
140	while s1<>"" or s2<>""
141	if not (s1 parse any:(var Str t1) (var uInt i1) any:(var Str r1))
142	t1 := s1 ; i1 := 0 ; r1 := ""
143	if not (s2 parse any:(var Str t2) (var uInt i2) any:(var Str r2))
144	t2 := s2 ; i2 := 0 ; r2 := ""
145	c := compare reorder:t1 reorder:t2
146	if c<>compare_equal
147	return
148	c := compare i1 i2
149	if c<>compare_equal
150	return
151	s1 := r1 ; s2 := r2
152	c := compare_equal
153
154	function satisfyed cond version -> ok
155	arg Str cond version ; arg CBool ok
156	if version=""
157	return false
158	if cond=""
159	return true
160	var Int flags ; var Str v
161	if (cond parse ">=" any:v)
162	flags := compare_superior+compare_equal
163	eif (cond parse "<=" any:v)
164	flags := compare_inferior+compare_equal
165	eif (cond parse ">>" any:v)
166	flags := compare_superior
167	eif (cond parse "<<" any:v)
168	flags := compare_inferior
169	eif (cond parse "=" any:v)
170	flags := compare_equal
171	else
172	return false
173	ok := ((compare_version version v) .and. flags)<>0
174
175
176	method debian package name version cond err -> package
177	arg DebianDistribution debian ; arg Str name version cond ; arg_w Str err ; arg Link:DebianPackage package
178	var Float ring := 99 ; var Int count := 0
179	var Pointer:Arrow c :> debian:packages first name
180	while c<>null
181	var Link:DebianPackage p :> c map DebianPackage
182	if cond="latest" or (satisfyed cond p:version)
183	if version="" or p:version=version
184	var Float Int r := p ring
185	if p:name=name
186	r -= 0.5
187	if r<ring or cond="latest" and ((compare_version p:version package:version) .and. compare_superior)<>0
188	package :> p
189	ring := r
190	count := 1
191	eif r=ring
192	count += 1
193	c :> debian:packages next name c
194	if count<1
195	package :> new DebianPackage
196	err := "not found"
197	eif count>1
198	package :> new DebianPackage
199	err := "ambigious"
200	if cond<>""
201	err += " for condition "+cond
202	var Pointer:Arrow c :> debian:packages first name
203	while c<>null
204	var Link:DebianPackage p :> c map DebianPackage
205	if (satisfyed cond p:version)
206	if version="" or p:version=version
207	var Float Int r := p ring
208	if p:name=name
209	r -= 0.5
210	if r=ring
211	err += " "+p:repository+" "+p:name+" "+p:version
212	c :> debian:packages next name c
213	else
214	err := ""
215
216
217	method debian bind c
218	arg_rw DebianDistribution debian ; arg Data:Computer c
219	debian computer :> c
220	debian ftp_server := c:env:"debian":"download":"ftp_server"
221	if debian:ftp_server=""
222	debian ftp_server := "ftp.uk.debian.org"
223	var Str prefered := c:env:"debian":"download":"prefered_repository"
224	each rep c:env:"debian":"repository"
225	if rep<>""
226	if prefered="unstable"
227	debian load keyof:rep (shunt (rep search "unstable" -1)<>(-1) 0 (rep search "testing" -1)<>(-1) 1 2) rep
228	eif prefered="testing"
229	debian load keyof:rep (shunt (rep search "unstable" -1)<>(-1) 1 (rep search "testing" -1)<>(-1) 0 2) rep
230	else
231	debian load keyof:rep (shunt (rep search "unstable" -1)<>(-1) 2 (rep search "testing" -1)<>(-1) 1 0) rep
232
233
234	method debian package name -> package
235	arg DebianDistribution debian ; arg Str name ; arg Link:DebianPackage package
236	package :> debian package name debian:computer:env:"package":name:"version" debian:computer:env:"package":name:"condition" (var Str err)
237
238
239
240
241	doc
242	['debian_select' function will use the Debian packages database as a source of dependencies rules, and add the missing required packages, and eventually detect a conflict.]
243
244
245	function debian_select c -> status
246	arg_rw Data:Computer c ; arg ExtendedStatus status
247	var Str computer_name := keyof c
248	(var DebianDistribution debian) bind c
249	each cursor debian:packages
250	var Link:DebianPackage p :> cursor map DebianPackage
251	if p:priority="required"
252	c:env create "package"
253	c:env:"package" create p:name
254	status := failure
255	var Dictionary provide
256	each pkg c:env:"package"
257	var Link:DebianPackage p :> debian package keyof:pkg pkg:"version" pkg:"condition" (var Str err)
258	if err<>""
259	return (failure "Could not find Debian package "+keyof:pkg+" "+pkg:"version"+" ("+err+")")
260	if pkg:"version"=""
261	pkg create "version"
262	pkg:"version" := p version
263	var Str provides := p provides
264	while provides<>""
265	if not (provides parse any:(var Str name) "," any:(var Str remain))
266	name := provides ; remain := ""
267	provide kmap name Bool := true
268	provides := remain
269	part complete
270	var CBool more := false
271	each pkg c:env:"package"
272	part check_package
273	var Link:DebianPackage p :> debian package keyof:pkg
274	for (var Int lap) 0 1
275	var Str depends := shunt lap=0 p:predepends p:depends
276	while depends<>""
277	if not (depends parse any:(var Str defs) "," any:(var Str remain))
278	defs := depends ; remain := ""
279	var Str alldefs := defs
280	part study_one_condition
281	if (defs parse any:(var Str def) "|" any:(var Str remain2))
282	var CBool one := false
283	while defs<>""
284	if not (defs parse any:(var Str def) "|" any:(var Str remain2))
285	def := defs ; remain2 := ""
286	if not (def parse any:(var Str name) "(" any:(var Str cond) ")")
287	name := def ; cond := ""
288	if (satisfyed cond c:env:"package":name:"version") or (cond="" and (provide kmap name Bool false))
289	one := true
290	defs := remain2
291	if not one
292	# debian_trace trace "Condition "+alldefs+" requested by package "+p:name+" for computer "+computer_name+" is ambiguous"
293	alldefs parse  any:(var Str defs) "|" any:(var Str remain2)
294	restart study_one_condition
295	else
296	if not (defs parse any:(var Str name) "(" any:(var Str cond) ")")
297	name := defs ; cond := ""
298	if (provide kmap name Bool false)
299	void
300	eif not (exists c:env:"package":name)
301	var Link:DebianPackage q :> debian package name "" cond (var Str err)
302	if err=""
303	debian_trace trace "package " p:name " requires " q:name
304	c:env create "package"
305	c:env:"package" create q:name
306	c:env:"package":(q name) create "version"
307	c:env:"package":(q name):"version" := q version
308	c:env:"package":(q name) create "parent"
309	c:env:"package":(q name):"parent" := p name
310	var Str provides := q provides
311	while provides<>""
312	if not (provides parse any:(var Str name) "," any:(var Str remain2))
313	name := provides ; remain2 := ""
314	provide kmap name Bool := true
315	provides := remain2
316	else
317	return (failure "Cannot solve condition "+defs+" in package "+p:name+" for computer "+computer_name+" ("+err+")")
318	more := true
319	eif not (satisfyed cond c:env:"package":name:"version")
320	var Link:DebianPackage q :> debian package name "" cond (var Str err)
321	if err="" and ((compare_version q:version c:env:"package":name:"version") .and. compare_superior)<>0
322	# we can solve the problem through increasing the target package version
323	debian_trace trace "package " pkg:name " forced package " name " from " c:env:"package":name:"version" " to " q:name
324	c:env:"package":name "version" := q version
325	more := true
326	else
327	var Link:DebianPackage q :> debian package keyof:pkg "" ">> "+pkg:"version" (var Str err)
328	if err=""
329	# try to increase the source package version
330	debian_trace trace "package " pkg:name " tries to raise itself from " pkg:"version" " to " q:version " in order to solve conflict with " name
331	pkg "version" := q version
332	more := true
333	restart check_package
334	if not (exists pkg:"relax")
335	return (failure "Condition "+defs+" requested by package "+p:name+" for computer "+computer_name+" is unsatisfyed")
336	depends := remain
337	if more
338	restart complete
339	each pkg c:env:"package"
340	check pkg:"version"<>"any"
341	var Link:DebianPackage p :> debian package keyof:pkg
342	check p:name<>""
343	var Str conflicts := p conflicts
344	while conflicts<>""
345	if not (conflicts parse any:(var Str def) "," any:(var Str remain))
346	def := conflicts ; remain := ""
347	if not (def parse any:(var Str name) "(" any:(var Str cond) ")")
348	name := def ; cond := ""
349	if (satisfyed cond (debian package name):version)
350	debian_trace trace "version is " (debian package name):version
351	return (failure "Package "+p:name+" "+p:version+" conflicts with "+name+" for computer "+computer_name)
352	conflicts := remain
353	status := success
354	data_store
355
356	export debian_select
357
358
359	function debian_upgrade c -> status
360	arg Data:Computer c ; arg Status status
361	status := success
362	var Str ftp_server := c:env:"debian":"download":"ftp_server"
363	if ftp_server=""
364	ftp_server := "ftp.uk.debian.org"
365	file_tree_create "file:/fullpliant/debian/"
366	each rep c:env:"debian":"repository"
367	if rep<>""
368	if (rep search ":" -1)<>(-1)
369	if (file_copy rep+"Packages.gz" "file:/fullpliant/debian/packages_"+keyof:rep+".gz" reduced)=failure
370	status := failure
371	else
372	if (file_copy "ftp://"+ftp_server+"/debian/dists/"+rep+"Packages.gz" "file:/fullpliant/debian/packages_"+keyof:rep+".gz" reduced)=failure
373	if (file_copy "ftp://"+ftp_server+"/debian-non-US/dists/"+rep+"Packages.gz" "file:/fullpliant/debian/packages_"+keyof:rep+".gz" reduced)=failure
374	status := failure
375
376	export debian_upgrade
377
378
379	function debian_download c check -> status
380	arg_rw Data:Computer c ; arg CBool check ; arg Status status
381	status := success
382	(var Stream log) open "file:/tmp/download.log" out+safe
383	var Str computer_name := keyof c
384	(var DebianDistribution debian) bind c
385	var Dictionary download
386	var Int count := 0
387	var Int already := 0
388	var Intn total := 0
389	each pkg c:env:"package"
390	part prepare
391	var Str name := keyof pkg
392	var Str version := pkg "version"
393	var Link:DebianPackage p :> debian package name
394	if p:name=""
395	log writeline "Package "+name+" requested for computer "+computer_name+" is not available"
396	status := failure
397	leave prepare
398	var FileInfo local := file_query p:local_filename standard
399	var FileInfo alternate := file_query (replace p:local_filename "/fullpliant/debian/" "/fullpliant/debian.old/") standard
400	if local=undefined and alternate=defined
401	file_move alternate:name local:name
402	local := file_query p:local_filename standard
403	if local=undefined
404	download kmap name Str := version
405	count += 1
406	total += p size
407	debian_trace trace "package " pkg:name " needs to be downloaded"
408	eif (shunt check (file_md5_hexa_signature local:name)<>(upper p:md5) local:size<>p:size)
409	download kmap name Str := version
410	count += 1
411	total += p size
412	debian_trace trace "package " p:name " is corrupted"
413	else
414	already += 1
415	debian_trace trace already " ready to use packages."
416	debian_trace trace count " packages to download (" total " bytes , " total\2^20 " MB)."
417	console already " ready to use packages." eol
418	console count " packages to download (" total " bytes , " total\2^20 " MB)." eol
419	var DateTime start := datetime
420	var Intn done := 0
421	var Int failed := 0
422	each version download type Str getkey name
423	part download
424	var Link:DebianPackage p :> debian package name
425	if p:name=""
426	log writeline "Package "+name+" to be downloaded for computer "+computer_name+" is not available"
427	status := failure
428	leave download
429	debian_trace trace "download " p:base_section "/" p:base_filename
430	console "download " p:base_section "/" p:base_filename " "
431	var Str result := shunt (file_copy p:alternate_filename p:local_filename reduced+linktransparent)=success "ok" "FAILED"
432	if result="FAILED"
433	result := shunt (file_copy p:remote_filename p:local_filename reduced+linktransparent)=success "ok" "FAILED"
434	if result="FAILED" and (p:remote_filename search "/debian/" -1)<>(-1)
435	result := shunt (file_copy (replace p:remote_filename "/debian/" "/debian-non-US/") p:local_filename reduced+linktransparent)=success "ok" "FAILED"
436	if result="ok"
437	done += p size
438	if (file_md5_hexa_signature p:local_filename)<>(upper p:md5)
439	# file_delete p:local_filename
440	if result="ok"
441	result := "CORRUPTED"
442	var Float elapsed := datetime:seconds-start:seconds
443	if elapsed<=0.001
444	elapsed := 0.001
445	debian_trace trace result " " done*100\total "% " (cast (cast done Int)/elapsed Int) " cps"
446	console result " " done*100\total "% " (cast (cast done Int)/elapsed Int) " cps" eol
447	if result<>"ok"
448	failed += 1
449	status := failure
450	console "  " p:remote_filename eol
451	if count<>0
452	debian_trace trace "downloaded " count-failed " packages" (shunt failed<>0 " out of "+string:count+" expected" "")
453	console "downloaded " count-failed " packages" (shunt failed<>0 " out of "+string:count+" expected" "") eol
454	if status=success
455	file_delete "file:/tmp/download.log"
456
457	export debian_download
458
459
460
461
462	doc
463	para
464	['debian_unpack' is roughly equivalent to] ; fixed [ dpkg-deb --extract] ; eol
465	[It will create the following files in the path:]
466	list
467	item fixed:[control]
468	item fixed:[data.tar.gz]
469	item { fixed:[info/] ; italic [package_name] ; fixed [.list] }
470	item { fixed:[info/] ; italic [package_name] ; fixed [.conffiles] }
471	item { fixed:[info/] ; italic [package_name] ; fixed [.preinst] }
472	item { fixed:[info/] ; italic [package_name] ; fixed [.postinst] }
473	item { fixed:[info/] ; italic [package_name] ; fixed [.prerm] }
474	item { fixed:[info/] ; italic [package_name] ; fixed [.postrm] }
475	item { fixed:[info/] ; italic [package_name] ; fixed [.shlibs] }
476	item { fixed:[info/] ; italic [package_name] ; fixed [.md5sums] }
477
478
479	method debian unpack1 name file path -> status
480	arg DebianDistribution debian ; arg Str name file path ; arg Status status
481	var Link:DebianPackage p :> debian package name
482	if p:name=""
483	return failure
484	file_tree_delete path
485	(var Stream deb) open (shunt file<>"" file p:local_filename) in+safe
486	if deb=failure
487	return failure
488	var Str cmd := deb readline
489	if cmd<>"!<arch>"
490	return failure
491	while not deb:atend
492	var Str cmd := deb readline
493	if (cmd parse any:(var Str filename) _ (var Int i1) (var Int uid) (var Int gid) (var Int i2) (var Int size) "`")
494	(var Stream data) open path+filename out+mkdir
495	var Int remain := size
496	while remain>0 and { var Int step := raw_copy deb data 1 remain ; step>0 }
497	remain -= step
498	data close
499	eif cmd:parse
500	void
501	else
502	return failure
503	(var Stream data) open path+"debian-binary" in+safe
504	var Str ver := data readline
505	if ver<>"2.0"
506	return failure
507	status := success
508
509
510	method debian unpack name file target -> status
511	arg DebianDistribution debian ; arg Str name file target ; arg Status status
512	var Str temp := file_temporary+"_package/"
513	file_tree_delete temp
514	if (debian unpack1 name file temp)=failure
515	return failure
516	file_tree_create temp+"info/"
517	if (file_extract temp+"control.tar.gz" temp+"info/")=failure
518	debian_trace trace "Failed to extract configuration files in Debian package " name
519	return failure
520	(var Stream control) open temp+"info/control" in
521	var Str l := control readline
522	if not (l parse "Package" ":" pattern:name)
523	return failure
524	file_tree_create target+"var/lib/dpkg/info/"
525	if (execute "tar -zt -f "+file_os_name:temp+"data.tar.gz" output target+"var/lib/dpkg/info/"+name+".list")<>0
526	return failure
527	if (file_extract temp+"data.tar.gz" target)=failure
528	return failure
529	var Array:FileInfo files := file_list temp+"info/" standard+relative
530	for (var Int i) 0 files:size-1
531	if files:i:name<>"control"
532	file_move temp+"info/"+files:i:name target+"var/lib/dpkg/info/"+name+"."+files:i:name
533	(var Stream status1) open target+"var/lib/dpkg/status" in+safe
534	(var Stream status2) open target+"var/lib/dpkg/status.tmp" out+mkdir+safe
535	part scan_before
536	while not status1:atend
537	var Str l := status1 readline
538	if (l parse "Package" ":" pattern:name)
539	leave scan_before
540	status2 writeline l
541	part scan_drop
542	while not status1:atend
543	var Str l := status1 readline
544	status2 writeline l
545	if l=""
546	leave scan_drop
547	status2 writeline "Package: "+name
548	status2 writeline "Status: install ok unpacked"
549	while not control:atend
550	var Str l := control readline
551	if not (l parse "Architecture" ":" any)
552	status2 writeline l
553	if l<>""
554	status2 writeline ""
555	control close
556	while not status1:atend
557	status2 writeline status1:readline
558	status1 close ; status2 close
559	file_delete target+"var/lib/dpkg/status"
560	file_move target+"var/lib/dpkg/status.tmp" target+"var/lib/dpkg/status"
561	file_tree_delete temp
562	status := success
563
564	export DebianDistribution '. bind' '. unpack1' '. unpack'