slogsend.pas 9.7 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320
  1. {==============================================================================|
  2. | Project : Ararat Synapse | 001.002.003 |
  3. |==============================================================================|
  4. | Content: SysLog client |
  5. |==============================================================================|
  6. | Copyright (c)1999-2010, Lukas Gebauer |
  7. | All rights reserved. |
  8. | |
  9. | Redistribution and use in source and binary forms, with or without |
  10. | modification, are permitted provided that the following conditions are met: |
  11. | |
  12. | Redistributions of source code must retain the above copyright notice, this |
  13. | list of conditions and the following disclaimer. |
  14. | |
  15. | Redistributions in binary form must reproduce the above copyright notice, |
  16. | this list of conditions and the following disclaimer in the documentation |
  17. | and/or other materials provided with the distribution. |
  18. | |
  19. | Neither the name of Lukas Gebauer nor the names of its contributors may |
  20. | be used to endorse or promote products derived from this software without |
  21. | specific prior written permission. |
  22. | |
  23. | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
  24. | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
  25. | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
  26. | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
  27. | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
  28. | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
  29. | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
  30. | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
  31. | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
  32. | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
  33. | DAMAGE. |
  34. |==============================================================================|
  35. | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
  36. | Portions created by Lukas Gebauer are Copyright (c)2001-2010. |
  37. | All Rights Reserved. |
  38. |==============================================================================|
  39. | Contributor(s): |
  40. | Christian Brosius |
  41. |==============================================================================|
  42. | History: see HISTORY.HTM from distribution package |
  43. | (Found at URL: http://www.ararat.cz/synapse/) |
  44. |==============================================================================}
  45. {:@abstract(BSD SYSLOG protocol)
  46. Used RFC: RFC-3164
  47. }
  48. {$IFDEF FPC}
  49. {$MODE DELPHI}
  50. {$ENDIF}
  51. {$Q-}
  52. {$H+}
  53. unit slogsend;
  54. interface
  55. uses
  56. SysUtils, Classes,
  57. blcksock, synautil;
  58. const
  59. cSysLogProtocol = '514';
  60. FCL_Kernel = 0;
  61. FCL_UserLevel = 1;
  62. FCL_MailSystem = 2;
  63. FCL_System = 3;
  64. FCL_Security = 4;
  65. FCL_Syslogd = 5;
  66. FCL_Printer = 6;
  67. FCL_News = 7;
  68. FCL_UUCP = 8;
  69. FCL_Clock = 9;
  70. FCL_Authorization = 10;
  71. FCL_FTP = 11;
  72. FCL_NTP = 12;
  73. FCL_LogAudit = 13;
  74. FCL_LogAlert = 14;
  75. FCL_Time = 15;
  76. FCL_Local0 = 16;
  77. FCL_Local1 = 17;
  78. FCL_Local2 = 18;
  79. FCL_Local3 = 19;
  80. FCL_Local4 = 20;
  81. FCL_Local5 = 21;
  82. FCL_Local6 = 22;
  83. FCL_Local7 = 23;
  84. type
  85. {:@abstract(Define possible priority of Syslog message)}
  86. TSyslogSeverity = (Emergency, Alert, Critical, Error, Warning, Notice, Info,
  87. Debug);
  88. {:@abstract(encoding or decoding of SYSLOG message)}
  89. TSyslogMessage = class(TObject)
  90. private
  91. FFacility:Byte;
  92. FSeverity:TSyslogSeverity;
  93. FDateTime:TDateTime;
  94. FTag:String;
  95. FMessage:String;
  96. FLocalIP:String;
  97. function GetPacketBuf:String;
  98. procedure SetPacketBuf(Value:String);
  99. public
  100. {:Reset values to defaults}
  101. procedure Clear;
  102. published
  103. {:Define facilicity of Syslog message. For specify you may use predefined
  104. FCL_* constants. Default is "FCL_Local0".}
  105. property Facility:Byte read FFacility write FFacility;
  106. {:Define possible priority of Syslog message. Default is "Debug".}
  107. property Severity:TSyslogSeverity read FSeverity write FSeverity;
  108. {:date and time of Syslog message}
  109. property DateTime:TDateTime read FDateTime write FDateTime;
  110. {:This is used for identify process of this message. Default is filename
  111. of your executable file.}
  112. property Tag:String read FTag write FTag;
  113. {:Text of your message for log.}
  114. property LogMessage:String read FMessage write FMessage;
  115. {:IP address of message sender.}
  116. property LocalIP:String read FLocalIP write FLocalIP;
  117. {:This property holds encoded binary SYSLOG packet}
  118. property PacketBuf:String read GetPacketBuf write SetPacketBuf;
  119. end;
  120. {:@abstract(This object implement BSD SysLog client)
  121. Note: Are you missing properties for specify server address and port? Look to
  122. parent @link(TSynaClient) too!}
  123. TSyslogSend = class(TSynaClient)
  124. private
  125. FSock: TUDPBlockSocket;
  126. FSysLogMessage: TSysLogMessage;
  127. public
  128. constructor Create;
  129. destructor Destroy; override;
  130. {:Send Syslog UDP packet defined by @link(SysLogMessage).}
  131. function DoIt: Boolean;
  132. published
  133. {:Syslog message for send}
  134. property SysLogMessage:TSysLogMessage read FSysLogMessage write FSysLogMessage;
  135. end;
  136. {:Simply send packet to specified Syslog server.}
  137. function ToSysLog(const SyslogServer: string; Facil: Byte;
  138. Sever: TSyslogSeverity; const Content: string): Boolean;
  139. implementation
  140. function TSyslogMessage.GetPacketBuf:String;
  141. begin
  142. Result := '<' + IntToStr((FFacility * 8) + Ord(FSeverity)) + '>';
  143. Result := Result + CDateTime(FDateTime) + ' ';
  144. Result := Result + FLocalIP + ' ';
  145. Result := Result + FTag + ': ' + FMessage;
  146. end;
  147. procedure TSyslogMessage.SetPacketBuf(Value:String);
  148. var StrBuf:String;
  149. IntBuf,Pos:Integer;
  150. begin
  151. if Length(Value) < 1 then exit;
  152. Pos := 1;
  153. if Value[Pos] <> '<' then exit;
  154. Inc(Pos);
  155. // Facility and Severity
  156. StrBuf := '';
  157. while (Value[Pos] <> '>')do
  158. begin
  159. StrBuf := StrBuf + Value[Pos];
  160. Inc(Pos);
  161. end;
  162. IntBuf := StrToInt(StrBuf);
  163. FFacility := IntBuf div 8;
  164. case (IntBuf mod 8)of
  165. 0:FSeverity := Emergency;
  166. 1:FSeverity := Alert;
  167. 2:FSeverity := Critical;
  168. 3:FSeverity := Error;
  169. 4:FSeverity := Warning;
  170. 5:FSeverity := Notice;
  171. 6:FSeverity := Info;
  172. 7:FSeverity := Debug;
  173. end;
  174. // DateTime
  175. Inc(Pos);
  176. StrBuf := '';
  177. // Month
  178. while (Value[Pos] <> ' ')do
  179. begin
  180. StrBuf := StrBuf + Value[Pos];
  181. Inc(Pos);
  182. end;
  183. StrBuf := StrBuf + Value[Pos];
  184. Inc(Pos);
  185. // Day
  186. while (Value[Pos] <> ' ')do
  187. begin
  188. StrBuf := StrBuf + Value[Pos];
  189. Inc(Pos);
  190. end;
  191. StrBuf := StrBuf + Value[Pos];
  192. Inc(Pos);
  193. // Time
  194. while (Value[Pos] <> ' ')do
  195. begin
  196. StrBuf := StrBuf + Value[Pos];
  197. Inc(Pos);
  198. end;
  199. FDateTime := DecodeRFCDateTime(StrBuf);
  200. Inc(Pos);
  201. // LocalIP
  202. StrBuf := '';
  203. while (Value[Pos] <> ' ')do
  204. begin
  205. StrBuf := StrBuf + Value[Pos];
  206. Inc(Pos);
  207. end;
  208. FLocalIP := StrBuf;
  209. Inc(Pos);
  210. // Tag
  211. StrBuf := '';
  212. while (Value[Pos] <> ':')do
  213. begin
  214. StrBuf := StrBuf + Value[Pos];
  215. Inc(Pos);
  216. end;
  217. FTag := StrBuf;
  218. // LogMessage
  219. Inc(Pos);
  220. StrBuf := '';
  221. while (Pos <= Length(Value))do
  222. begin
  223. StrBuf := StrBuf + Value[Pos];
  224. Inc(Pos);
  225. end;
  226. FMessage := TrimSP(StrBuf);
  227. end;
  228. procedure TSysLogMessage.Clear;
  229. begin
  230. FFacility := FCL_Local0;
  231. FSeverity := Debug;
  232. FTag := ExtractFileName(ParamStr(0));
  233. FMessage := '';
  234. FLocalIP := '0.0.0.0';
  235. end;
  236. //------------------------------------------------------------------------------
  237. constructor TSyslogSend.Create;
  238. begin
  239. inherited Create;
  240. FSock := TUDPBlockSocket.Create;
  241. FSock.Owner := self;
  242. FSysLogMessage := TSysLogMessage.Create;
  243. FTargetPort := cSysLogProtocol;
  244. end;
  245. destructor TSyslogSend.Destroy;
  246. begin
  247. FSock.Free;
  248. FSysLogMessage.Free;
  249. inherited Destroy;
  250. end;
  251. function TSyslogSend.DoIt: Boolean;
  252. var
  253. L: TStringList;
  254. begin
  255. Result := False;
  256. L := TStringList.Create;
  257. try
  258. FSock.ResolveNameToIP(FSock.Localname, L);
  259. if L.Count < 1 then
  260. FSysLogMessage.LocalIP := '0.0.0.0'
  261. else
  262. FSysLogMessage.LocalIP := L[0];
  263. finally
  264. L.Free;
  265. end;
  266. FSysLogMessage.DateTime := Now;
  267. if Length(FSysLogMessage.PacketBuf) <= 1024 then
  268. begin
  269. FSock.Connect(FTargetHost, FTargetPort);
  270. FSock.SendString(FSysLogMessage.PacketBuf);
  271. Result := FSock.LastError = 0;
  272. end;
  273. end;
  274. {==============================================================================}
  275. function ToSysLog(const SyslogServer: string; Facil: Byte;
  276. Sever: TSyslogSeverity; const Content: string): Boolean;
  277. begin
  278. with TSyslogSend.Create do
  279. try
  280. TargetHost :=SyslogServer;
  281. SysLogMessage.Facility := Facil;
  282. SysLogMessage.Severity := Sever;
  283. SysLogMessage.LogMessage := Content;
  284. Result := DoIt;
  285. finally
  286. Free;
  287. end;
  288. end;
  289. end.