Skip to content
Merged
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
52 changes: 30 additions & 22 deletions main.ml
Original file line number Diff line number Diff line change
Expand Up @@ -22,20 +22,23 @@ open Types

let use_syslog = ref false

let info fmt =
let log level fmt =
Printf.ksprintf (fun s ->
if !use_syslog then begin
(* FIXME: this is synchronous and will block other I/O *)
Core.Syslog.syslog ~level:Core.Syslog.Level.INFO s;
return ()
Core.Syslog.syslog ~level ~facility:Core.Syslog.Facility.DAEMON s;
end else begin
let w = Lazy.force Writer.stderr in
Writer.write w s;
Writer.newline w;
Writer.flushed w;
Writer.newline w
end
) fmt

let debug fmt = log Core.Syslog.Level.DEBUG fmt
let info fmt = log Core.Syslog.Level.INFO fmt
let warn fmt = log Core.Syslog.Level.WARNING fmt
let error fmt = log Core.Syslog.Level.ERR fmt

let _nonpersistent = "NONPERSISTENT"
let _clone_on_boot_key = "clone-on-boot"

Expand All @@ -56,21 +59,25 @@ let missing_uri () =
let (>>>=) = Deferred.Result.(>>=)

let fork_exec_rpc root_dir script_name args response_of_rpc =
info "%s/%s %s" root_dir script_name (Jsonrpc.to_string args);
( Sys.is_file ~follow_symlinks:true script_name
>>= function
| `No | `Unknown ->
error "%s/%s is not a file" root_dir script_name;
return (Error(backend_error "SCRIPT_MISSING" [ script_name; "Check whether the file exists and has correct permissions" ]))
| `Yes -> return (Ok ())
) >>>= fun () ->
( Unix.access script_name [ `Exec ]
>>= function
| Error exn ->
error "%s/%s is not executable" root_dir script_name;
return (Error (backend_error "SCRIPT_NOT_EXECUTABLE" [ script_name; Exn.to_string exn ]))
| Ok () -> return (Ok ())
) >>>= fun () ->
Process.create ~prog:script_name ~args:["--json"] ~working_dir:root_dir ()
>>= function
| Error e ->
error "%s/%s failed: %s" root_dir script_name (Error.to_string_hum e);
return (Error(backend_error "SCRIPT_FAILED" [ script_name; Error.to_string_hum e ]))
| Ok p ->
(* Send the request as json on stdin *)
Expand All @@ -85,26 +92,34 @@ let fork_exec_rpc root_dir script_name args response_of_rpc =
(* Expect an exception and backtrace on stderr *)
begin match Or_error.try_with (fun () -> Jsonrpc.of_string output.Process.Output.stderr) with
| Error _ ->
error "%s/%s failed and printed bad error json: %s" root_dir script_name output.Process.Output.stderr;
return (Error (backend_error "SCRIPT_FAILED" [ script_name; "non-zero exit and bad json on stderr"; string_of_int code; output.Process.Output.stdout; output.Process.Output.stderr ]))
| Ok response ->
begin match Or_error.try_with (fun () -> error_of_rpc response) with
| Error _ -> return (Error (backend_error "SCRIPT_FAILED" [ script_name; "non-zero exit and bad json on stderr"; string_of_int code; output.Process.Output.stdout; output.Process.Output.stderr ]))
| Error _ ->
error "%s/%s failed and printed bad error json: %s" root_dir script_name output.Process.Output.stderr;
return (Error (backend_error "SCRIPT_FAILED" [ script_name; "non-zero exit and bad json on stderr"; string_of_int code; output.Process.Output.stdout; output.Process.Output.stderr ]))
| Ok x -> return (Error(backend_backtrace_error "SCRIPT_FAILED" [ script_name; "non-zero exit"; string_of_int code; output.Process.Output.stdout ] x))
end
end
| Error (`Signal signal) ->
error "%s/%s caught a signal and failed" root_dir script_name;
return (Error (backend_error "SCRIPT_FAILED" [ script_name; "signalled"; Signal.to_string signal; output.Process.Output.stdout; output.Process.Output.stderr ]))
| Ok () ->

(* Parse the json on stdout *)
begin match Or_error.try_with (fun () -> Jsonrpc.of_string output.Process.Output.stdout) with
| Error _ ->
error "%s/%s succeeded but printed bad json: %s" root_dir script_name output.Process.Output.stdout;
return (Error (backend_error "SCRIPT_FAILED" [ script_name; "bad json on stdout"; output.Process.Output.stdout ]))
| Ok response ->
begin match Or_error.try_with (fun () -> response_of_rpc response) with
| Error _ ->
error "%s/%s succeeded but printed bad json: %s" root_dir script_name output.Process.Output.stdout;
return (Error (backend_error "SCRIPT_FAILED" [ script_name; "json did not match schema"; output.Process.Output.stdout ]))
| Ok x -> return (Ok x)
| Ok x ->
info "%s/%s succeeded: %s" root_dir script_name output.Process.Output.stdout;
return (Ok x)
end
end
end
Expand Down Expand Up @@ -162,13 +177,11 @@ module Datapath_plugins = struct
fork_exec_rpc root_dir (script root_dir name (`Datapath name) "Plugin.Query") args Storage.Plugin.Types.Plugin.Query.Out.t_of_rpc
>>= function
| Ok response ->
info "Registered datapath plugin %s" name
>>= fun () ->
info "Registered datapath plugin %s" name;
Hashtbl.replace !table name response;
return ()
| _ ->
info "Failed to register datapath plugin %s" name
>>= fun () ->
info "Failed to register datapath plugin %s" name;
return ()

