b4fb92f38e2fe02149c6c6127db99be9b9deecd0
[mclu.git] / mclu_boot.ml
1 (* mclu: Mini Cloud
2  * Copyright (C) 2014-2015 Red Hat Inc.
3  *
4  * This program is free software; you can redistribute it and/or modify
5  * it under the terms of the GNU General Public License as published by
6  * the Free Software Foundation; either version 2 of the License, or
7  * (at your option) any later version.
8  *
9  * This program is distributed in the hope that it will be useful,
10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12  * GNU General Public License for more details.
13  *
14  * You should have received a copy of the GNU General Public License
15  * along with this program; if not, write to the Free Software
16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
17  *)
18
19 (* Implement 'mclu boot'. *)
20
21 module C = Libvirt.Connect
22 module D = Libvirt.Domain
23 module MS = Mclu_status
24
25 open Printf
26
27 open Utils
28
29 let memory = ref 0L                     (* 0 = choose for me *)
30 let set_memory s =
31   try memory := bytes_of_human_size s
32   with Not_found ->
33     eprintf "mclu: don't understand --memory parameter '%s'
34 Try something like --memory 1G\n" s;
35     exit 1
36 let vcpus = ref 0                       (* 0 = choose for me *)
37
38 let get_arg_speclist () = Arg.align [
39   "--cpus",     Arg.Set_int vcpus, "n Number of virtual CPUs";
40   "--memory",   Arg.String set_memory, "nnG Amount of RAM to give guest";
41   "--ram",      Arg.String set_memory, "nnG Amount of RAM to give guest";
42   "--vcpus",    Arg.Set_int vcpus, "n Number of virtual CPUs";
43 ]
44
45 let boot ~verbose template name =
46   let templates = Template.templates () in
47
48   (* Does the template exist? *)
49   let template_filename =
50     try List.assoc template templates
51     with Not_found ->
52       eprintf "mclu: template %s not found
53 Try `mclu list --templates' to list all known templates.\n" template;
54       exit 1 in
55
56   (* Probe the template for various features. *)
57   let template_info = Template.probe ~verbose template_filename in
58
59   (* Decide how much RAM we will give the guest.  This affects our
60    * choice of node, so do it early.
61    *)
62   let memory = !memory in
63   let memory =
64     if memory > 0L then (
65       (* User requested, just check it's above the minimum. *)
66       match template_info.Template.minimum_memory with
67       | None -> memory
68       | Some min when min > memory ->
69         eprintf "mclu: minimum memory for this template is %s\n"
70           (human_size min);
71         exit 1
72       | Some _ -> memory
73     ) else (
74       (* User didn't request any memory setting, use the recommended. *)
75       match template_info.Template.recommended_memory with
76       | Some memory -> memory
77       | None -> 4L *^ 1024L *^ 1024L *^ 1024L (* 4 GB *)
78     ) in
79
80   (* Check what's running. *)
81   let summary = MS.node_guest_summary ~verbose () in
82
83   (* Did the user request a specific host?  If not, choose one. *)
84   let hostname, name =
85     match name_parse name with
86     | Some hostname, name -> hostname, name
87     | None, name ->
88       (* Choose the first host with enough free memory. *)
89       let nodes = List.filter (
90         fun { MS.free_memory = free_memory } -> free_memory >= memory
91       ) summary in
92       match nodes with
93       | [] ->
94         eprintf "mclu: no node with enough free memory found
95 Try: `mclu status' and `mclu on <node>'\n";
96         exit 1
97       | node :: _ ->
98         let hostname =
99           node.MS.node_status.MS.node.Mclu_conf.hostname in
100         hostname, name in
101
102   (* Check there isn't a guest with this name running anywhere
103    * in the cluster already.
104    *)
105   List.iter (
106     fun ({ MS.active_guests = guests } as node) ->
107       List.iter (
108         fun { Mclu_list.dom_name = n } ->
109           if name = n then (
110             let hostname =
111               node.MS.node_status.MS.node.Mclu_conf.hostname
112             in
113             eprintf "mclu: there is already a guest called '%s' (running on %s)\n"
114               name hostname;
115             exit 1
116           )
117       ) guests
118   ) summary;
119
120   (* Convert hostname to a specific node, and check it is up. *)
121   let node =
122     try List.find (
123       fun node ->
124         node.MS.node_status.MS.node.Mclu_conf.hostname = hostname
125     ) summary
126     with Not_found ->
127       eprintf "mclu: no node is called '%s'\n" hostname;
128       exit 1 in
129   if not node.MS.node_status.MS.node_on then (
130     eprintf "mclu: node '%s' is switched off
131 Try: `mclu on %s'\n" hostname hostname;
132     exit 1
133   );
134
135   (* Where we upload the template and image on remote. *)
136   let format, extension = "qcow2", "qcow2" in
137   let remote_filename = sprintf "/tmp/mclu%s.sh" (string_random8 ()) in
138   let remote_image = sprintf "/var/tmp/%s.%s" name extension in
139
140   (* Get ready to generate the guest XML. *)
141   let vcpus = !vcpus in
142   let vcpus =
143     if vcpus > 0 then vcpus
144     else min 4 node.MS.node_status.MS.node_info.C.cpus in
145   let mac_addr =
146     sprintf "52:54:00:%02x:%02x:%02x"
147       (Random.int 256) (Random.int 256) (Random.int 256) in
148
149   (* Generate the guest XML.  XXX Quoting. *)
150   let xml = sprintf "\
151 <domain type='kvm'>
152   <name>%s</name>
153   <memory unit='KiB'>%Ld</memory>
154   <currentMemory unit='KiB'>%Ld</currentMemory>
155   <vcpu>%d</vcpu>
156   <os>
157     <type>hvm</type>
158     <boot dev='hd'/>
159   </os>
160   <features>
161     <acpi/>
162     <apic/>
163     <pae/>
164   </features>
165   <cpu mode='host-model' fallback='allow' />
166   <clock offset='utc'>
167     <timer name='rtc' tickpolicy='catchup'/>
168     <timer name='pit' tickpolicy='delay'/>
169     <timer name='hpet' present='no'/>
170   </clock>
171   <on_poweroff>destroy</on_poweroff>
172   <on_reboot>restart</on_reboot>
173   <on_crash>restart</on_crash>
174   <devices>
175 " name (memory /^ 1024L) (memory /^ 1024L) vcpus in
176
177   let xml = xml ^ sprintf "\
178   <disk type='file' device='disk'>
179     <driver name='qemu' type='%s' cache='none' io='native'/>
180     <source file='%s'/>
181 " format remote_image in
182   let xml = xml ^
183     match template_info.Template.disk_bus with
184     | Some "ide" ->
185       "      <target dev='sda' bus='ide'/>\n"
186     | Some "virtio-scsi" | None ->
187       "      <target dev='sda' bus='scsi'/>\n"
188     | Some bus ->
189       eprintf "mclu: unknown disk-bus: %s\n" bus;
190       exit 1 in
191   let xml = xml ^ "\
192     </disk>
193 " in
194
195   let xml = xml ^
196     if template_info.Template.disk_bus = Some "virtio-scsi" then
197       "  <controller type='scsi' index='0' model='virtio-scsi'/>\n"
198     else
199       "" in
200
201   (* XXX Don't hard-code bridge name here. *)
202   let network_model =
203     match template_info with
204     | { Template.network_model = None } -> "virtio"
205     | { Template.network_model = Some d } -> d in
206   let xml = xml ^ sprintf "\
207     <interface type='bridge'>
208       <mac address='%s'/>
209       <source bridge='br0'/>
210       <model type='%s'/>
211     </interface>
212 " mac_addr network_model in
213
214   let xml = xml ^ "\
215     <serial type='pty'>
216       <target port='0'/>
217     </serial>
218     <console type='pty'>
219       <target type='serial' port='0'/>
220     </console>
221     <input type='tablet' bus='usb'/>
222     <input type='mouse' bus='ps2'/>
223     <input type='keyboard' bus='ps2'/>
224     <graphics type='vnc' autoport='yes'/>
225     <video>
226       <model type='cirrus' vram='9216' heads='1'/>
227     </video>
228   </devices>
229 </domain>" in
230
231   (* Copy the template to remote and build the guest. *)
232   let cmd =
233     sprintf "scp %s root@%s:%s"
234       (quote template_filename) (quote hostname) remote_filename in
235   if verbose then printf "%s\n%!" cmd;
236   if Sys.command cmd <> 0 then (
237     eprintf "mclu: scp template to remote failed\n";
238     exit 1
239   );
240   let cmd =
241     (* XXX Don't hard-code network_bridge here. *)
242     sprintf "ssh root@%s LIBGUESTFS_BACKEND_SETTINGS=network_bridge=br0 %s build %s %s %s"
243       (quote hostname) remote_filename
244       (quote template_info.Template.base_image) (quote remote_image)
245       format in
246   if verbose then printf "%s\n%!" cmd;
247   if Sys.command cmd <> 0 then (
248     eprintf "mclu: remote build failed\n";
249     exit 1
250   );
251
252   (* Start the guest. *)
253   try
254     let conn =
255       let name = node.MS.node_status.MS.node.Mclu_conf.libvirt_uri in
256       C.connect ~name () in
257     let dom = D.create_xml conn xml [] in
258     printf "mclu: %s:%s started\n" hostname (D.get_name dom)
259   with Libvirt.Virterror msg ->
260     eprintf "mclu: %s: %s\n" hostname (Libvirt.Virterror.to_string msg);
261     exit 1
262
263 let run ~verbose = function
264   | [ template; name ] ->
265     boot ~verbose template name
266   | _ ->
267     eprintf "Usage: mclu boot <template> <[host:]name>\n";
268     exit 1