uses Windows, fphttpapp, httpdefs, httproute;
var
svc_name: string = '_testservice';
svc_disp: string = '_My Test Service';
servicetable: TSERVICETABLEENTRY;
servicestatus: TSERVICESTATUS;
statushandle: SERVICE_STATUS_HANDLE;
ghSvcStopEvent: dword;
stopped: boolean = false;
paused: boolean = false;
procedure DoHello(ARequest: TRequest; AResponse: TResponse);
begin
AResponse.Content := '<html><body><h1>Hello World!</h1></body></html>';
end;
procedure httpapp;
begin
HTTPRouter.RegisterRoute('*', @DoHello);
Application.Port := 9000;
Application.Initialize;
Application.Run;
end;
function install_service(name, displayname, path: string): boolean;
var
manager, service: SC_HANDLE;
starttype: dword;
begin
result := false;
starttype := SERVICE_AUTO_START;
//starttype := SERVICE_DEMAND_START;
manager := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
if manager = 0 then exit;
service := CreateService(manager, pchar(name), pchar(displayname), SERVICE_ALL_ACCESS, SERVICE_WIN32_OWN_PROCESS +
SERVICE_INTERACTIVE_PROCESS, starttype, SERVICE_ERROR_IGNORE, pchar(path), nil, nil, nil, nil, nil);
if service > 0 then begin
result := true;
CloseServiceHandle(service);
end;
CloseServiceHandle(manager);
end;
function uninstall_service(name: string): boolean;
var
manager, service: SC_HANDLE;
status: TSERVICESTATUS;
begin
result := false;
manager := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
if manager = 0 then exit;
try
service := OpenService(manager, pchar(name), SERVICE_ALL_ACCESS);
if service = 0 then exit;
ControlService(service, SERVICE_CONTROL_STOP, status);
DeleteService(service);
CloseServiceHandle(service);
result := true;
finally
CloseServiceHandle(manager);
end;
end;
function start_service(name: string): boolean;
var
manager, service: SC_HANDLE;
args: LPPCSTR;
begin
result := false;
manager := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
if manager = 0 then exit;
try
service := OpenService(manager, pchar(name), SERVICE_ALL_ACCESS);
if service = 0 then exit;
args := nil;
result := StartService(service, 0, args);
finally
CloseServiceHandle(manager);
end;
end;
procedure service_report_status(dwCurrentState, dwWin32ExitCode, dwWaitHint: DWORD);
begin
ServiceStatus.dwCurrentState := dwCurrentState;
ServiceStatus.dwWin32ExitCode := dwWin32ExitCode;
ServiceStatus.dwWaitHint := dwWaitHint;
case dwCurrentState of
SERVICE_START_PENDING: ServiceStatus.dwControlsAccepted := 0;
else
ServiceStatus.dwControlsAccepted := SERVICE_ACCEPT_STOP + SERVICE_ACCEPT_PAUSE_CONTINUE
end;
case (dwCurrentState = SERVICE_RUNNING) or (dwCurrentState = SERVICE_STOPPED) of
true: ServiceStatus.dwCheckPoint := 0;
false: ServiceStatus.dwCheckPoint := 1;
end;
SetServiceStatus(StatusHandle, ServiceStatus);
end;
function service_handler(control: dword): longbool; stdcall;
begin
result := true;
case Control of
SERVICE_CONTROL_STOP:
begin
stopped := true;
SetEvent(ghSvcStopEvent);
ServiceStatus.dwCurrentState := SERVICE_STOP_PENDING;
SetServiceStatus(statushandle, servicestatus);
end;
SERVICE_CONTROL_PAUSE:
begin
paused := true;
ServiceStatus.dwcurrentstate := SERVICE_PAUSED;
SetServiceStatus(statushandle, servicestatus);
end;
SERVICE_CONTROL_CONTINUE:
begin
paused := false;
ServiceStatus.dwCurrentState := SERVICE_RUNNING;
SetServiceStatus(statushandle, servicestatus);
end;
SERVICE_CONTROL_INTERROGATE: SetServiceStatus(StatusHandle, ServiceStatus);
SERVICE_CONTROL_SHUTDOWN: stopped := true;
end;
end;
function svcmain(p: pointer): ptrint; stdcall;
begin
//while true do begin
// if stopped then break;
// if paused then begin sleep(500); continue; end;
//
// // do something?
//end;
// start httpapp
httpapp;
result := 0;
end;
procedure svcloop;
var
d: dword;
begin
ghSvcStopEvent := CreateEvent(nil, true, false, nil);
if ghSvcStopEvent = 0 then begin
service_report_status(SERVICE_STOPPED, NO_ERROR, 0);
exit;
end;
// start svcmian
CreateThread(nil, 0, @svcmain, nil, 0, d);
service_report_status(SERVICE_RUNNING, NO_ERROR, 0);
// wait for stop
WaitForSingleObject(ghSvcStopEvent, INFINITE);
// cleanup here
// ...
service_report_status(SERVICE_STOPPED, NO_ERROR, 0);
end;
procedure svcregister(dwArgc: longword; lpszArgv: LPPSTR); stdcall;
begin
with servicestatus do begin
dwServiceType := SERVICE_WIN32_OWN_PROCESS;
dwCurrentState := SERVICE_START_PENDING;
dwControlsAccepted := SERVICE_ACCEPT_STOP or SERVICE_ACCEPT_PAUSE_CONTINUE;
dwServiceSpecificExitCode := 0;
dwWin32ExitCode := 0;
dwCheckPoint := 0;
dwWaitHint := 0;
end;
statushandle := RegisterServiceCtrlHandler(pchar(svc_name), @service_handler);
if statushandle <> 0 then begin
service_report_status(SERVICE_RUNNING, NO_ERROR, 0);
svcloop;
service_report_status(SERVICE_STOPPED, NO_ERROR, 0);
end;
end;
begin
if paramstr(1) = 'i' then begin
writeln('installing...');
if not install_service(svc_name, svc_disp, paramstr(0)) then begin
writeln('install failed');
exit;
end;
if start_service(svc_name) then
writeln('service started')
else
writeln('service start failed');
end else if paramstr(1) = 'u' then begin
writeln('uninstalling...');
if uninstall_service(svc_name) then writeln('ok!') else writeln('fail');
end else begin
servicetable.lpServiceName := pchar(svc_name);
servicetable.lpServiceProc := @svcregister;
if not StartServiceCtrlDispatcher(@servicetable) then begin
writeln('i am not a service');
writeln('run with "i" param to install');
exit;
end;
end;
end.
Recent
