httpcompiler.pp 14 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536
  1. unit httpcompiler;
  2. {$mode objfpc}
  3. {$H+}
  4. interface
  5. uses
  6. sysutils, classes, fpjson, contnrs, syncobjs, custhttpapp, fpwebfile, httproute,
  7. pas2jscompiler, httpdefs, dirwatch;
  8. Const
  9. nErrTooManyThreads = -1;
  10. Type
  11. TDirWatcher = Class;
  12. THTTPCompilerApplication = Class;
  13. { TCompileItem }
  14. TCompileItem = Class(TCollectionItem)
  15. private
  16. FBaseDir: string;
  17. FConfigFile: String;
  18. FFileName: string;
  19. FOutput : TStrings;
  20. FOptions : TStrings;
  21. FSuccess: Boolean;
  22. FThread: TThread;
  23. function GetOptions: TStrings;
  24. function GetOutput: TStrings;
  25. Public
  26. Destructor Destroy; override;
  27. Property BaseDir : string Read FBaseDir Write FBaseDir;
  28. Property FileName : string Read FFileName Write FFileName;
  29. Property ConfigFile: String Read FConfigFile Write FConfigFile;
  30. Property Options : TStrings Read GetOptions;
  31. Property Output : TStrings Read GetOutput;
  32. Property Thread : TThread Read FThread;
  33. Property Success : Boolean Read FSuccess;
  34. end;
  35. { TCompiles }
  36. TCompiles = Class(TCollection)
  37. private
  38. function GetC(AIndex : Integer): TCompileItem;
  39. Public
  40. Property Compiles[AIndex : Integer] : TCompileItem Read GetC; default;
  41. end;
  42. { TCompileThread }
  43. TCompileThread = class(TThread)
  44. private
  45. FApp : THTTPCompilerApplication;
  46. FItem: TCompileItem;
  47. procedure DoCompilerLog(Sender: TObject; const Msg: String);
  48. procedure SetItem(AValue: TCompileItem);
  49. Public
  50. Constructor create(App : THTTPCompilerApplication; aItem : TCompileItem);
  51. Procedure Execute; override;
  52. Property Item : TCompileItem read FItem write SetItem;
  53. end;
  54. { TDirWatcher }
  55. TDirWatcher = Class(TComponent)
  56. Private
  57. FApp : THTTPCompilerApplication;
  58. FDW : TDirWatch;
  59. procedure DoChange(Sender: TObject; aEntry: TDirectoryEntry; AEvents: TFileEvents);
  60. Public
  61. Constructor Create(App : THTTPCompilerApplication; ADir : String);overload;
  62. Destructor Destroy; override;
  63. end;
  64. { THTTPCompilerApplication }
  65. THTTPCompilerApplication = Class(TCustomHTTPApplication)
  66. private
  67. FBaseDir: String;
  68. FConfigFile: String;
  69. FProjectFile: String;
  70. FStatusLock : TCriticalSection;
  71. FQuiet: Boolean;
  72. FWatch: Boolean;
  73. FDW : TDirWatcher;
  74. FStatusList : TFPObjectList;
  75. FCompiles : TCompiles;
  76. procedure AddToStatus(O: TJSONObject);
  77. Procedure ReportBuilding(AItem : TCompileItem);
  78. Procedure ReportBuilt(AItem : TCompileItem);
  79. Procedure AddToStatus(AEntry : TDirectoryEntry; AEvents : TFileEvents);
  80. procedure DoStatusRequest(ARequest: TRequest; AResponse: TResponse);
  81. procedure DoRecompile(ARequest: TRequest; AResponse: TResponse);
  82. function ScheduleCompile(const aProjectFile: String; Options : TStrings = Nil): Integer;
  83. procedure StartWatch(ADir: String);
  84. procedure Usage(Msg: String);
  85. public
  86. Constructor Create(AOWner : TComponent); override;
  87. Destructor Destroy; override;
  88. procedure DoLog(EventType: TEventType; const Msg: String); override;
  89. Procedure DoRun; override;
  90. property Quiet : Boolean read FQuiet Write FQuiet;
  91. Property Watch : Boolean Read FWatch Write FWatch;
  92. Property ProjectFile : String Read FProjectFile Write FProjectFile;
  93. Property ConfigFile : String Read FConfigFile Write FConfigFile;
  94. Property BaseDir : String Read FBaseDir;
  95. end;
  96. Implementation
  97. { TCompileThread }
  98. procedure TCompileThread.SetItem(AValue: TCompileItem);
  99. begin
  100. if FItem=AValue then Exit;
  101. FItem:=AValue;
  102. end;
  103. procedure TCompileThread.DoCompilerLog(Sender: TObject; const Msg: String);
  104. begin
  105. If Assigned(Item) then
  106. Item.Output.Add(Msg);
  107. end;
  108. constructor TCompileThread.create(App: THTTPCompilerApplication; aItem: TCompileItem);
  109. begin
  110. FItem:=aItem;
  111. FApp:=App;
  112. FreeOnTerminate:=True;
  113. inherited create(False);
  114. end;
  115. procedure TCompileThread.Execute;
  116. Var
  117. C : TPas2jsCompiler;
  118. L : TStrings;
  119. begin
  120. L:=Nil;
  121. C:=TPas2jsCompiler.Create;
  122. Try
  123. FApp.ReportBuilding(Item);
  124. L:=TStringList.Create;
  125. L.Assign(Item.Options);
  126. if (Item.ConfigFile<>'') then
  127. L.Add('@'+Item.ConfigFile);
  128. L.Add(Item.FileName);
  129. C.Log.OnLog:=@DoCompilerLog;
  130. try
  131. C.Run(ParamStr(0),Item.BaseDir,L,True);
  132. Item.FSuccess:=True;
  133. except
  134. On E : Exception do
  135. Item.Output.Add(Format('Error %s compiling %s: %s',[E.ClassName,Item.FileName,E.Message]));
  136. end;
  137. FApp.ReportBuilt(Item);
  138. Finally
  139. C.Free;
  140. L.Free;
  141. end;
  142. Item.FThread:=Nil;
  143. end;
  144. { TCompiles }
  145. function TCompiles.GetC(AIndex : Integer): TCompileItem;
  146. begin
  147. Result:=Items[Aindex] as TCompileItem;
  148. end;
  149. { TCompileItem }
  150. function TCompileItem.GetOutput: TStrings;
  151. begin
  152. If (FOutput=Nil) then
  153. FOutput:=TStringList.Create;
  154. Result:=FOutput;
  155. end;
  156. function TCompileItem.GetOptions: TStrings;
  157. begin
  158. If (FOptions=Nil) then
  159. FOptions:=TStringList.Create;
  160. Result:=FOptions;
  161. end;
  162. destructor TCompileItem.Destroy;
  163. begin
  164. FreeAndNil(FOutput);
  165. FreeAndNil(FOptions);
  166. inherited Destroy;
  167. end;
  168. { TDirWatcher }
  169. procedure TDirWatcher.DoChange(Sender: TObject; aEntry: TDirectoryEntry; AEvents: TFileEvents);
  170. begin
  171. if Assigned(FApp) then
  172. FApp.AddToStatus(AEntry,AEvents);
  173. end;
  174. constructor TDirWatcher.Create(App: THTTPCompilerApplication; ADir: String);
  175. begin
  176. Inherited create(APP);
  177. FApp:=App;
  178. FDW:=TDirwatch.Create(Self);
  179. FDW.AddWatch(ADir,allEvents);
  180. FDW.OnChange:=@DoChange;
  181. TThread.ExecuteInThread(@FDW.StartWatch);
  182. end;
  183. destructor TDirWatcher.Destroy;
  184. begin
  185. FApp:=Nil;
  186. FDW.Terminate;
  187. FreeAndNil(FDW);
  188. inherited Destroy;
  189. end;
  190. { THTTPCompilerApplication }
  191. procedure THTTPCompilerApplication.DoLog(EventType: TEventType; const Msg: String);
  192. begin
  193. {AllowWriteln}
  194. if Quiet then
  195. exit;
  196. if IsConsole then
  197. Writeln(FormatDateTime('yyyy-mm-dd hh:nn:ss.zzz',Now),' [',EventType,'] ',Msg)
  198. else
  199. inherited DoLog(EventType, Msg);
  200. {AllowWriteln-}
  201. end;
  202. procedure THTTPCompilerApplication.Usage(Msg : String);
  203. begin
  204. {AllowWriteln}
  205. if (Msg<>'') then
  206. Writeln('Error: ',Msg);
  207. Writeln('Usage ',ExtractFileName(ParamStr(0)),' [options] ');
  208. Writeln('Where options is one or more of : ');
  209. Writeln('-d --directory=dir Base directory from which to serve files.');
  210. Writeln(' Default is current working directory: ',GetCurrentDir);
  211. Writeln('-h --help This help text');
  212. Writeln('-i --indexpage=name Directory index page to use (default: index.html)');
  213. Writeln('-n --noindexpage Do not allow index page.');
  214. Writeln('-p --port=NNNN TCP/IP port to listen on (default is 3000)');
  215. Writeln('-q --quiet Do not write diagnostic messages');
  216. Writeln('-w --watch Watch directory for changes');
  217. Writeln('-c --compile[=proj] Recompile project if pascal files change. Default project is app.lpr');
  218. Halt(Ord(Msg<>''));
  219. {AllowWriteln-}
  220. end;
  221. constructor THTTPCompilerApplication.Create(AOWner: TComponent);
  222. begin
  223. inherited Create(AOWner);
  224. FStatusLock:=TCriticalSection.Create;
  225. FStatusList:=TFPObjectList.Create(False);
  226. FCompiles:=TCompiles.Create(TCompileItem);
  227. end;
  228. destructor THTTPCompilerApplication.Destroy;
  229. begin
  230. FStatusLock.Enter;
  231. try
  232. FreeAndNil(FCompiles);
  233. FreeAndNil(FStatusList);
  234. finally
  235. FStatusLock.Leave;
  236. end;
  237. FreeAndNil(FStatusLock);
  238. inherited Destroy;
  239. end;
  240. procedure THTTPCompilerApplication.StartWatch(ADir : String);
  241. begin
  242. FDW:=TDirWatcher.Create(Self,ADir);
  243. end;
  244. procedure THTTPCompilerApplication.ReportBuilding(AItem: TCompileItem);
  245. Var
  246. O : TJSONObject;
  247. begin
  248. O:=TJSONObject.Create(['action','building','compileID',AItem.ID,'project',AItem.FileName,'config',AItem.ConfigFile]);
  249. AddToStatus(O);
  250. end;
  251. procedure THTTPCompilerApplication.ReportBuilt(AItem: TCompileItem);
  252. Var
  253. O : TJSONObject;
  254. A : TJSONArray;
  255. I : Integer;
  256. begin
  257. A:=TJSONArray.Create;
  258. For I:=0 to AItem.Output.Count-1 do
  259. A.Add(AItem.Output[i]);
  260. O:=TJSONObject.Create(['action','built','compileID',AItem.ID,'project',AItem.FileName,'config',AItem.ConfigFile,'output',A,'success',AItem.Success]);
  261. AddToStatus(O);
  262. end;
  263. procedure THTTPCompilerApplication.AddToStatus(O : TJSONObject);
  264. begin
  265. FStatusLock.Enter;
  266. try
  267. {$ifdef VerboseHTTPCompiler}
  268. Writeln('Adding to status ',Assigned(O),' : ',O.ClassName);
  269. {$endif}
  270. FStatusList.Add(O);
  271. finally
  272. FStatusLock.Leave;
  273. end;
  274. end;
  275. procedure THTTPCompilerApplication.AddToStatus(AEntry: TDirectoryEntry; AEvents: TFileEvents);
  276. Var
  277. O : TJSONObject;
  278. FN : String;
  279. begin
  280. Log(etDebug,'File change detected: %s (%s)',[AEntry.name,FileEventsToStr(AEvents)]);
  281. O:=TJSONObject.Create(['action','file','name',AEntry.name,'events',FileEventsToStr(AEvents)]);
  282. if Pos(ExtractFileExt(AEntry.Name),'.lpr.pas.pp.inc.dpr')>0 then
  283. FN:=AEntry.Name;
  284. if (FN<>'') then
  285. O.Add('recompile',true);
  286. AddToStatus(O);
  287. if (FN<>'') then
  288. begin
  289. Log(etDebug,'File change forces recompile: %s',[AEntry.name]);
  290. ScheduleCompile('',Nil);
  291. end;
  292. end;
  293. procedure THTTPCompilerApplication.DoStatusRequest(ARequest : TRequest; AResponse : TResponse);
  294. Var
  295. R,O : TJSONObject;
  296. A : TJSONArray;
  297. I : integer;
  298. begin
  299. Log(etDebug,'Status request from: %s',[ARequest.RemoteAddress]);
  300. R:=Nil;
  301. try
  302. FStatusLock.Enter;
  303. try
  304. if (FStatusList.Count=0) then
  305. R:=TJSONObject.Create(['ping',True])
  306. else
  307. begin
  308. {$ifdef VerboseHTTPCompiler}
  309. Writeln(FStatusList[0].ClassName);
  310. {$endif}
  311. O:=FStatusList[0] as TJSONObject;
  312. FStatusList.Delete(0);
  313. if O.Get('action','')<>'file' then
  314. R:=O
  315. else
  316. begin
  317. // If first event is file event, then add and delete all file events in list.
  318. A:=TJSONArray.Create([O]);
  319. O.Delete('action');
  320. R:=TJSONObject.Create(['action','sync','files',A]);
  321. For I:=FStatusList.Count-1 downto 0 do
  322. begin
  323. O:=FStatusList[I] as TJSONObject;
  324. if (O.Get('action','')='file') then
  325. begin
  326. A.Add(O);
  327. O.Delete('action');
  328. FStatusList.Delete(I);
  329. end;
  330. end;
  331. end
  332. end;
  333. finally
  334. FStatusLock.Leave;
  335. end;
  336. AResponse.ContentType:='application/json';
  337. AResponse.Content:=R.AsJSON;
  338. AResponse.SendResponse;
  339. finally
  340. R.Free;
  341. end;
  342. end;
  343. Function THTTPCompilerApplication.ScheduleCompile(const aProjectFile : String; Options : TStrings = Nil) : Integer;
  344. Var
  345. CI : TCompileItem;
  346. I,TC : Integer;
  347. begin
  348. TC:=0;
  349. For I:=0 to FCompiles.Count-1 do
  350. if Assigned(FCompiles[I].THread) then
  351. Inc(TC);
  352. if TC>10 then
  353. begin
  354. Log(etError,'Refusing compile of file "%s" using config file "%s"',[AProjectFile, ConfigFile]);
  355. Exit(nErrTooManyThreads);
  356. end;
  357. CI:=FCompiles.Add as TCompileItem;
  358. Log(etInfo,'Scheduling compile ID %d of file "%s" using config file "%s"',[CI.ID,AProjectFile, ConfigFile]);
  359. CI.BaseDir:=BaseDir;
  360. CI.FileName:=AProjectFile;
  361. CI.ConfigFile:=ConfigFile;
  362. if Assigned(Options) then
  363. CI.Options.Assign(Options);
  364. TCompileThread.Create(Self,CI);
  365. Result:=CI.ID;
  366. end;
  367. procedure THTTPCompilerApplication.DoRecompile(ARequest: TRequest; AResponse: TResponse);
  368. Var
  369. ID : Integer;
  370. PF,CL : String;
  371. Options: TStrings;
  372. begin
  373. PF:=ARequest.ContentFields.Values['ProjectFile'];
  374. CL:=ARequest.ContentFields.Values['CompileOptions'];
  375. if PF='' then
  376. PF:=ProjectFile;
  377. If (PF='') then
  378. begin
  379. AResponse.Code:=404;
  380. AResponse.CodeText:='No project file';
  381. AResponse.ContentType:='application/json';
  382. AResponse.Content:='{ "success" : false, "message": "no project file set or provided" }';
  383. end
  384. else
  385. begin
  386. Options:=Nil;
  387. try
  388. if CL<>'' then
  389. begin
  390. Options:=TStringList.Create;
  391. Options.Text:=Cl;
  392. end;
  393. ID:=ScheduleCompile(PF,Options);
  394. finally
  395. FreeAndNil(Options);
  396. end;
  397. if ID=nErrTooManyThreads then
  398. begin
  399. AResponse.Code:=403;
  400. AResponse.CodeText:='Too many compiles';
  401. AResponse.ContentType:='application/json';
  402. AResponse.Content:='{ "success" : false, "message": "Too many compiles running" }';
  403. end
  404. else
  405. begin
  406. AResponse.Code:=200;
  407. AResponse.ContentType:='application/json';
  408. AResponse.Content:=Format('{ "success" : true, "file": "%s", "commandLine" : "%s", "compileID": %d }',[StringToJSONString(PF),StringToJSONString(CL),ID]);
  409. end
  410. end;
  411. AResponse.SendResponse;
  412. end;
  413. procedure THTTPCompilerApplication.DoRun;
  414. Var
  415. S,IndexPage,D : String;
  416. begin
  417. S:=Checkoptions('hqd:ni:p:wP::c',['help','quiet','noindexpage','directory:','port:','indexpage:','watch','project::','config:']);
  418. if (S<>'') or HasOption('h','help') then
  419. usage(S);
  420. Quiet:=HasOption('q','quiet');
  421. Watch:=HasOption('w','watch');
  422. Port:=StrToIntDef(GetOptionValue('p','port'),3000);
  423. D:=GetOptionValue('d','directory');
  424. if D='' then
  425. D:=GetCurrentDir;
  426. Log(etInfo,'Listening on port %d, serving files from directory: %s',[Port,D]);
  427. {$ifdef unix}
  428. MimeTypesFile:='/etc/mime.types';
  429. {$endif}
  430. if Hasoption('P','project') then
  431. begin
  432. ProjectFile:=GetOptionValue('P','project');
  433. if ProjectFile='' then
  434. ProjectFile:=IncludeTrailingPathDelimiter(D)+'app.lpr';
  435. If Not FileExists(ProjectFile) then
  436. begin
  437. Terminate;
  438. Log(etError,'Project file "%s" does not exist, aborting.',[ProjectFile]);
  439. Exit;
  440. end;
  441. ConfigFile:=GetOptionValue('c','config');
  442. if (ConfigFile='') then
  443. ConfigFile:=ChangeFileExt(Projectfile,'.cfg');
  444. if not FileExists(ConfigFile) then
  445. ConfigFile:='';
  446. end;
  447. if Watch then
  448. begin
  449. if (ProjectFile='') then
  450. Log(etWarning,'No project file specified, disabling watch.') ;
  451. StartWatch(D);
  452. end;
  453. FBaseDir:=D;
  454. TSimpleFileModule.BaseDir:=IncludeTrailingPathDelimiter(D);
  455. TSimpleFileModule.OnLog:=@Log;
  456. If not HasOption('n','noindexpage') then
  457. begin
  458. IndexPage:=GetOptionValue('i','indexpage');
  459. if (IndexPage='') then
  460. IndexPage:='index.html';
  461. Log(etInfo,'Using index page %s',[IndexPage]);
  462. TSimpleFileModule.IndexPageName:=IndexPage;
  463. end;
  464. httprouter.RegisterRoute('$sys/compile',rmPost,@DoRecompile);
  465. httprouter.RegisterRoute('$sys/status',rmGet,@DoStatusRequest);
  466. TSimpleFileModule.RegisterDefaultRoute;
  467. inherited;
  468. end;
  469. end.