let unregister root_dir name =
Expand Down Expand Up @@ -728,8 +741,7 @@ let process root_dir name x =
Deferred.return (Error (backend_error "UNIMPLEMENTED" [ name ])))
>>= function
| Result.Error error ->
info "returning error %s" (Jsonrpc.string_of_response (R.failure error))
>>= fun () ->
info "returning error %s" (Jsonrpc.string_of_response (R.failure error));
return (Jsonrpc.string_of_response (R.failure error))
| Result.Ok rpc ->
return (Jsonrpc.string_of_response rpc)
Expand Down Expand Up @@ -759,17 +771,15 @@ let watch_volume_plugins ~root_dir ~switch_path =
if Hashtbl.mem servers name
then return ()
else begin
info "Adding %s" name
>>= fun () ->
info "Adding %s" name;
Protocol_async.Server.listen ~process:(process root_dir name) ~switch:switch_path ~queue:(Filename.basename name) ()
>>= fun result ->
let server = get_ok result in
Hashtbl.add_exn servers name server;
return ()
end in
let destroy switch_path name =
info "Removing %s" name
>>= fun () ->
info "Removing %s" name;
if Hashtbl.mem servers name then begin
let t = Hashtbl.find_exn servers name in
Protocol_async.Server.shutdown ~t () >>= fun () ->
Expand All @@ -793,8 +803,7 @@ let watch_volume_plugins ~root_dir ~switch_path =
let rec loop () =
( Pipe.read pipe >>= function
| `Eof ->
info "Received EOF from inotify event pipe"
>>= fun () ->
info "Received EOF from inotify event pipe";
Shutdown.exit 1
| `Ok (Created path)
| `Ok (Moved (Into path)) ->
Expand Down Expand Up @@ -833,8 +842,7 @@ let watch_datapath_plugins ~root_dir =
let rec loop () =
( Pipe.read pipe >>= function
| `Eof ->
info "Received EOF from inotify event pipe"
>>= fun () ->
info "Received EOF from inotify event pipe";
Shutdown.exit 1
| `Ok (Created path)
| `Ok (Moved (Into path)) ->
Expand Down Expand Up @@ -907,7 +915,7 @@ let _ =
if !Xcp_service.daemon then begin
Xcp_service.maybe_daemonize ();
use_syslog := true;
Core.Syslog.openlog ~id:"xapi-storage-script" ~facility:Core.Syslog.Facility.DAEMON ();
info "Daemonisation successful.";
end;
main ~root_dir:!root_dir ~state_path:!state_path ~switch_path:!Xcp_client.switch_path