├── Demo ├── Server2.dpr ├── Server2.dproj ├── Server2.exe ├── Server2.res ├── uBrokers.dfm ├── uBrokers.pas ├── uServer2.dfm └── uServer2.pas ├── README.md └── src ├── MQTTComponents.dpk ├── MQTTComponents.dproj ├── MQTTComponents.res ├── uMQTT.pas └── uMQTTComps.pas /Demo/Server2.dpr: -------------------------------------------------------------------------------- 1 | program Server2; 2 | 3 | uses 4 | Forms, 5 | uServer2 in 'uServer2.pas' {MainForm}, 6 | uMQTT in 'uMQTT.pas', 7 | uBrokers in 'uBrokers.pas' {BrokerForm}; 8 | 9 | {$R *.res} 10 | 11 | begin 12 | Application.Initialize; 13 | Application.MainFormOnTaskbar := True; 14 | Application.CreateForm(TMainForm, MainForm); 15 | Application.CreateForm(TBrokerForm, BrokerForm); 16 | Application.Run; 17 | end. 18 | -------------------------------------------------------------------------------- /Demo/Server2.dproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | {EB00A936-B90C-47A8-888D-82C98B8DA42F} 4 | 12.2 5 | Server2.dpr 6 | True 7 | Debug 8 | Win32 9 | Application 10 | VCL 11 | DCC32 12 | 13 | 14 | true 15 | 16 | 17 | true 18 | Base 19 | true 20 | 21 | 22 | true 23 | Base 24 | true 25 | 26 | 27 | 00400000 28 | .\$(Config)\$(Platform) 29 | WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;$(DCC_UnitAlias) 30 | .\$(Config)\$(Platform) 31 | 32 | 33 | C:\Delphi Projects\Virtual Treeview\Resources;C:\Delphi Projects\Graphics32;C:\Delphi Projects\icsv816\Source;$(DCC_UnitSearchPath) 34 | DEBUG;$(DCC_Define) 35 | false 36 | true 37 | 38 | 39 | false 40 | RELEASE;$(DCC_Define) 41 | 0 42 | false 43 | 44 | 45 | 46 | MainSource 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | Cfg_2 57 | Base 58 | 59 | 60 | Base 61 | 62 | 63 | Cfg_1 64 | Base 65 | 66 | 67 | 68 | 69 | 70 | Delphi.Personality.12 71 | 72 | 73 | 74 | 75 | False 76 | False 77 | 1 78 | 0 79 | 0 80 | 0 81 | False 82 | False 83 | False 84 | False 85 | False 86 | 3081 87 | 1252 88 | 89 | 90 | 91 | 92 | 1.0.0.0 93 | 94 | 95 | 96 | 97 | 98 | 1.0.0.0 99 | 100 | 101 | 102 | Microsoft Office 2000 Sample Automation Server Wrapper Components 103 | Microsoft Office XP Sample Automation Server Wrapper Components 104 | 105 | 106 | Server2.dpr 107 | 108 | 109 | 110 | True 111 | 112 | 113 | 12 114 | 115 | 116 | -------------------------------------------------------------------------------- /Demo/Server2.exe: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pjde/delphi-mqtt/65ef33f009f7b96d0e50f35d1591df08be79011f/Demo/Server2.exe -------------------------------------------------------------------------------- /Demo/Server2.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pjde/delphi-mqtt/65ef33f009f7b96d0e50f35d1591df08be79011f/Demo/Server2.res -------------------------------------------------------------------------------- /Demo/uBrokers.dfm: -------------------------------------------------------------------------------- 1 | object BrokerForm: TBrokerForm 2 | Left = 0 3 | Top = 0 4 | BorderStyle = bsToolWindow 5 | Caption = ' Other Brokers' 6 | ClientHeight = 297 7 | ClientWidth = 310 8 | Color = clBtnFace 9 | Font.Charset = DEFAULT_CHARSET 10 | Font.Color = clWindowText 11 | Font.Height = -11 12 | Font.Name = 'Tahoma' 13 | Font.Style = [] 14 | OldCreateOrder = False 15 | OnCreate = FormCreate 16 | OnShow = FormShow 17 | PixelsPerInch = 96 18 | TextHeight = 13 19 | object Label1: TLabel 20 | Left = 4 21 | Top = 221 22 | Width = 52 23 | Height = 13 24 | Caption = 'IP Address' 25 | end 26 | object Label2: TLabel 27 | Left = 146 28 | Top = 221 29 | Width = 20 30 | Height = 13 31 | Caption = 'Port' 32 | end 33 | object MonTree: TVirtualStringTree 34 | Left = 4 35 | Top = 4 36 | Width = 299 37 | Height = 199 38 | Colors.UnfocusedSelectionColor = clHighlight 39 | Colors.UnfocusedSelectionBorderColor = clHighlight 40 | Header.AutoSizeIndex = 0 41 | Header.DefaultHeight = 17 42 | Header.Font.Charset = DEFAULT_CHARSET 43 | Header.Font.Color = clWindowText 44 | Header.Font.Height = -11 45 | Header.Font.Name = 'Tahoma' 46 | Header.Font.Style = [] 47 | Header.Options = [hoColumnResize, hoDrag, hoShowSortGlyphs, hoVisible] 48 | RootNodeCount = 3 49 | TabOrder = 0 50 | TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowHorzGridLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines] 51 | TreeOptions.SelectionOptions = [toFullRowSelect] 52 | OnChange = MonTreeChange 53 | OnGetText = MonTreeGetText 54 | OnGetNodeDataSize = MonTreeGetNodeDataSize 55 | Columns = < 56 | item 57 | Position = 0 58 | Width = 100 59 | WideText = 'IP Address' 60 | end 61 | item 62 | Position = 1 63 | Width = 60 64 | WideText = 'Port' 65 | end 66 | item 67 | Position = 2 68 | Width = 60 69 | WideText = 'Enabled' 70 | end 71 | item 72 | Position = 3 73 | WideText = 'Online' 74 | end> 75 | end 76 | object IPTxt: TEdit 77 | Left = 4 78 | Top = 235 79 | Width = 127 80 | Height = 21 81 | TabOrder = 1 82 | OnChange = IPTxtChange 83 | end 84 | object PortTxt: TEdit 85 | Left = 146 86 | Top = 235 87 | Width = 71 88 | Height = 21 89 | TabOrder = 2 90 | OnChange = IPTxtChange 91 | OnKeyPress = PortTxtKeyPress 92 | end 93 | object DelBtn: TButton 94 | Left = 231 95 | Top = 205 96 | Width = 71 97 | Height = 23 98 | Caption = 'Del' 99 | TabOrder = 3 100 | OnClick = DelBtnClick 101 | end 102 | object AddBtn: TButton 103 | Left = 232 104 | Top = 234 105 | Width = 71 106 | Height = 23 107 | Caption = 'Add' 108 | TabOrder = 4 109 | OnClick = AddBtnClick 110 | end 111 | object BitBtn1: TBitBtn 112 | Left = 211 113 | Top = 263 114 | Width = 91 115 | Height = 27 116 | Caption = 'Close' 117 | DoubleBuffered = True 118 | Kind = bkCancel 119 | NumGlyphs = 2 120 | ParentDoubleBuffered = False 121 | TabOrder = 5 122 | OnClick = BitBtn1Click 123 | end 124 | object StartBtn: TButton 125 | Left = 4 126 | Top = 271 127 | Width = 71 128 | Height = 23 129 | Caption = 'Start' 130 | TabOrder = 6 131 | OnClick = StartBtnClick 132 | end 133 | object StopBtn: TButton 134 | Left = 81 135 | Top = 271 136 | Width = 71 137 | Height = 23 138 | Caption = 'Stop' 139 | TabOrder = 7 140 | OnClick = StopBtnClick 141 | end 142 | end 143 | -------------------------------------------------------------------------------- /Demo/uBrokers.pas: -------------------------------------------------------------------------------- 1 | unit uBrokers; 2 | 3 | interface 4 | 5 | uses 6 | Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 7 | Dialogs, uMQTTComps, VirtualTrees, Buttons, StdCtrls; 8 | 9 | type 10 | TDataRec = record 11 | Broker : TMQTTClient; 12 | end; 13 | PDataRec = ^TDataRec; 14 | 15 | TBrokerForm = class(TForm) 16 | MonTree: TVirtualStringTree; 17 | IPTxt: TEdit; 18 | PortTxt: TEdit; 19 | Label1: TLabel; 20 | Label2: TLabel; 21 | DelBtn: TButton; 22 | AddBtn: TButton; 23 | BitBtn1: TBitBtn; 24 | StartBtn: TButton; 25 | StopBtn: TButton; 26 | procedure FormCreate(Sender: TObject); 27 | procedure MonTreeGetNodeDataSize(Sender: TBaseVirtualTree; 28 | var NodeDataSize: Integer); 29 | procedure FormShow(Sender: TObject); 30 | procedure AddBtnClick(Sender: TObject); 31 | procedure MonTreeGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; 32 | Column: TColumnIndex; TextType: TVSTTextType; var CellText: string); 33 | procedure BitBtn1Click(Sender: TObject); 34 | procedure DelBtnClick(Sender: TObject); 35 | procedure PortTxtKeyPress(Sender: TObject; var Key: Char); 36 | procedure StartBtnClick(Sender: TObject); 37 | procedure StopBtnClick(Sender: TObject); 38 | procedure IPTxtChange(Sender: TObject); 39 | procedure MonTreeChange(Sender: TBaseVirtualTree; Node: PVirtualNode); 40 | private 41 | { Private declarations } 42 | procedure UpdateBtnStatus; 43 | 44 | public 45 | { Public declarations } 46 | FServer : TMQTTServer; 47 | procedure Sync; 48 | procedure RefreshTree; 49 | end; 50 | 51 | var 52 | BrokerForm: TBrokerForm; 53 | 54 | procedure ShowBrokerForm (anOwner : TComponent; aServer : TMQTTServer); 55 | 56 | implementation 57 | 58 | 59 | {$R *.dfm} 60 | 61 | procedure ShowBrokerForm (anOwner : TComponent; aServer : TMQTTServer); 62 | var 63 | aForm : TBrokerForm; 64 | begin 65 | aForm := TBrokerForm.Create (anOwner); 66 | aForm.FServer := aServer; 67 | aForm.Show; 68 | end; 69 | 70 | { TForm2 } 71 | 72 | procedure TBrokerForm.AddBtnClick(Sender: TObject); 73 | var 74 | aBroker : TMQTTClient; 75 | aNode : PVirtualNode; 76 | aData : PDataRec; 77 | begin 78 | if FServer = nil then exit; 79 | aBroker := FServer.AddBroker (IPTxt.Text, StrToIntDef (PortTxt.Text, 1883)); 80 | Sync; 81 | aNode := MonTree.GetFirst (false); 82 | while aNode <> nil do 83 | begin 84 | aData := MonTree.GetNodeData (aNode); 85 | if aData.Broker = aBroker then 86 | begin 87 | MonTree.Selected[aNode] := true; 88 | aNode := nil; 89 | end 90 | else 91 | aNode := MonTree.GetNext (aNode, false); 92 | end; 93 | end; 94 | 95 | procedure TBrokerForm.BitBtn1Click (Sender: TObject); 96 | begin 97 | hide; 98 | end; 99 | 100 | procedure TBrokerForm.DelBtnClick(Sender: TObject); 101 | var 102 | aNode : PVirtualNode; 103 | aData : PDataRec; 104 | begin 105 | if FServer = nil then exit; 106 | aNode := MonTree.GetFirstSelected (false); 107 | if aNode = nil then exit; 108 | aData := MonTree.GetNodeData (aNode); 109 | FServer.Brokers.Remove (aData.Broker); 110 | aData.Broker.Free; 111 | Sync; 112 | end; 113 | 114 | procedure TBrokerForm.FormCreate (Sender: TObject); 115 | begin 116 | FServer := nil; 117 | end; 118 | 119 | procedure TBrokerForm.FormShow (Sender: TObject); 120 | begin 121 | Sync; 122 | UpdateBtnStatus; 123 | end; 124 | 125 | procedure TBrokerForm.IPTxtChange(Sender: TObject); 126 | begin 127 | UpdateBtnStatus; 128 | end; 129 | 130 | procedure TBrokerForm.MonTreeChange(Sender: TBaseVirtualTree; 131 | Node: PVirtualNode); 132 | begin 133 | UpdateBtnStatus; 134 | end; 135 | 136 | procedure TBrokerForm.MonTreeGetNodeDataSize(Sender: TBaseVirtualTree; 137 | var NodeDataSize: Integer); 138 | begin 139 | NodeDataSize := SizeOf (TDataRec); 140 | end; 141 | 142 | procedure TBrokerForm.MonTreeGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; 143 | Column: TColumnIndex; TextType: TVSTTextType; var CellText: string); 144 | const 145 | ny : array [boolean] of string = ('NO', 'YES'); 146 | var 147 | aData : PDataRec; 148 | begin 149 | aData := Sender.GetNodeData (Node); 150 | if FServer = nil then 151 | CellText := '' 152 | else if FServer.Brokers.IndexOf (aData.Broker) >= 0 then 153 | begin 154 | case Column of 155 | 0 : CellText := aData.Broker.Host; 156 | 1 : CellText := IntToStr (aData.Broker.Port); 157 | 2 : Celltext := ny[aData.Broker.Enabled]; 158 | 3 : CellText := ny[aData.Broker.Online]; 159 | end; 160 | end 161 | else 162 | CellText := ''; 163 | end; 164 | 165 | procedure TBrokerForm.PortTxtKeyPress(Sender: TObject; var Key: Char); 166 | begin 167 | if not CharInSet (Key, ['0'..'9', #8]) then Key := #0; 168 | end; 169 | 170 | procedure TBrokerForm.RefreshTree; 171 | begin 172 | MonTree.Invalidate; 173 | end; 174 | 175 | procedure TBrokerForm.StartBtnClick(Sender: TObject); 176 | var 177 | aNode : PVirtualNode; 178 | aData : PDataRec; 179 | begin 180 | if FServer = nil then exit; 181 | aNode := MonTree.GetFirstSelected (false); 182 | if aNode = nil then exit; 183 | aData := MonTree.GetNodeData (aNode); 184 | aData.Broker.Activate (true); 185 | MonTree.Invalidate; 186 | end; 187 | 188 | procedure TBrokerForm.StopBtnClick(Sender: TObject); 189 | var 190 | aNode : PVirtualNode; 191 | aData : PDataRec; 192 | begin 193 | if FServer = nil then exit; 194 | aNode := MonTree.GetFirstSelected (false); 195 | if aNode = nil then exit; 196 | aData := MonTree.GetNodeData (aNode); 197 | aData.Broker.Activate (false); 198 | MonTree.Invalidate; 199 | end; 200 | 201 | procedure TBrokerForm.Sync; 202 | var 203 | i, x : integer; 204 | aData : PDataRec; 205 | aNode, bNode : PVirtualNode; 206 | begin 207 | if FServer = nil then 208 | begin 209 | MonTree.Clear; 210 | exit; 211 | end; 212 | MonTree.BeginUpdate; 213 | x := 0; 214 | aNode := MonTree.GetFirst (false); 215 | while (aNode <> nil) and (x < FServer.Brokers.Count) do 216 | begin 217 | aData := MonTree.GetNodeData (aNode); 218 | aData.Broker := FServer.Brokers[x]; 219 | x := x + 1; 220 | aNode := MonTree.GetNext (aNode, false); 221 | end; 222 | if aNode = nil then // ran out of existing 223 | begin 224 | for i := x to FServer.Brokers.Count - 1 do 225 | begin 226 | aNode := MonTree.AddChild (nil); 227 | aData := MonTree.GetNodeData (aNode); 228 | aData.Broker := FServer.Brokers[x]; 229 | end; 230 | end 231 | else // delete any extra 232 | begin 233 | while aNode <> nil do 234 | begin 235 | bNode := MonTree.GetNext (aNode, false); 236 | MonTree.DeleteNode (aNode, false); 237 | aNode := bNode; 238 | end; 239 | end; 240 | MonTree.EndUpdate; 241 | end; 242 | 243 | procedure TBrokerForm.UpdateBtnStatus; 244 | begin 245 | AddBtn.Enabled := (length (IPTxt.Text) > 0); 246 | DelBtn.Enabled := MonTree.GetFirstSelected (false) <> nil; 247 | StartBtn.Enabled := MonTree.GetFirstSelected (false) <> nil; 248 | StopBtn.Enabled := MonTree.GetFirstSelected (false) <> nil; 249 | end; 250 | 251 | end. 252 | -------------------------------------------------------------------------------- /Demo/uServer2.dfm: -------------------------------------------------------------------------------- 1 | object MainForm: TMainForm 2 | Left = 0 3 | Top = 0 4 | BorderStyle = bsToolWindow 5 | Caption = 'MQTT Server / Client Demo' 6 | ClientHeight = 426 7 | ClientWidth = 831 8 | Color = clBtnFace 9 | Font.Charset = DEFAULT_CHARSET 10 | Font.Color = clWindowText 11 | Font.Height = -11 12 | Font.Name = 'Tahoma' 13 | Font.Style = [] 14 | OldCreateOrder = False 15 | OnCreate = FormCreate 16 | OnDestroy = FormDestroy 17 | OnShow = FormShow 18 | PixelsPerInch = 96 19 | TextHeight = 13 20 | object Label2: TLabel 21 | Left = 8 22 | Top = 220 23 | Width = 27 24 | Height = 13 25 | Caption = 'Client' 26 | end 27 | object CIDTxt: TLabel 28 | Left = 370 29 | Top = 8 30 | Width = 3 31 | Height = 13 32 | AutoSize = False 33 | end 34 | object Label4: TLabel 35 | Left = 370 36 | Top = 220 37 | Width = 30 38 | Height = 13 39 | Caption = 'Online' 40 | end 41 | object COnlineTxt: TLabel 42 | Left = 406 43 | Top = 220 44 | Width = 15 45 | Height = 13 46 | Caption = 'NO' 47 | end 48 | object CEnableTxt: TLabel 49 | Left = 348 50 | Top = 220 51 | Width = 15 52 | Height = 13 53 | Caption = 'NO' 54 | end 55 | object Label3: TLabel 56 | Left = 304 57 | Top = 220 58 | Width = 38 59 | Height = 13 60 | Caption = 'Enabled' 61 | end 62 | object Label1: TLabel 63 | Left = 8 64 | Top = 6 65 | Width = 32 66 | Height = 13 67 | Caption = 'Server' 68 | end 69 | object Label5: TLabel 70 | Left = 431 71 | Top = 248 72 | Width = 91 73 | Height = 13 74 | Caption = 'Subscription Topics' 75 | end 76 | object Label6: TLabel 77 | Left = 582 78 | Top = 283 79 | Width = 42 80 | Height = 13 81 | Caption = 'Message' 82 | end 83 | object SClientsTxt: TLabel 84 | Left = 412 85 | Top = 6 86 | Width = 6 87 | Height = 13 88 | Caption = '0' 89 | end 90 | object Label9: TLabel 91 | Left = 370 92 | Top = 6 93 | Width = 32 94 | Height = 13 95 | Caption = 'Clients' 96 | end 97 | object Label7: TLabel 98 | Left = 737 99 | Top = 243 100 | Width = 85 101 | Height = 13 102 | Caption = 'Quality of Service' 103 | end 104 | object Label8: TLabel 105 | Left = 45 106 | Top = 220 107 | Width = 42 108 | Height = 13 109 | Caption = 'Last Msg' 110 | end 111 | object CMsgTxt: TLabel 112 | Left = 93 113 | Top = 220 114 | Width = 40 115 | Height = 13 116 | Caption = '' 117 | end 118 | object Label11: TLabel 119 | Left = 46 120 | Top = 6 121 | Width = 42 122 | Height = 13 123 | Caption = 'Last Msg' 124 | end 125 | object SMsgTxt: TLabel 126 | Left = 94 127 | Top = 6 128 | Width = 40 129 | Height = 13 130 | Caption = '' 131 | end 132 | object Label10: TLabel 133 | Left = 466 134 | Top = 155 135 | Width = 20 136 | Height = 13 137 | Caption = 'Port' 138 | end 139 | object Label13: TLabel 140 | Left = 653 141 | Top = 220 142 | Width = 20 143 | Height = 13 144 | Caption = 'Port' 145 | end 146 | object Label14: TLabel 147 | Left = 173 148 | Top = 6 149 | Width = 19 150 | Height = 13 151 | Caption = 'Qos' 152 | end 153 | object SQosTxt: TLabel 154 | Left = 198 155 | Top = 6 156 | Width = 3 157 | Height = 13 158 | Caption = ' ' 159 | end 160 | object Label16: TLabel 161 | Left = 173 162 | Top = 220 163 | Width = 19 164 | Height = 13 165 | Caption = 'Qos' 166 | end 167 | object CQosTxt: TLabel 168 | Left = 198 169 | Top = 220 170 | Width = 6 171 | Height = 13 172 | Caption = ' ' 173 | end 174 | object Label15: TLabel 175 | Left = 304 176 | Top = 6 177 | Width = 38 178 | Height = 13 179 | Caption = 'Enabled' 180 | end 181 | object SEnableTxt: TLabel 182 | Left = 348 183 | Top = 6 184 | Width = 15 185 | Height = 13 186 | Caption = 'NO' 187 | end 188 | object Label18: TLabel 189 | Left = 581 190 | Top = 247 191 | Width = 25 192 | Height = 13 193 | Caption = 'Topic' 194 | end 195 | object ClientIDTxt: TLabel 196 | Left = 683 197 | Top = 179 198 | Width = 38 199 | Height = 13 200 | Caption = 'ClientID' 201 | end 202 | object PixTxt: TLabel 203 | Left = 618 204 | Top = 2 205 | Width = 193 206 | Height = 13 207 | Alignment = taCenter 208 | AutoSize = False 209 | end 210 | object Label12: TLabel 211 | Left = 653 212 | Top = 196 213 | Width = 22 214 | Height = 13 215 | Caption = 'Host' 216 | end 217 | object Memo1: TMemo 218 | Left = 2 219 | Top = 20 220 | Width = 421 221 | Height = 183 222 | ScrollBars = ssVertical 223 | TabOrder = 0 224 | OnDblClick = Memo1DblClick 225 | end 226 | object Button15: TButton 227 | Left = 431 228 | Top = 15 229 | Width = 69 230 | Height = 27 231 | Caption = 'Start' 232 | TabOrder = 1 233 | OnClick = Button15Click 234 | end 235 | object Button16: TButton 236 | Left = 501 237 | Top = 15 238 | Width = 69 239 | Height = 27 240 | Caption = 'Stop' 241 | TabOrder = 2 242 | OnClick = Button16Click 243 | end 244 | object Memo2: TMemo 245 | Left = 7 246 | Top = 234 247 | Width = 279 248 | Height = 194 249 | ScrollBars = ssVertical 250 | TabOrder = 3 251 | OnDblClick = Memo2DblClick 252 | end 253 | object Button17: TButton 254 | Left = 501 255 | Top = 214 256 | Width = 69 257 | Height = 27 258 | Caption = 'Stop' 259 | TabOrder = 4 260 | OnClick = Button17Click 261 | end 262 | object Button18: TButton 263 | Left = 431 264 | Top = 214 265 | Width = 69 266 | Height = 27 267 | Caption = 'Start' 268 | TabOrder = 5 269 | OnClick = Button18Click 270 | end 271 | object Button22: TButton 272 | Left = 429 273 | Top = 48 274 | Width = 80 275 | Height = 27 276 | Caption = 'Show Clients' 277 | TabOrder = 6 278 | OnClick = Button22Click 279 | end 280 | object Button24: TButton 281 | Left = 581 282 | Top = 373 283 | Width = 69 284 | Height = 25 285 | Caption = 'Publish' 286 | TabOrder = 7 287 | OnClick = Button24Click 288 | end 289 | object rb1: TRadioButton 290 | Left = 735 291 | Top = 259 292 | Width = 87 293 | Height = 17 294 | Caption = 'At Most Once' 295 | TabOrder = 8 296 | OnClick = rb1Click 297 | end 298 | object rb2: TRadioButton 299 | Tag = 1 300 | Left = 735 301 | Top = 275 302 | Width = 91 303 | Height = 17 304 | Caption = 'At Least Once' 305 | Checked = True 306 | TabOrder = 9 307 | TabStop = True 308 | OnClick = rb1Click 309 | end 310 | object rb3: TRadioButton 311 | Tag = 2 312 | Left = 735 313 | Top = 291 314 | Width = 87 315 | Height = 17 316 | Caption = 'Exactly Once' 317 | TabOrder = 10 318 | OnClick = rb1Click 319 | end 320 | object Button1: TButton 321 | Left = 431 322 | Top = 399 323 | Width = 69 324 | Height = 25 325 | Caption = 'Show' 326 | TabOrder = 11 327 | OnClick = Button1Click 328 | end 329 | object PortTxt: TEdit 330 | Left = 497 331 | Top = 152 332 | Width = 85 333 | Height = 21 334 | TabOrder = 12 335 | Text = '1883' 336 | OnKeyPress = PortTxtKeyPress 337 | end 338 | object Button2: TButton 339 | Left = 429 340 | Top = 113 341 | Width = 80 342 | Height = 27 343 | Caption = 'Brokers' 344 | TabOrder = 13 345 | OnClick = Button2Click 346 | end 347 | object Button3: TButton 348 | Left = 573 349 | Top = 214 350 | Width = 69 351 | Height = 27 352 | Caption = 'Kill' 353 | TabOrder = 14 354 | OnClick = Button3Click 355 | end 356 | object CPortTxt: TEdit 357 | Left = 683 358 | Top = 217 359 | Width = 85 360 | Height = 21 361 | TabOrder = 15 362 | Text = '1883' 363 | OnKeyPress = PortTxtKeyPress 364 | end 365 | object BounceBox: TCheckBox 366 | Left = 517 367 | Top = 49 368 | Width = 97 369 | Height = 17 370 | Caption = ' Local Bounce' 371 | TabOrder = 16 372 | OnClick = BounceBoxClick 373 | end 374 | object TopicsTxt: TMemo 375 | Left = 431 376 | Top = 263 377 | Width = 144 378 | Height = 104 379 | Lines.Strings = ( 380 | 'update/memo' 381 | 'update/png/+' 382 | 'will/#') 383 | TabOrder = 17 384 | end 385 | object Button5: TButton 386 | Left = 431 387 | Top = 373 388 | Width = 69 389 | Height = 25 390 | Caption = 'Subscribe' 391 | TabOrder = 18 392 | OnClick = Button5Click 393 | end 394 | object Button6: TButton 395 | Left = 506 396 | Top = 373 397 | Width = 69 398 | Height = 25 399 | Caption = 'Unsubscribe' 400 | TabOrder = 19 401 | OnClick = Button6Click 402 | end 403 | object TopicTxt: TEdit 404 | Left = 581 405 | Top = 263 406 | Width = 146 407 | Height = 21 408 | TabOrder = 20 409 | Text = 'update/memo' 410 | end 411 | object MsgBox: TMemo 412 | Left = 582 413 | Top = 298 414 | Width = 145 415 | Height = 69 416 | Lines.Strings = ( 417 | 'WARNING' 418 | 'Coolant Leak.' 419 | 'Primary Cooling System.' 420 | 'Reactor 5.') 421 | TabOrder = 21 422 | end 423 | object CMBox: TCheckBox 424 | Left = 517 425 | Top = 65 426 | Width = 97 427 | Height = 17 428 | Caption = 'Client Monitor' 429 | Checked = True 430 | State = cbChecked 431 | TabOrder = 22 432 | end 433 | object CMBox2: TCheckBox 434 | Left = 735 435 | Top = 361 436 | Width = 97 437 | Height = 17 438 | Caption = 'Client Monitor' 439 | Checked = True 440 | State = cbChecked 441 | TabOrder = 23 442 | end 443 | object BounceBox2: TCheckBox 444 | Left = 735 445 | Top = 345 446 | Width = 97 447 | Height = 17 448 | Caption = ' Local Bounce' 449 | TabOrder = 24 450 | OnClick = BounceBox2Click 451 | end 452 | object CleanBox2: TCheckBox 453 | Left = 735 454 | Top = 312 455 | Width = 97 456 | Height = 17 457 | Caption = 'Clean' 458 | TabOrder = 25 459 | OnClick = CleanBox2Click 460 | end 461 | object Button4: TButton 462 | Left = 774 463 | Top = 216 464 | Width = 53 465 | Height = 23 466 | Caption = 'Update' 467 | TabOrder = 26 468 | OnClick = Button4Click 469 | end 470 | object Memo3: TMemo 471 | Left = 292 472 | Top = 234 473 | Width = 133 474 | Height = 189 475 | TabOrder = 27 476 | OnDblClick = Memo3DblClick 477 | end 478 | object RetainBox: TCheckBox 479 | Left = 735 480 | Top = 327 481 | Width = 97 482 | Height = 17 483 | Caption = 'Retain' 484 | TabOrder = 28 485 | OnClick = RetainBoxClick 486 | end 487 | object Button8: TButton 488 | Left = 556 489 | Top = 399 490 | Width = 50 491 | Height = 25 492 | Caption = 'Send' 493 | TabOrder = 29 494 | OnClick = Button8Click 495 | end 496 | object Button9: TButton 497 | Left = 769 498 | Top = 378 499 | Width = 50 500 | Height = 25 501 | Caption = 'Off' 502 | TabOrder = 30 503 | OnClick = Button9Click 504 | end 505 | object JTxt: TEdit 506 | Left = 674 507 | Top = 380 508 | Width = 33 509 | Height = 21 510 | TabOrder = 31 511 | Text = '3' 512 | OnKeyPress = JTxtKeyPress 513 | end 514 | object Edit1: TEdit 515 | Left = 618 516 | Top = 403 517 | Width = 89 518 | Height = 21 519 | TabOrder = 32 520 | Text = '3' 521 | end 522 | object Button10: TButton 523 | Left = 717 524 | Top = 378 525 | Width = 50 526 | Height = 25 527 | Caption = 'On' 528 | TabOrder = 33 529 | OnClick = Button10Click 530 | end 531 | object AddrTxt: TEdit 532 | Left = 683 533 | Top = 193 534 | Width = 129 535 | Height = 21 536 | TabOrder = 34 537 | Text = '10.0.0.2' 538 | end 539 | object TTServer: TMQTTServer 540 | MaxRetries = 4 541 | RetryTime = 60 542 | Port = 1883 543 | LocalBounce = False 544 | OnFailure = TTServerFailure 545 | OnStoreSession = TTServerStoreSession 546 | OnRestoreSession = TTServerRestoreSession 547 | OnDeleteSession = TTServerDeleteSession 548 | OnBrokerOnline = TTServerBrokerOnline 549 | OnBrokerOffline = TTServerBrokerOffline 550 | OnBrokerEnableChange = TTServerBrokerEnableChange 551 | OnEnableChange = TTServerEnableChange 552 | OnSubscription = TTServerSubscription 553 | OnClientsChange = TTServerClientsChange 554 | OnCheckUser = TTServerCheckUser 555 | OnObituary = TTServerObituary 556 | OnMon = TTServerMon 557 | Left = 526 558 | Top = 102 559 | end 560 | object TTClient: TMQTTClient 561 | KeepAlive = 10 562 | MaxRetries = 8 563 | RetryTime = 60 564 | Clean = True 565 | Broker = False 566 | AutoSubscribe = False 567 | Username = 'admin' 568 | Password = 'password' 569 | Host = 'localhost' 570 | Port = 1883 571 | LocalBounce = False 572 | OnClientID = TTClientClientID 573 | OnMon = TTClientMon 574 | OnOnline = TTClientOnline 575 | OnOffline = TTClientOffline 576 | OnEnableChange = TTClientEnableChange 577 | OnFailure = TTClientFailure 578 | OnMsg = TTClientMsg 579 | Left = 564 580 | Top = 102 581 | end 582 | end 583 | -------------------------------------------------------------------------------- /Demo/uServer2.pas: -------------------------------------------------------------------------------- 1 | unit uServer2; 2 | 3 | interface 4 | 5 | uses 6 | Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 7 | Dialogs, OverbyteIcsWndControl, OverbyteIcsWSocket, OverbyteIcsWSocketS, uMQTT, 8 | StdCtrls, uMQTTComps, ExtCtrls {, GR32_RangeBars}; 9 | 10 | type 11 | TMainForm = class (TForm) 12 | Memo1: TMemo; 13 | Button15: TButton; 14 | Button16: TButton; 15 | Memo2: TMemo; 16 | Button17: TButton; 17 | Button18: TButton; 18 | Button22: TButton; 19 | Button24: TButton; 20 | Label2: TLabel; 21 | CIDTxt: TLabel; 22 | Label4: TLabel; 23 | COnlineTxt: TLabel; 24 | CEnableTxt: TLabel; 25 | Label3: TLabel; 26 | Label1: TLabel; 27 | Label5: TLabel; 28 | Label6: TLabel; 29 | SClientsTxt: TLabel; 30 | Label9: TLabel; 31 | rb1: TRadioButton; 32 | rb2: TRadioButton; 33 | rb3: TRadioButton; 34 | Label7: TLabel; 35 | Button1: TButton; 36 | Label8: TLabel; 37 | CMsgTxt: TLabel; 38 | Label11: TLabel; 39 | SMsgTxt: TLabel; 40 | PortTxt: TEdit; 41 | Label10: TLabel; 42 | Button2: TButton; 43 | Button3: TButton; 44 | CPortTxt: TEdit; 45 | Label13: TLabel; 46 | Label14: TLabel; 47 | SQosTxt: TLabel; 48 | Label16: TLabel; 49 | CQosTxt: TLabel; 50 | Label15: TLabel; 51 | SEnableTxt: TLabel; 52 | BounceBox: TCheckBox; 53 | TopicsTxt: TMemo; 54 | Button5: TButton; 55 | Button6: TButton; 56 | TopicTxt: TEdit; 57 | Label18: TLabel; 58 | MsgBox: TMemo; 59 | CMBox: TCheckBox; 60 | CMBox2: TCheckBox; 61 | BounceBox2: TCheckBox; 62 | CleanBox2: TCheckBox; 63 | ClientIDTxt: TLabel; 64 | TTServer: TMQTTServer; 65 | TTClient: TMQTTClient; 66 | PixTxt: TLabel; 67 | Button4: TButton; 68 | Memo3: TMemo; 69 | RetainBox: TCheckBox; 70 | Button8: TButton; 71 | Button9: TButton; 72 | JTxt: TEdit; 73 | Edit1: TEdit; 74 | Button10: TButton; 75 | AddrTxt: TEdit; 76 | Label12: TLabel; 77 | 78 | procedure FormCreate (Sender : TObject); 79 | procedure FormDestroy(Sender: TObject); 80 | procedure Memo1DblClick(Sender: TObject); 81 | procedure Button15Click(Sender: TObject); 82 | procedure Button16Click(Sender: TObject); 83 | procedure Memo2DblClick(Sender: TObject); 84 | procedure Button18Click(Sender: TObject); 85 | procedure Button17Click(Sender: TObject); 86 | procedure Button22Click(Sender: TObject); 87 | procedure rb1Click(Sender: TObject); 88 | procedure Button1Click(Sender: TObject); 89 | procedure Button2Click(Sender: TObject); 90 | procedure FormShow(Sender: TObject); 91 | procedure PortTxtKeyPress(Sender: TObject; var Key: Char); 92 | procedure Button3Click(Sender: TObject); 93 | procedure BounceBoxClick(Sender: TObject); 94 | procedure Button5Click(Sender: TObject); 95 | procedure Button6Click(Sender: TObject); 96 | procedure Button24Click(Sender: TObject); 97 | procedure BounceBox2Click(Sender: TObject); 98 | procedure CleanBox2Click(Sender: TObject); 99 | procedure TTClientFailure(Sender: TObject; aReason: Integer; 100 | var CloseClient: Boolean); 101 | procedure TTClientMon(Sender: TObject; aStr: string); 102 | procedure TTClientEnableChange(Sender: TObject); 103 | procedure TTClientMsg (Sender: TObject; aTopic: UTF8String; 104 | aMessage: AnsiString; aQos : TMQTTQOSType; aRetained : Boolean); 105 | procedure TTClientOffline(Sender: TObject; Graceful: Boolean); 106 | procedure TTClientOnline(Sender: TObject); 107 | procedure TTServerCheckUser(Sender: TObject; aUser, aPass: UTF8String; 108 | var Allowed: Boolean); 109 | procedure TTServerClientsChange(Sender: TObject; anID: Word); 110 | procedure TTServerFailure(Sender: TObject; aReason: Integer; 111 | var CloseClient: Boolean); 112 | procedure TTServerEnableChange(Sender: TObject); 113 | procedure TTServerMon(Sender: TObject; aStr: string); 114 | procedure TTServerRestoreSession(Sender: TObject; aClientID: UTF8String); 115 | procedure TTServerStoreSession(Sender: TObject; aClientID: UTF8String); 116 | procedure TTServerDeleteSession(Sender: TObject; aClientID: UTF8String); 117 | procedure TTServerObituary(Sender: TObject; var aTopic, 118 | aMessage: UTF8String; var aQos: TMQTTQOSType); 119 | procedure TTServerSubscription(Sender: TObject; aTopic: UTF8String; 120 | var RequestedQos: TMQTTQOSType); 121 | procedure TTServerBrokerOffline(Sender: TObject; Graceful: Boolean); 122 | procedure TTServerBrokerOnline(Sender: TObject); 123 | procedure TTServerBrokerEnableChange(Sender: TObject); 124 | procedure Button4Click(Sender: TObject); 125 | procedure TTClientClientID(Sender: TObject; var aClientID: UTF8String); 126 | procedure Memo3DblClick(Sender: TObject); 127 | procedure RetainBoxClick(Sender: TObject); 128 | procedure Button8Click(Sender: TObject); 129 | procedure Button9Click(Sender: TObject); 130 | procedure JTxtKeyPress(Sender: TObject; var Key: Char); 131 | procedure GaugeBar1UserChange(Sender: TObject); 132 | procedure Button10Click(Sender: TObject); 133 | { Private declarations } 134 | public 135 | { Public declarations } 136 | aQos : TMQTTQOSType; 137 | aRetain : Boolean; 138 | procedure StoreSettings; 139 | procedure LoadSettings; 140 | procedure SMonHeader (Sender : TObject; aMsgType: TMQTTMessageType; aDup: Boolean; 141 | aQos: TMQTTQOSType; aRetain: Boolean); 142 | procedure CMonHeader (Sender : TObject; aMsgType: TMQTTMessageType; aDup: Boolean; 143 | aQos: TMQTTQOSType; aRetain: Boolean); 144 | end; 145 | 146 | var 147 | MainForm: TMainForm; 148 | 149 | implementation 150 | 151 | uses uBrokers, IniFiles; 152 | 153 | {$R *.dfm} 154 | { TForm1 } 155 | 156 | procedure TMainForm.BounceBox2Click(Sender: TObject); 157 | begin 158 | TTClient.LocalBounce := BounceBox2.Checked; 159 | end; 160 | 161 | procedure TMainForm.BounceBoxClick(Sender: TObject); 162 | begin 163 | TTServer.LocalBounce := BounceBox.Checked; 164 | end; 165 | 166 | procedure TMainForm.Button10Click(Sender: TObject); 167 | begin 168 | TTClient.Publish ('csi/pnl/set/state/' + UTF8String (JTxt.Text), '1', qtAT_MOST_ONCE, false); 169 | end; 170 | 171 | procedure TMainForm.Button15Click(Sender: TObject); 172 | begin 173 | TTServer.Port := StrToIntDef (PortTxt.Text, 1883); 174 | TTServer.Activate (true); 175 | end; 176 | 177 | procedure TMainForm.Button16Click (Sender: TObject); 178 | begin 179 | TTServer.Activate(false); 180 | end; 181 | 182 | procedure TMainForm.Button17Click (Sender: TObject); 183 | begin 184 | TTClient.Activate (false); 185 | end; 186 | 187 | procedure TMainForm.Button18Click (Sender: TObject); 188 | begin 189 | TTClient.Host := AddrTxt.Text; 190 | TTClient.Port := StrToIntDef (CPortTxt.Text, 1883); 191 | TTClient.Activate (true); 192 | end; 193 | 194 | procedure TMainForm.Button1Click (Sender: TObject); 195 | var 196 | j : integer; 197 | x : cardinal; 198 | begin 199 | memo2.Lines.Add (''); 200 | memo2.Lines.Add('------ Client ' + string (TTClient.Parser.ClientID) + ' -------'); 201 | memo2.Lines.Add (format ('Username "%s" Password "%s"', [TTClient.Parser.Username, TTClient.Parser.Password])); 202 | memo2.Lines.Add (format ('Keep Alive "%d" Retry Time "%d" Max Retries "%d"', [TTClient.Parser.KeepAlive, TTClient.Parser.RetryTime, TTClient.Parser.MaxRetries])); 203 | memo2.Lines.Add (format ('Will Topic "%s" Message "%s" @ %s', [TTClient.Parser.WillTopic, TTClient.Parser.WillMessage, QosNames [TTClient.Parser.WillQos]])); 204 | memo2.Lines.Add ('Subscriptions ----'); 205 | for j := 0 to TTClient.Subscriptions.Count - 1 do 206 | begin 207 | x := cardinal (TTClient.Subscriptions.Objects[j]) and $03; 208 | if (cardinal (TTClient.Subscriptions.Objects[j]) shr 8) and $ff = $ff then 209 | memo2.Lines.Add (' "' + TTClient.Subscriptions[j] + '" @ ' + QOSNames[TMQTTQOSType (x)] + ' Acked.') 210 | else 211 | memo2.Lines.Add (' "' + TTClient.Subscriptions[j] + '" @ ' + QOSNames[TMQTTQOSType (x)]); 212 | end; 213 | end; 214 | 215 | procedure TMainForm.Button22Click(Sender: TObject); 216 | var 217 | i, j : integer; 218 | aClient : TClient; 219 | x : cardinal; 220 | begin 221 | for i := 0 to TTServer.Server.ClientCount - 1 do 222 | begin 223 | aClient := TClient (TTServer.Server.Client[i]); 224 | memo1.Lines.Add (''); 225 | memo1.Lines.Add('------ Client ' + string (aClient.Parser.ClientID) + ' -------'); 226 | memo1.Lines.Add (format ('Username "%s" Password "%s"', [aClient.Parser.Username, aClient.Parser.Password])); 227 | memo1.Lines.Add (format ('Keep Alive "%d" Retry Time "%d" Max Retries "%d"', [aClient.Parser.KeepAlive, aClient.Parser.RetryTime, aClient.Parser.MaxRetries])); 228 | memo1.Lines.Add (format ('Will Topic "%s" Message "%s" @ %s', [aClient.Parser.WillTopic, aClient.Parser.WillMessage, QosNames [aClient.Parser.WillQos]])); 229 | memo1.Lines.Add ('Subscriptions ----'); 230 | for j := 0 to aClient.Subscriptions.Count - 1 do 231 | begin 232 | x := cardinal (aClient.Subscriptions.Objects[j]) and $03; 233 | memo1.Lines.Add (' "' + aClient.Subscriptions[j] + '" @ ' + QOSNames[TMQTTQOSType (x)]); 234 | end; 235 | end; 236 | end; 237 | 238 | procedure TMainForm.Button24Click (Sender: TObject); 239 | var 240 | i, x : integer; 241 | aStr : AnsiString; 242 | begin 243 | aStr := ''; 244 | for i := 0 to MsgBox.Lines.Count - 1 do 245 | begin 246 | x := length (MsgBox.Lines[i]); 247 | aStr := aStr + AnsiChar (x div $100) + AnsiChar (x mod $100) + AnsiString (MsgBox.Lines[i]); 248 | end; 249 | TTClient.Publish (UTF8String (TopicTxt.Text), aStr, aQos, aRetain); 250 | end; 251 | 252 | procedure TMainForm.Button2Click (Sender: TObject); 253 | begin 254 | BrokerForm.FServer := TTServer; 255 | BrokerForm.Show; 256 | end; 257 | 258 | procedure TMainForm.Button3Click (Sender: TObject); 259 | begin 260 | try 261 | TTClient.Link.Close; 262 | except 263 | end; 264 | end; 265 | 266 | procedure TMainForm.Button4Click(Sender: TObject); 267 | begin 268 | TTClient.Publish ('request/png/' + TTClient.ClientID, '?', qtEXACTLY_ONCE); 269 | end; 270 | 271 | procedure TMainForm.Button5Click (Sender: TObject); 272 | var 273 | s : TStringlist; 274 | i : integer; 275 | begin 276 | s := TStringList.Create; 277 | for i := 0 to TopicsTxt.Lines.Count - 1 do 278 | s.AddObject(TopicsTxt.Lines[i], TObject (aQos)); 279 | TTClient.Subscribe (s); 280 | s.Free; 281 | end; 282 | 283 | procedure TMainForm.Button6Click(Sender: TObject); 284 | var 285 | s : TStringlist; 286 | i : integer; 287 | begin 288 | s := TStringList.Create; 289 | for i := 0 to TopicsTxt.Lines.Count - 1 do 290 | s.Add (TopicsTxt.Lines[i]); 291 | TTClient.Unsubscribe (s); 292 | s.Free; 293 | end; 294 | 295 | procedure TMainForm.Button8Click(Sender: TObject); 296 | begin 297 | TTClient.Publish ('csi/pnl/set/text/' + UTF8String (JTxt.Text), AnsiString (Edit1.Text), qtAT_MOST_ONCE, false); 298 | end; 299 | 300 | procedure TMainForm.Button9Click(Sender: TObject); 301 | begin 302 | TTClient.Publish ('csi/pnl/set/state/' + UTF8String (JTxt.Text), '0', qtAT_MOST_ONCE, false); 303 | end; 304 | 305 | procedure TMainForm.CleanBox2Click(Sender: TObject); 306 | begin 307 | TTClient.Clean := CleanBox2.Checked; 308 | end; 309 | 310 | procedure TMainForm.CMonHeader(Sender: TObject; aMsgType: TMQTTMessageType; 311 | aDup: Boolean; aQos: TMQTTQOSType; aRetain: Boolean); 312 | begin 313 | CMsgTxt.Caption := MsgNames[aMsgType]; 314 | CQosTxt.Caption := QosNames[aQos]; 315 | end; 316 | 317 | procedure TMainForm.FormCreate (Sender: TObject); 318 | begin 319 | aQos := qtAT_LEAST_ONCE; 320 | aRetain := false; 321 | LoadSettings; 322 | // load retained messages 323 | end; 324 | 325 | procedure TMainForm.FormDestroy(Sender: TObject); 326 | begin 327 | // store retained messages 328 | StoreSettings; 329 | end; 330 | 331 | procedure TMainForm.FormShow (Sender: TObject); 332 | begin 333 | PortTxt.Text := IntToStr (TTServer.Port); 334 | CPortTxt.Text := IntToStr (TTClient.Port); 335 | AddrTxt.Text := TTClient.Host; 336 | BounceBox.Checked := TTServer.LocalBounce; 337 | BounceBox2.Checked := TTClient.LocalBounce; 338 | rb1.Checked := (aQos = qtAT_MOST_ONCE); 339 | rb2.Checked := (aQos = qtAT_LEAST_ONCE); 340 | rb3.Checked := (aQos = qtEXACTLY_ONCE); 341 | CleanBox2.Checked := TTClient.Clean; 342 | ClientIDTxt.Caption := ''; 343 | TTServer.FOnMonHdr := SMonHeader; 344 | TTClient.Parser.OnHeader := CMonHeader; 345 | RetainBox.Checked := aRetain; 346 | end; 347 | 348 | procedure TMainForm.GaugeBar1UserChange(Sender: TObject); 349 | begin 350 | // TTClient.Publish ('csi/pnl/set/amount/' + UTF8String (JTxt.Text), AnsiString (IntToStr (GaugeBar1.Position)), qtAT_MOST_ONCE, false); 351 | end; 352 | 353 | procedure TMainForm.JTxtKeyPress(Sender: TObject; var Key: Char); 354 | begin 355 | if not CharInSet (Key, ['0'..'9', #8]) then Key := #0; 356 | end; 357 | 358 | procedure TMainForm.LoadSettings; 359 | var 360 | anIniFile : string; 361 | begin 362 | anIniFile := ChangeFileExt (Application.ExeName, '.ini'); 363 | with TIniFile.Create (anIniFile) do 364 | begin 365 | TTServer.Port := ReadInteger ('SERVER', 'Port', 1883); 366 | TTServer.LocalBounce := ReadBool ('SERVER', 'Local Bounce', true); 367 | TTClient.Host := ReadString ('CLIENT', 'Host', 'localhost'); 368 | TTClient.Port := ReadInteger ('CLIENT', 'Port', 1883); 369 | TTClient.LocalBounce := ReadBool ('CLIENT', 'Local Bounce', false); 370 | aQos := TMQTTQOSType (ReadInteger ('CLIENT', 'Qos', 1)); 371 | CMBox.Checked := ReadBool ('SERVER', 'Monitor', true); 372 | CMBox2.Checked := ReadBool ('CLIENT', 'Monitor', true); 373 | Free; 374 | end; 375 | end; 376 | 377 | procedure TMainForm.StoreSettings; 378 | var 379 | anIniFile : string; 380 | begin 381 | anIniFile := ChangeFileExt (Application.ExeName, '.ini'); 382 | with TIniFile.Create (anIniFile) do 383 | begin 384 | WriteInteger ('SERVER', 'Port', TTServer.Port); 385 | WriteBool ('SERVER', 'Local Bounce', TTServer.LocalBounce); 386 | writeString ('CLIENT', 'Host', TTClient.Host); 387 | WriteInteger ('CLIENT', 'Port', TTClient.Port); 388 | WriteInteger ('CLIENT', 'Qos', ord (aQos)); 389 | WriteBool ('CLIENT', 'Local Bounce', TTClient.LocalBounce); 390 | WriteBool ('SERVER', 'Monitor', CMBox.Checked); 391 | WriteBool ('CLIENT', 'Monitor', CMBox2.Checked); 392 | Free; 393 | end; 394 | end; 395 | 396 | procedure TMainForm.TTClientClientID(Sender: TObject; 397 | var aClientID: UTF8String); 398 | begin 399 | TTClient.SetWill ('will/' + aClientID, 'I''ve had it folks..', qtEXACTLY_ONCE); 400 | end; 401 | 402 | procedure TMainForm.TTClientEnableChange(Sender: TObject); 403 | begin 404 | CEnableTxt.Caption := ny[TMQTTClient (Sender).Enabled]; 405 | if TMQTTClient (Sender).Enabled then 406 | memo2.Lines.Add ('Client is enabled.') 407 | else 408 | memo2.Lines.Add ('Client is disabled.'); 409 | end; 410 | 411 | procedure TMainForm.TTClientFailure(Sender: TObject; aReason: Integer; 412 | var CloseClient: Boolean); 413 | begin 414 | memo2.Lines.Add ('---- Failure Reported ' + FailureNames (aReason)); 415 | end; 416 | 417 | procedure TMainForm.TTClientMon (Sender: TObject; aStr: string); 418 | begin 419 | if CMBox2.Checked then memo2.Lines.Add (aStr); 420 | end; 421 | 422 | procedure TMainForm.TTClientMsg (Sender: TObject; aTopic: UTF8String; 423 | aMessage: AnsiString; aQos : TMQTTQOSType; aRetained : boolean); 424 | var 425 | i, x : integer; 426 | aStr : string; 427 | ForMe : boolean; 428 | t : TStringList; 429 | begin // Sender TMQTTClient 430 | memo2.Lines.Add ('MESSAGE "' + string (aTopic) + '".'); 431 | memo2.Lines.Add (IntToStr (length (aMessage)) + ' byte(s) @ ' + QOSNames[aQos]); 432 | if aRetained then 433 | memo2.Lines.Add('This is a Retained message.'); 434 | t := SubTopics (aTopic); 435 | if t[0] = 'will' then 436 | memo2.Lines.Add (string (aMessage)) 437 | else if t.Count >= 2 then 438 | begin 439 | if t[0] = 'update' then 440 | begin 441 | if t[1] = 'memo' then 442 | begin 443 | ForMe := true; 444 | if (t.Count > 2) then ForMe := (t[2] = string (TTClient.ClientID)); 445 | if ForMe then 446 | begin 447 | Memo3.Lines.Clear; 448 | i := 1; 449 | while (i + 1) <= length (aMessage) do 450 | begin 451 | aStr := ''; 452 | x := ord (aMessage[i]) * $100 + ord (aMessage[i + 1]); 453 | i := i + 2; 454 | if (x > 0) then 455 | begin 456 | aStr := Copy (string (aMessage), i, x); 457 | i := i + x; 458 | end; 459 | memo3.Lines.Add (aStr); 460 | end; // while 461 | if aRetained then memo3.Lines.Add ('(Retained)'); 462 | end; // forme 463 | end; // [t[1] 464 | end; // t[0] 465 | end; // t.Count >= 2 466 | memo2.Lines.Add ('MESSAGE END'); 467 | t.Free; 468 | end; 469 | 470 | procedure TMainForm.TTClientOffline(Sender: TObject; Graceful: Boolean); 471 | begin 472 | COnlineTxt.Caption := 'NO'; 473 | ClientIDTxt.Caption := ''; 474 | if Graceful then 475 | memo2.Lines.Add ('Client Gracefully Disconnected.') 476 | else 477 | memo2.Lines.Add ('Client Terminated Unexpectedly.'); 478 | end; 479 | 480 | procedure TMainForm.TTClientOnline(Sender: TObject); 481 | begin 482 | COnlineTxt.Caption := 'YES'; 483 | memo2.Lines.Add ('Client is online.'); 484 | ClientIDTxt.Caption := string (TTClient.Parser.ClientID); 485 | Button5Click (Button5); 486 | end; 487 | 488 | procedure TMainForm.TTServerBrokerEnableChange(Sender: TObject); 489 | begin 490 | if BrokerForm.Visible then BrokerForm.RefreshTree; 491 | end; 492 | 493 | procedure TMainForm.TTServerBrokerOffline(Sender: TObject; Graceful: Boolean); 494 | begin 495 | if BrokerForm.Visible then BrokerForm.RefreshTree; 496 | end; 497 | 498 | procedure TMainForm.TTServerBrokerOnline(Sender: TObject); 499 | begin 500 | if BrokerForm.Visible then BrokerForm.RefreshTree; 501 | end; 502 | 503 | procedure TMainForm.TTServerCheckUser(Sender: TObject; aUser, aPass: UTF8String; 504 | var Allowed: Boolean); 505 | begin 506 | memo1.Lines.Add ('Login Approval Username "' + string (aUser) + '" Password "' + string (aPass) + '".'); 507 | Allowed := true; 508 | end; 509 | 510 | procedure TMainForm.TTServerClientsChange (Sender: TObject; anID: Word); 511 | begin 512 | SClientsTxt.Caption := IntToStr (anID); 513 | end; 514 | 515 | procedure TMainForm.TTServerDeleteSession (Sender: TObject; 516 | aClientID: UTF8String); 517 | begin 518 | memo1.Lines.Add ('Delete Session for "' + string (aClientID) + '".'); 519 | end; 520 | 521 | procedure TMainForm.TTServerEnableChange (Sender: TObject); 522 | begin 523 | SEnableTxt.Caption := ny[TTServer.Enabled]; 524 | end; 525 | 526 | procedure TMainForm.TTServerFailure (Sender: TObject; aReason: Integer; 527 | var CloseClient: Boolean); 528 | begin 529 | memo1.Lines.Add ('---- Failure Reported ' + FailureNames (aReason)); 530 | end; 531 | 532 | procedure TMainForm.TTServerMon(Sender: TObject; aStr: string); 533 | begin 534 | if CMBox.Checked then memo1.Lines.Add (aStr); 535 | end; 536 | 537 | procedure TMainForm.TTServerObituary(Sender: TObject; var aTopic, 538 | aMessage: UTF8String; var aQos: TMQTTQOSType); 539 | begin 540 | if not (Sender is TClient) then exit; 541 | memo1.Lines.Add ('Obituary Approval "' + string (aTopic) + '" with message "' + string (aMessage) + '"'); 542 | with TClient (Sender) do 543 | begin 544 | aMessage := Parser.ClientID + ' failed at ' + UTF8String (TimeToStr (Now)) + ' - ' + aMessage; 545 | end; 546 | end; 547 | 548 | procedure TMainForm.TTServerRestoreSession(Sender: TObject; 549 | aClientID: UTF8String); 550 | begin 551 | memo1.Lines.Add ('Restore Session for "' + string (aClientID) + '".'); 552 | end; 553 | 554 | procedure TMainForm.TTServerStoreSession(Sender: TObject; 555 | aClientID: UTF8String); 556 | begin 557 | memo1.Lines.Add ('Store Session for "' + string (aClientID) + '".'); 558 | end; 559 | 560 | procedure TMainForm.TTServerSubscription(Sender: TObject; aTopic: UTF8String; 561 | var RequestedQos: TMQTTQOSType); 562 | begin 563 | memo1.Lines.Add ('Subscription Approval "' + string (aTopic) + '" @ ' + QOSNames [RequestedQOS]); 564 | end; 565 | 566 | procedure TMainForm.Memo1DblClick(Sender: TObject); 567 | begin 568 | Memo1.Lines.Clear; 569 | end; 570 | 571 | procedure TMainForm.Memo2DblClick(Sender: TObject); 572 | begin 573 | memo2.Lines.Clear; 574 | end; 575 | 576 | procedure TMainForm.Memo3DblClick(Sender: TObject); 577 | begin 578 | Memo3.Lines.Clear; 579 | end; 580 | 581 | procedure TMainForm.PortTxtKeyPress(Sender: TObject; var Key: Char); 582 | begin 583 | if not CharInSet (Key, ['0'..'9', #8]) then Key := #0; 584 | end; 585 | 586 | procedure TMainForm.rb1Click (Sender: TObject); 587 | begin 588 | aQos := TMQTTQOSType (TRadioButton (Sender).Tag); 589 | end; 590 | 591 | procedure TMainForm.RetainBoxClick(Sender: TObject); 592 | begin 593 | aRetain := RetainBox.Checked; 594 | end; 595 | 596 | procedure TMainForm.SMonHeader(Sender: TObject; aMsgType: TMQTTMessageType; 597 | aDup: Boolean; aQos: TMQTTQOSType; aRetain: Boolean); 598 | begin 599 | SMsgTxt.Caption := MsgNames[aMsgType]; 600 | SQosTxt.Caption := QosNames[aQos]; 601 | end; 602 | 603 | 604 | end. 605 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | delphi-mqtt 2 | =========== 3 | 4 | MQTT server and client components for Delphi -------------------------------------------------------------------------------- /src/MQTTComponents.dpk: -------------------------------------------------------------------------------- 1 | package MQTTComponents; 2 | 3 | {$R *.res} 4 | {$ALIGN 8} 5 | {$ASSERTIONS ON} 6 | {$BOOLEVAL OFF} 7 | {$DEBUGINFO ON} 8 | {$EXTENDEDSYNTAX ON} 9 | {$IMPORTEDDATA ON} 10 | {$IOCHECKS ON} 11 | {$LOCALSYMBOLS ON} 12 | {$LONGSTRINGS ON} 13 | {$OPENSTRINGS ON} 14 | {$OPTIMIZATION ON} 15 | {$OVERFLOWCHECKS OFF} 16 | {$RANGECHECKS OFF} 17 | {$REFERENCEINFO ON} 18 | {$SAFEDIVIDE OFF} 19 | {$STACKFRAMES OFF} 20 | {$TYPEDADDRESS OFF} 21 | {$VARSTRINGCHECKS ON} 22 | {$WRITEABLECONST OFF} 23 | {$MINENUMSIZE 1} 24 | {$IMAGEBASE $400000} 25 | {$IMPLICITBUILD ON} 26 | 27 | requires 28 | rtl, 29 | vcl, 30 | OverbyteIcsDXeRun; 31 | 32 | contains 33 | uMQTTComps in 'uMQTTComps.pas', 34 | uMQTT in 'uMQTT.pas'; 35 | 36 | end. 37 | -------------------------------------------------------------------------------- /src/MQTTComponents.dproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | {BA2E8961-2769-4173-B5A1-093FF189B3EC} 4 | MQTTComponents.dpk 5 | 12.2 6 | True 7 | Debug 8 | Win32 9 | Package 10 | VCL 11 | DCC32 12 | 13 | 14 | true 15 | 16 | 17 | true 18 | Base 19 | true 20 | 21 | 22 | true 23 | Base 24 | true 25 | 26 | 27 | true 28 | All 29 | true 30 | 00400000 31 | .\$(Config)\$(Platform) 32 | WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;$(DCC_UnitAlias) 33 | .\$(Config)\$(Platform) 34 | 35 | 36 | C:\Delphi Projects\ICS\Delphi\Vc32;$(DCC_UnitSearchPath) 37 | DEBUG;$(DCC_Define) 38 | false 39 | true 40 | 41 | 42 | false 43 | RELEASE;$(DCC_Define) 44 | 0 45 | false 46 | 47 | 48 | 49 | MainSource 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | Cfg_2 58 | Base 59 | 60 | 61 | Base 62 | 63 | 64 | Cfg_1 65 | Base 66 | 67 | 68 | 69 | 70 | 71 | Delphi.Personality.12 72 | Package 73 | 74 | 75 | 76 | MQTTComponents.dpk 77 | 78 | 79 | True 80 | False 81 | 1 82 | 0 83 | 0 84 | 0 85 | False 86 | False 87 | False 88 | False 89 | False 90 | 3081 91 | 1252 92 | 93 | 94 | 95 | 96 | 1.0.0.0 97 | 98 | 99 | 100 | 101 | 102 | 1.0.0.0 103 | 104 | 105 | 106 | Microsoft Office 2000 Sample Automation Server Wrapper Components 107 | Microsoft Office XP Sample Automation Server Wrapper Components 108 | 109 | 110 | 111 | True 112 | 113 | 114 | 12 115 | 116 | 117 | -------------------------------------------------------------------------------- /src/MQTTComponents.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pjde/delphi-mqtt/65ef33f009f7b96d0e50f35d1591df08be79011f/src/MQTTComponents.res -------------------------------------------------------------------------------- /src/uMQTT.pas: -------------------------------------------------------------------------------- 1 | unit uMQTT; 2 | (* Web Sites 3 | http://www.alphaworks.ibm.com/tech/rsmb 4 | http://www.mqtt.org 5 | 6 | Permission to copy and display the MQ Telemetry Transport specification (the 7 | "Specification"), in any medium without fee or royalty is hereby granted by Eurotech 8 | and International Business Machines Corporation (IBM) (collectively, the "Authors"), 9 | provided that you include the following on ALL copies of the Specification, or portions 10 | thereof, that you make: 11 | A link or URL to the Specification at one of 12 | 1. the Authors' websites. 13 | 2. The copyright notice as shown in the Specification. 14 | 15 | The Authors each agree to grant you a royalty-free license, under reasonable, 16 | non-discriminatory terms and conditions to their respective patents that they deem 17 | necessary to implement the Specification. THE SPECIFICATION IS PROVIDED "AS IS," 18 | AND THE AUTHORS MAKE NO REPRESENTATIONS OR WARRANTIES, EXPRESS OR 19 | IMPLIED, INCLUDING, BUT NOT LIMITED TO, WARRANTIES OF MERCHANTABILITY, 20 | FITNESS FOR A PARTICULAR PURPOSE, NON-INFRINGEMENT, OR TITLE; THAT THE 21 | CONTENTS OF THE SPECIFICATION ARE SUITABLE FOR ANY PURPOSE; NOR THAT THE 22 | IMPLEMENTATION OF SUCH CONTENTS WILL NOT INFRINGE ANY THIRD PARTY 23 | PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER RIGHTS. THE AUTHORS WILL NOT 24 | BE LIABLE FOR ANY DIRECT, INDIRECT, SPECIAL, INCIDENTAL OR CONSEQUENTIAL 25 | DAMAGES ARISING OUT OF OR RELATING TO ANY USE OR DISTRIBUTION OF THE 26 | SPECIFICATION *) 27 | 28 | interface 29 | uses 30 | Classes; 31 | 32 | const 33 | MQTT_PROTOCOL = 'MQIsdp'; 34 | MQTT_VERSION = 3; 35 | 36 | DefRetryTime = 60; // 6 seconds 37 | DefMaxRetries = 8; 38 | 39 | rsHdr = 0; 40 | rsLen = 1; 41 | rsVarHdr = 2; 42 | rsPayload = 3; 43 | 44 | frKEEPALIVE = 0; // keep alive exceeded 45 | frMAXRETRIES = 1; 46 | 47 | rcACCEPTED = 0; // Connection Accepted 48 | rcPROTOCOL = 1; // Connection Refused: unacceptable protocol version 49 | rcIDENTIFIER = 2; // Connection Refused: identifier rejected 50 | rcSERVER = 3; // Connection Refused: server unavailable 51 | rcUSER = 4; // Connection Refused: bad user name or password 52 | rcAUTHORISED = 5; // Connection Refused: not authorised 53 | // 6-255 Reserved for future use 54 | ny : array [boolean] of string = ('NO', 'YES'); 55 | 56 | type 57 | // Message type 58 | TMQTTMessageType = 59 | ( 60 | // mtReserved0, // 0 Reserved 61 | mtBROKERCONNECT, // 0 Broker request to connect to Broker 62 | mtCONNECT, // 1 Client request to connect to Broker 63 | mtCONNACK, // 2 Connect Acknowledgment 64 | mtPUBLISH, // 3 Publish message 65 | mtPUBACK, // 4 Publish Acknowledgment 66 | mtPUBREC, // 5 Publish Received (assured delivery part 1) 67 | mtPUBREL, // 6 Publish Release (assured delivery part 2) 68 | mtPUBCOMP, // 7 Publish Complete (assured delivery part 3) 69 | mtSUBSCRIBE, // 8 Client Subscribe request 70 | mtSUBACK, // 9 Subscribe Acknowledgment 71 | mtUNSUBSCRIBE, // 10 Client Unsubscribe request 72 | mtUNSUBACK, // 11 Unsubscribe Acknowledgment 73 | mtPINGREQ, // 12 PING Request 74 | mtPINGRESP, // 13 PING Response 75 | mtDISCONNECT, // 14 Client is Disconnecting 76 | mtReserved15 // 15 77 | ); 78 | 79 | TMQTTQOSType = 80 | ( 81 | qtAT_MOST_ONCE, // 0 At most once Fire and Forget <=1 82 | qtAT_LEAST_ONCE, // 1 At least once Acknowledged delivery >=1 83 | qtEXACTLY_ONCE, // 2 Exactly once Assured delivery =1 84 | qtReserved3 // 3 Reserved 85 | ); 86 | 87 | TMQTTStreamEvent = procedure (Sender : TObject; anID : Word; Retry : integer; aStream : TMemoryStream) of object; 88 | TMQTTMonEvent = procedure (Sender : TObject; aStr : string) of object; 89 | TMQTTCheckUserEvent = procedure (Sender : TObject; aUser, aPass : UTF8String; var Allowed : Boolean) of object; 90 | TMQTTPubResponseEvent = procedure (Sender : TObject; aMsg : TMQTTMessageType; anID : Word) of object; 91 | TMQTTIDEvent = procedure (Sender : TObject; anID : Word) of object; 92 | TMQTTAckEvent = procedure (Sender : TObject; aCode : Byte) of object; 93 | TMQTTDisconnectEvent = procedure (Sender : TObject; Graceful : Boolean) of object; 94 | TMQTTSubscriptionEvent = procedure (Sender : TObject; aTopic : UTF8String; var RequestedQos : TMQTTQOSType) of object; 95 | TMQTTSubscribeEvent = procedure (Sender : TObject; anID : Word; Topics : TStringList) of object; 96 | TMQTTUnsubscribeEvent = procedure (Sender : TObject; anID : Word; Topics : TStringList) of object; 97 | TMQTTSubAckEvent = procedure (Sender : TObject; anID : Word; Qoss : array of TMQTTQosType) of object; 98 | TMQTTFailureEvent = procedure (Sender : TObject; aReason : integer; var CloseClient : Boolean) of object; 99 | TMQTTMsgEvent = procedure (Sender : TObject; aTopic : UTF8String; aMessage : AnsiString; aQos : TMQTTQOSType; aRetained : boolean) of object; 100 | TMQTTRetainEvent = procedure (Sender : TObject; aTopic : UTF8String; aMessage : AnsiString; aQos : TMQTTQOSType) of object; 101 | TMQTTRetainedEvent = procedure (Sender : TObject; Subscribed : UTF8String; var aTopic : UTF8String; var aMessage : AnsiString; var aQos : TMQTTQOSType) of object; 102 | TMQTTPublishEvent = procedure (Sender : TObject; anID : Word; aTopic : UTF8String; aMessage : AnsiString) of object; 103 | TMQTTClientIDEvent = procedure (Sender : TObject; var aClientID : UTF8String) of object; 104 | TMQTTConnectEvent = procedure (Sender : TObject; 105 | Protocol : UTF8String; 106 | Version : byte; 107 | ClientID, 108 | UserName, Password : UTF8String; 109 | KeepAlive : Word; Clean : Boolean) of object; 110 | TMQTTWillEvent = procedure (Sender : TObject; aTopic, aMessage : UTF8String; aQos : TMQTTQOSType; aRetain : boolean) of object; 111 | TMQTTObituaryEvent = procedure (Sender : TObject; var aTopic, aMessage : UTF8String; var aQos : TMQTTQOSType) of object; 112 | TMQTTHeaderEvent = procedure (Sender : TObject; MsgType: TMQTTMessageType; Dup: Boolean; Qos: TMQTTQOSType; Retain: Boolean) of object; 113 | TMQTTSessionEvent = procedure (Sender : TObject; aClientID : UTF8String) of object; 114 | 115 | TMQTTParser = class 116 | private 117 | FOnSend: TMQTTStreamEvent; 118 | FTxStream : TMemoryStream; 119 | FRxStream : TMemoryStream; 120 | FKeepAliveCount : cardinal; 121 | FKeepAlive : Word; 122 | FWillFlag : boolean; 123 | FRxState, FRxMult, FRxVal : integer; 124 | FOnConnAck: TMQTTAckEvent; 125 | FOnUnsubAck: TMQTTIDEvent; 126 | FOnSubscribe: TMQTTSubscribeEvent; 127 | FOnPing: TNotifyEvent; 128 | FOnDisconnect: TNotifyEvent; 129 | FOnPingResp: TNotifyEvent; 130 | FOnPublish: TMQTTPublishEvent; 131 | FOnConnect: TMQTTConnectEvent; 132 | FOnUnsubscribe: TMQTTUnsubscribeEvent; 133 | FOnSubAck: TMQTTSubAckEvent; 134 | FOnSetWill: TMQTTWillEvent; 135 | FOnHeader: TMQTTHeaderEvent; 136 | FOnMon: TMQTTMonEvent; 137 | FOnPubAck: TMQTTIDEvent; 138 | FOnPubRel: TMQTTIDEvent; 139 | FOnPubComp: TMQTTIDEvent; 140 | FOnPubRec: TMQTTIDEvent; 141 | FMaxRetries: Word; 142 | FRetryTime: Word; 143 | FOnBrokerConnect: TMQTTConnectEvent; 144 | procedure SetKeepAlive(const Value: Word); 145 | public 146 | NosRetries : integer; 147 | RxMsg : TMQTTMessageType; 148 | RxQos : TMQTTQOSType; 149 | RxDup, RxRetain : Boolean; 150 | UserName, Password, 151 | WillTopic: UTF8String; 152 | WillMessage : UTF8String; 153 | WillRetain : Boolean; 154 | WillQos : TMQTTQOSType; 155 | ClientID : UTF8String; 156 | Clean : Boolean; 157 | constructor Create; 158 | destructor Destroy; override; 159 | procedure Reset; 160 | procedure Parse (aStream : TStream); overload; 161 | procedure Parse (aStr : AnsiString); overload; 162 | procedure SetWill (aTopic, aMessage : UTF8String; aQos : TMQTTQOSType; aRetain : boolean); 163 | function CheckKeepAlive : boolean; 164 | procedure Mon (aStr : string); 165 | // client 166 | procedure SendBrokerConnect (aClientID, aUsername, aPassword : UTF8String; aKeepAlive : Word; aClean : Boolean); // non standard 167 | procedure SendConnect (aClientID, aUsername, aPassword : UTF8String; aKeepAlive : Word; aClean : Boolean); 168 | procedure SendPublish (anID : Word; aTopic: UTF8String; aMessage : AnsiString; aQOS : TMQTTQOSType; aDup : boolean = false; aRetain : boolean = false); 169 | procedure SendPing; 170 | procedure SendDisconnect; 171 | procedure SendSubscribe (anID : Word; aTopic : UTF8String; aQOS : TMQTTQOSType); overload; 172 | procedure SendSubscribe (anID : Word; Topics : TStringList); overload; 173 | procedure SendUnsubscribe (anID : Word; aTopic : UTF8String); overload; 174 | procedure SendUnsubscribe (anID : Word; Topics : TStringList); overload; 175 | // server 176 | procedure SendConnAck (aCode : byte); 177 | procedure SendPubAck (anID : Word); 178 | procedure SendPubRec (anID : Word); 179 | procedure SendPubRel (anID : Word; aDup : Boolean = false); 180 | procedure SendPubComp (anID : Word); 181 | procedure SendSubAck (anID : Word; Qoss : array of TMQTTQosType); 182 | procedure SendUnsubAck (anID : Word); 183 | procedure SendPingResp; 184 | property KeepAlive : Word read FKeepAlive write SetKeepAlive; 185 | property RetryTime : Word read FRetryTime write FRetryTime; 186 | property MaxRetries : Word read FMaxRetries write FMaxRetries; 187 | // client 188 | property OnConnAck : TMQTTAckEvent read FOnConnAck write FOnConnAck; 189 | property OnSubAck: TMQTTSubAckEvent read FOnSubAck write FOnSubAck; 190 | property OnPubAck : TMQTTIDEvent read FOnPubAck write FOnPubAck; 191 | property OnPubRel : TMQTTIDEvent read FOnPubRel write FOnPubRel; 192 | property OnPubRec : TMQTTIDEvent read FOnPubRec write FOnPubRec; 193 | property OnPubComp : TMQTTIDEvent read FOnPubComp write FOnPubComp; 194 | property OnUnsubAck : TMQTTIDEvent read FOnUnsubAck write FOnUnsubAck; 195 | property OnPingResp : TNotifyEvent read FOnPingResp write FOnPingResp; 196 | // server 197 | property OnBrokerConnect : TMQTTConnectEvent read FOnBrokerConnect write FOnBrokerConnect; // non standard 198 | property OnConnect : TMQTTConnectEvent read FOnConnect write FOnConnect; 199 | property OnPublish : TMQTTPublishEvent read FOnPublish write FOnPublish; 200 | property OnPing : TNotifyEvent read FOnPing write FOnPing; 201 | property OnDisconnect : TNotifyEvent read FOnDisconnect write FOnDisconnect; 202 | property OnSubscribe : TMQTTSubscribeEvent read FOnSubscribe write FOnSubscribe; 203 | property OnUnsubscribe : TMQTTUnsubscribeEvent read FOnUnsubscribe write FOnUnsubscribe; 204 | property OnSetWill : TMQTTWillEvent read FOnSetWill write FOnSetWill; 205 | property OnHeader : TMQTTHeaderEvent read FOnHeader write FOnHeader; 206 | property OnMon : TMQTTMonEvent read FOnMon write FOnMon; 207 | property OnSend : TMQTTStreamEvent read FOnSend write FOnSend; 208 | end; 209 | 210 | const 211 | MsgNames : array [TMQTTMessageType] of string = 212 | ( 213 | // 'Reserved', // 0 Reserved 214 | 'BROKERCONNECT', // 0 Broker request to connect to Broker 215 | 'CONNECT', // 1 Client request to connect to Broker 216 | 'CONNACK', // 2 Connect Acknowledgment 217 | 'PUBLISH', // 3 Publish message 218 | 'PUBACK', // 4 Publish Acknowledgment 219 | 'PUBREC', // 5 Publish Received (assured delivery part 1) 220 | 'PUBREL', // 6 Publish Release (assured delivery part 2) 221 | 'PUBCOMP', // 7 Publish Complete (assured delivery part 3) 222 | 'SUBSCRIBE', // 8 Client Subscribe request 223 | 'SUBACK', // 9 Subscribe Acknowledgment 224 | 'UNSUBSCRIBE', // 10 Client Unsubscribe request 225 | 'UNSUBACK', // 11 Unsubscribe Acknowledgment 226 | 'PINGREQ', // 12 PING Request 227 | 'PINGRESP', // 13 PING Response 228 | 'DISCONNECT', // 14 Client is Disconnecting 229 | 'Reserved15' // 15 230 | ); 231 | 232 | QOSNames : array [TMQTTQOSType] of string = 233 | ( 234 | 'AT_MOST_ONCE', // 0 At most once Fire and Forget <=1 235 | 'AT_LEAST_ONCE', // 1 At least once Acknowledged delivery >=1 236 | 'EXACTLY_ONCE', // 2 Exactly once Assured delivery =1 237 | 'RESERVED' // 3 Reserved 238 | ); 239 | 240 | function CodeNames (aCode : byte) : string; 241 | function ExtractFileNameOnly (FileName : string) : string; 242 | function FailureNames (aCode : byte) : string; 243 | procedure DebugStr (aStr : string); 244 | 245 | implementation 246 | 247 | uses Windows, SysUtils; 248 | 249 | function ExtractFileNameOnly (FileName : string) : string; 250 | begin 251 | Result := ExtractFileName (FileName); 252 | SetLength (Result, Length (Result) - Length (ExtractFileExt (FileName))); 253 | end; 254 | 255 | function CodeNames (aCode : byte) : string; 256 | begin 257 | case (aCode) of 258 | rcACCEPTED : Result := 'ACCEPTED'; // Connection Accepted 259 | rcPROTOCOL : Result := 'PROTOCOL UNACCEPTABLE'; // Connection Refused: unacceptable protocol version 260 | rcIDENTIFIER : Result := 'IDENTIFIER REJECTED'; // Connection Refused: identifier rejected 261 | rcSERVER : Result := 'SERVER UNAVILABLE'; // Connection Refused: server unavailable 262 | rcUSER : Result := 'BAD LOGIN'; // Connection Refused: bad user name or password 263 | rcAUTHORISED : Result := 'NOT AUTHORISED' 264 | else Result := 'RESERVED ' + IntToStr (aCode); 265 | end; 266 | end; 267 | 268 | function FailureNames (aCode : byte) : string; 269 | begin 270 | case (aCode) of 271 | frKEEPALIVE : Result := 'KEEP ALIVE TIMEOUT'; 272 | frMAXRETRIES : Result := 'MAX RETRIES EXCEEDED'; 273 | else Result := 'RESERVED ' + IntToStr (aCode); 274 | end; 275 | end; 276 | 277 | procedure DebugStr (aStr : string); 278 | begin 279 | OutputDebugString (PChar (aStr)); 280 | end; 281 | 282 | procedure AddByte (aStream : TStream; aByte: Byte); 283 | begin 284 | aStream.Write (aByte, 1); 285 | end; 286 | 287 | procedure AddHdr (aStream : TStream; MsgType: TMQTTMessageType; Dup: Boolean; 288 | Qos: TMQTTQOSType; Retain: Boolean); 289 | begin 290 | { Fixed Header Spec: 291 | bit |7 6 5 4 | |3 | |2 1 | | 0 | 292 | byte 1 |Message Type| |DUP flag| |QoS level| |RETAIN| } 293 | AddByte (aStream, (Ord (MsgType) shl 4) + (ord (Dup) shl 3) + (ord (Qos) shl 1) + ord (Retain)); 294 | end; 295 | 296 | procedure AddLength (aStream : TStream; aLen: integer); 297 | var 298 | x : integer; 299 | dig : byte; 300 | begin 301 | x := aLen; 302 | repeat 303 | dig := x mod 128; 304 | x := x div 128; 305 | if (x > 0) then 306 | dig := dig or $80; 307 | AddByte (aStream, dig); 308 | until (x = 0); 309 | end; 310 | 311 | procedure AddStr (aStream : TStream; aStr: UTF8String); 312 | var 313 | l : integer; 314 | begin 315 | l := length (aStr); 316 | AddByte (aStream, l div $100); 317 | AddByte (aStream, l mod $100); 318 | aStream.Write (aStr[1], length (aStr)); 319 | end; 320 | 321 | function ReadByte (aStream : TStream) : Byte; 322 | begin 323 | if aStream.Position = aStream.Size then 324 | Result := 0 325 | else 326 | aStream.Read (Result, 1); 327 | end; 328 | 329 | function ReadHdr (aStream : TStream; var MsgType: TMQTTMessageType; var Dup: Boolean; 330 | var Qos: TMQTTQOSType; var Retain: Boolean) : byte; 331 | begin 332 | Result := ReadByte (aStream); 333 | { Fixed Header Spec: 334 | bit |7 6 5 4 | |3 | |2 1 | | 0 | 335 | byte 1 |Message Type| |DUP flag| |QoS level| |RETAIN| } 336 | MsgType := TMQTTMessageType ((Result and $f0) shr 4); 337 | Dup := (Result and $08) > 0; 338 | Qos := TMQTTQOSType ((Result and $06) shr 1); 339 | Retain := (Result and $01) > 0; 340 | end; 341 | 342 | function ReadLength (aStream : TStream) : integer; 343 | var 344 | mult : integer; 345 | x : byte; 346 | begin 347 | mult := 0; 348 | Result := 0; 349 | repeat 350 | x := ReadByte (aStream); 351 | Result := Result + ((x and $7f) * mult); 352 | until (x and $80) <> 0; 353 | end; 354 | 355 | function ReadStr (aStream : TStream) : UTF8String; 356 | var 357 | l : integer; 358 | begin 359 | l := ReadByte (aStream) * $100 + ReadByte (aStream); 360 | if aStream.Position + l <= aStream.Size then 361 | begin 362 | SetLength (Result, l); 363 | aStream.Read (Result[1], l); 364 | end; 365 | end; 366 | 367 | { TMQTTParser } 368 | 369 | function TMQTTParser.CheckKeepAlive: boolean; 370 | begin 371 | Result := true; 372 | if FKeepAliveCount > 0 then 373 | begin 374 | FKeepAliveCount := FKeepAliveCount - 1; 375 | Result := (FKeepAliveCount > 0); 376 | end; 377 | end; 378 | 379 | constructor TMQTTParser.Create; 380 | begin 381 | KeepAlive := 10; 382 | FKeepAliveCount := 0; 383 | FMaxRetries := DefMaxRetries; 384 | FRetryTime := DefRetryTime; 385 | NosRetries := 0; 386 | ClientID := ''; 387 | WillTopic := ''; 388 | WillMessage := ''; 389 | FWillFlag := false; 390 | WillQos := qtAT_LEAST_ONCE; 391 | WillRetain := false; 392 | Username := ''; 393 | Password := ''; 394 | FRxState := rsHdr; 395 | FRxMult := 0; 396 | FRxVal := 0; 397 | RxMsg := mtReserved15; 398 | RxQos := qtAT_MOST_ONCE; 399 | RxDup := false; 400 | RxRetain := false; 401 | FTxStream := TMemoryStream.Create; 402 | FRxStream := TMemoryStream.Create; 403 | end; 404 | 405 | destructor TMQTTParser.Destroy; 406 | begin 407 | FTxStream.Free; 408 | FRxStream.Free; 409 | inherited; 410 | end; 411 | 412 | procedure TMQTTParser.Mon (aStr: string); 413 | begin 414 | if Assigned (FOnMon) then FOnMon (Self, 'P ' + aStr); 415 | end; 416 | 417 | procedure TMQTTParser.Parse (aStr: AnsiString); 418 | var 419 | aStream : TMemoryStream; 420 | begin 421 | aStream := TMemoryStream.Create; 422 | aStream.Write (aStr[1], length (aStr)); 423 | aStream.Seek (0, soFromBeginning); 424 | Parse (aStream); 425 | aStream.Free; 426 | end; 427 | 428 | procedure TMQTTParser.Reset; 429 | begin 430 | FRxState := rsHdr; 431 | FRxStream.Clear; 432 | FTxStream.Clear; 433 | RxMsg := mtReserved15; 434 | RxDup := false; 435 | RxQOs := qtAT_MOST_ONCE; 436 | RxRetain := false; 437 | end; 438 | 439 | procedure TMQTTParser.Parse (aStream: TStream); 440 | var 441 | x, fl, vr, wq : byte; 442 | id, ka : Word; 443 | wr, wf, un, ps, cl: Boolean; 444 | wt, wm, ci, pt : UTF8String; 445 | aStr, bStr : UTF8String; 446 | Str : AnsiString; 447 | Strs : TStringList; 448 | Qoss : array of TMQTTQOSType; 449 | begin 450 | while aStream.Position <> aStream.Size do 451 | begin 452 | case FRxState of 453 | rsHdr : 454 | begin 455 | ReadHdr (aStream, RxMsg, RxDup, RxQos, RxRetain); 456 | FRxState := rsLen; 457 | FRxMult := 1; 458 | FRxVal := 0; 459 | if Assigned (FOnHeader) then FOnHeader (Self, RxMsg, RxDup, RxQos, RxRetain); 460 | end; 461 | rsLen : 462 | begin 463 | x := ReadByte (aStream); 464 | FRxVal := FRxVal + ((x and $7f) * FRxMult); 465 | FRxMult := FRxMult * $80; 466 | if (x and $80) = 0 then 467 | begin 468 | FKeepAliveCount := KeepAlive * 10; 469 | FRxStream.Clear; 470 | if FRxVal = 0 then 471 | begin 472 | case RxMsg of 473 | mtPINGREQ : 474 | if Assigned (FOnPing) then FOnPing (Self); 475 | mtPINGRESP : 476 | if Assigned (FOnPingResp) then FOnPingResp (Self); 477 | mtDISCONNECT : 478 | if Assigned (FOnDisconnect) then FOnDisconnect (Self); 479 | end; 480 | FRxState := rsHdr; 481 | end 482 | else 483 | begin 484 | FRxState := rsVarHdr; 485 | end; 486 | end; 487 | end; 488 | rsVarHdr : 489 | begin 490 | x := ReadByte (aStream); 491 | FRxStream.Write (x, 1); 492 | FRxVal := FRxVal - 1; 493 | if FRxVal = 0 then 494 | begin 495 | FRxStream.Seek (0, soFromBeginning); 496 | case RxMsg of 497 | mtBROKERCONNECT, 498 | mtCONNECT : 499 | begin 500 | pt := ReadStr (FRxStream); // protocol 501 | vr := ReadByte (FRxStream); // version 502 | fl := ReadByte (FRxStream); 503 | ka := ReadByte (FRxStream) * $100 + ReadByte (FRxStream); 504 | ci := ReadStr (FRxStream); 505 | wf := (fl and $04) > 0; // will flag 506 | wr := (fl and $10) > 0; // will retain 507 | wq := (fl and $18) shr 3; // will qos 508 | un := (fl and $80) > 0; // user name 509 | ps := (fl and $40) > 0; // pass word 510 | cl := (fl and $02) > 0; // clean 511 | wt := ''; 512 | wm := ''; 513 | if wf then 514 | begin 515 | wt := ReadStr (FRxStream); // will topic 516 | wm := ReadStr (FRxStream); // will message 517 | if Assigned (FOnSetWill) then 518 | FOnSetWill (Self, wt, wm, TMQTTQOSType (wq), wr); 519 | end; 520 | aStr := ''; 521 | bStr := ''; 522 | if un then aStr := ReadStr (FRxStream); // username 523 | if ps then bStr := ReadStr (FRxStream); // password 524 | if RxMsg = mtCONNECT then 525 | begin 526 | if Assigned (FOnConnect) then 527 | FOnConnect (Self, pt, vr, ci, aStr, bStr, ka, cl); 528 | end 529 | else if RxMsg = mtBROKERCONNECT then 530 | begin 531 | if Assigned (FOnBrokerConnect) then 532 | FOnBrokerConnect (Self, pt, vr, ci, aStr, bStr, ka, cl); 533 | end; 534 | end; 535 | mtPUBLISH : 536 | if FRxStream.Size >= 4 then 537 | begin 538 | aStr := ReadStr (FRxStream); 539 | if RxQos in [qtAT_LEAST_ONCE, qtEXACTLY_ONCE] then 540 | id := ReadByte (FRxStream) * $100 + ReadByte (FRxStream) 541 | else 542 | id := 0; // no id when RxQos = 0 543 | SetLength (Str, FRxStream.Size - FRxStream.Position); 544 | if length (Str) > 0 then FRxStream.Read (Str[1], length (Str)); 545 | if Assigned (FOnPublish) then FOnPublish (Self, id, aStr, Str); 546 | end; 547 | mtPUBACK, 548 | mtPUBREC, 549 | mtPUBREL, 550 | mtPUBCOMP : 551 | if FRxStream.Size = 2 then 552 | begin 553 | id := ReadByte (FRxStream) * $100 + ReadByte (FRxStream); 554 | case RxMsg of 555 | mtPUBACK : if Assigned (FOnPubAck) then FonPubAck (Self, id); 556 | mtPUBREC : if Assigned (FOnPubRec) then FonPubRec (Self, id); 557 | mtPUBREL : if Assigned (FOnPubRel) then FonPubRel (Self, id); 558 | mtPUBCOMP : if Assigned (FOnPubComp) then FonPubComp (Self, id); 559 | end; 560 | end; 561 | mtCONNACK : 562 | if FRxStream.Size = 2 then 563 | begin 564 | ReadByte (FRxStream); 565 | id := ReadByte (FRxStream); 566 | if Assigned (FOnConnAck) then 567 | FOnConnAck (Self, id); 568 | end; 569 | mtSUBACK : 570 | if FRxStream.Size >= 2 then 571 | begin 572 | SetLength (Qoss, 0); 573 | id := ReadByte (FRxStream) * $100 + ReadByte (FRxStream); 574 | while FRxStream.Position < FRxStream.Size do 575 | begin 576 | SetLength (Qoss, Length (Qoss) + 1); 577 | Qoss[Length (Qoss) - 1] := TMQTTQOSType (ReadByte (FRxStream) and $03); 578 | end; 579 | if Assigned (FOnSubAck) then FOnSubAck (Self, id, Qoss); 580 | end; 581 | mtUNSUBACK : 582 | if FRxStream.Size = 2 then 583 | begin 584 | ReadByte (FRxStream); 585 | id := ReadByte (FRxStream); 586 | if Assigned (FOnUnsubAck) then 587 | FOnUnsubAck (Self, id); 588 | end; 589 | mtUNSUBSCRIBE : 590 | if FRxStream.Size >= 2 then 591 | begin 592 | id := ReadByte (FRxStream) * $100 + ReadByte (FRxStream); 593 | Strs := TStringList.Create; 594 | while FRxStream.Size >= FRxStream.Position + 2 do // len 595 | begin 596 | aStr := ReadStr (FRxStream); 597 | Strs.Add (string (aStr)); 598 | end; 599 | if Assigned (FOnUnsubscribe) then FOnUnsubscribe (Self, id, Strs); 600 | Strs.Free; 601 | end; 602 | mtSUBSCRIBE : 603 | if FRxStream.Size >= 2 then 604 | begin 605 | id := ReadByte (FRxStream) * $100 + ReadByte (FRxStream); 606 | Strs := TStringList.Create; 607 | while FRxStream.Size >= FRxStream.Position + 3 do // len + qos 608 | begin 609 | aStr := ReadStr (FRxStream); 610 | x := ReadByte (FRxStream) and $03; 611 | Strs.AddObject (string (aStr), TObject (x)); 612 | end; 613 | if Assigned (FOnSubscribe) then FOnSubscribe (Self, id, Strs); 614 | Strs.Free; 615 | end; 616 | end; 617 | FKeepAliveCount := KeepAlive * 10; 618 | FRxState := rsHdr; 619 | end; 620 | end; 621 | end; 622 | end; 623 | end; 624 | 625 | procedure TMQTTParser.SendConnect (aClientID, aUsername, aPassword : UTF8String; aKeepAlive : Word; aClean : Boolean); 626 | var 627 | s : TMemoryStream; 628 | x : byte; 629 | begin 630 | KeepAlive := aKeepAlive; 631 | 632 | FTxStream.Clear; // dup, qos, retain not used 633 | AddHdr (FTxStream, mtCONNECT, false, qtAT_LEAST_ONCE, false); 634 | s := TMemoryStream.Create; 635 | // generate payload 636 | AddStr (s, aClientID); 637 | if FWillFlag then 638 | begin 639 | AddStr (s, WillTopic); 640 | AddStr (s, WillMessage); 641 | end; 642 | if length (aUserName) > 0 then 643 | AddStr (s, aUserName); 644 | if length (aPassword) > 0 then 645 | AddStr (s, aPassword); 646 | // finish fixed header 647 | AddLength (FTxStream, 12 + s.Size); 648 | // variable header 649 | AddStr (FTxStream, MQTT_PROTOCOL); // 00 06 MQIsdp (8) 650 | AddByte (FTxStream, MQTT_VERSION); // 3 (1) 651 | x := 0; 652 | if length (aUserName) > 0 then 653 | x := x or $80; 654 | if length (aPassword) > 0 then 655 | x := x or $40; 656 | if FWillFlag then 657 | begin 658 | x := x or $04; 659 | if WillRetain then 660 | x := x or $10; 661 | x := x or (ord (WillQos) shl 3); 662 | end; 663 | if Clean then 664 | x := x or $02; 665 | AddByte (FTxStream, x); // (1) 666 | AddByte (FTxStream, aKeepAlive div $100); // (1) 667 | AddByte (FTxStream, aKeepAlive mod $100); // (1) 668 | // payload 669 | s.Seek (0, soFromBeginning); 670 | FTxStream.CopyFrom (s, s.Size); 671 | s.Free; 672 | if Assigned (FOnSend) then FOnSend (Self, 0, 0, FTxStream); 673 | end; 674 | 675 | procedure TMQTTParser.SendBrokerConnect(aClientID, aUsername, 676 | aPassword: UTF8String; aKeepAlive: Word; aClean: Boolean); 677 | var 678 | s : TMemoryStream; 679 | x : byte; 680 | begin 681 | KeepAlive := aKeepAlive; 682 | FTxStream.Clear; // dup, qos, retain not used 683 | AddHdr (FTxStream, mtBROKERCONNECT, false, qtAT_LEAST_ONCE, false); 684 | s := TMemoryStream.Create; 685 | // generate payload 686 | AddStr (s, aClientID); 687 | if FWillFlag then 688 | begin 689 | AddStr (s, WillTopic); 690 | AddStr (s, WillMessage); 691 | end; 692 | if length (aUserName) > 0 then 693 | AddStr (s, aUserName); 694 | if length (aPassword) > 0 then 695 | AddStr (s, aPassword); 696 | // finish fixed header 697 | AddLength (FTxStream, 12 + s.Size); 698 | // variable header 699 | AddStr (FTxStream, MQTT_PROTOCOL); // 00 06 MQIsdp (8) 700 | AddByte (FTxStream, MQTT_VERSION); // 3 (1) 701 | x := 0; 702 | if length (aUserName) > 0 then 703 | x := x or $80; 704 | if length (aPassword) > 0 then 705 | x := x or $40; 706 | if FWillFlag then 707 | begin 708 | x := x or $04; 709 | if WillRetain then 710 | x := x or $10; 711 | x := x or (ord (WillQos) shl 3); 712 | end; 713 | if Clean then 714 | x := x or $02; 715 | AddByte (FTxStream, x); // (1) 716 | AddByte (FTxStream, aKeepAlive div $100); // (1) 717 | AddByte (FTxStream, aKeepAlive mod $100); // (1) 718 | // payload 719 | s.Seek (0, soFromBeginning); 720 | FTxStream.CopyFrom (s, s.Size); 721 | s.Free; 722 | if Assigned (FOnSend) then FOnSend (Self, 0, 0, FTxStream); 723 | end; 724 | 725 | procedure TMQTTParser.SendConnAck (aCode: byte); 726 | begin 727 | FTxStream.Clear; // dup, qos, retain not used 728 | AddHdr (FTxStream, mtCONNACK, false, qtAT_MOST_ONCE, false); 729 | AddLength (FTxStream, 2); 730 | AddByte (FTxStream, 0); // reserved (1) 731 | AddByte (FTxStream, aCode); // (1) 732 | if Assigned (FOnSend) then FOnSend (Self, 0, 0, FTxStream); 733 | end; 734 | 735 | procedure TMQTTParser.SendPublish (anID : Word; aTopic : UTF8String; aMessage : AnsiString; aQos : TMQTTQOSType; aDup : boolean = false; aRetain : boolean = false); 736 | var 737 | s : TMemoryStream; 738 | begin 739 | FTxStream.Clear; // dup qos and retain used 740 | AddHdr (FTxStream, mtPUBLISH, aDup, aQos, aRetain); 741 | s := TMemoryStream.Create; 742 | AddStr (s, aTopic); 743 | if aQos in [qtAT_LEAST_ONCE, qtEXACTLY_ONCE] then 744 | begin 745 | AddByte (s, anID div $100); 746 | AddByte (s, anID mod $100); 747 | end; 748 | if length (aMessage) > 0 then s.Write (aMessage[1], length (aMessage)); 749 | // payload 750 | s.Seek (0, soFromBeginning); 751 | AddLength (FTxStream, s.Size); 752 | FTxStream.CopyFrom (s, s.Size); 753 | s.Free; 754 | if Assigned (FOnSend) then FOnSend (Self, anID, 0, FTxStream); 755 | end; 756 | 757 | procedure TMQTTParser.SendPubAck (anID: Word); 758 | begin 759 | FTxStream.Clear; // dup, qos, retain not used 760 | AddHdr (FTxStream, mtPUBACK, false, qtAT_MOST_ONCE, false); 761 | AddLength (FTxStream, 2); 762 | AddByte (FTxStream, anID div $100); 763 | AddByte (FTxStream, anID mod $100); 764 | if Assigned (FOnSend) then FOnSend (Self, anID, 0, FTxStream); 765 | end; 766 | 767 | procedure TMQTTParser.SendPubRec (anID: Word); 768 | begin 769 | FTxStream.Clear; // dup, qos, retain are used 770 | AddHdr (FTxStream, mtPUBREC, false, qtAT_MOST_ONCE, false); 771 | AddLength (FTxStream, 2); 772 | AddByte (FTxStream, anID div $100); 773 | AddByte (FTxStream, anID mod $100); 774 | if Assigned (FOnSend) then FOnSend (Self, anID, 0, FTxStream); 775 | end; 776 | 777 | procedure TMQTTParser.SendPubRel (anID: Word; aDup : Boolean = false); 778 | begin 779 | FTxStream.Clear; 780 | AddHdr (FTxStream, mtPUBREL, aDup, qtAT_LEAST_ONCE, false); 781 | AddLength (FTxStream, 2); 782 | AddByte (FTxStream, anID div $100); 783 | AddByte (FTxStream, anID mod $100); 784 | if Assigned (FOnSend) then FOnSend (Self, anID, 0, FTxStream); 785 | end; 786 | 787 | procedure TMQTTParser.SendPubComp (anID: Word); 788 | begin 789 | FTxStream.Clear; // dup, qos, retain not used 790 | AddHdr (FTxStream, mtPUBCOMP, false, qtAT_MOST_ONCE, false); 791 | AddLength (FTxStream, 2); 792 | AddByte (FTxStream, anID div $100); 793 | AddByte (FTxStream, anID mod $100); 794 | if Assigned (FOnSend) then FOnSend (Self, anID, 0, FTxStream); 795 | end; 796 | 797 | procedure TMQTTParser.SendSubscribe (anID : Word; aTopic : UTF8String; aQOS : TMQTTQOSType); 798 | begin 799 | FTxStream.Clear; // qos and dup used 800 | AddHdr (FTxStream, mtSUBSCRIBE, false, qtAT_LEAST_ONCE, false); 801 | AddLength (FTxStream, 5 + length (aTopic)); 802 | AddByte (FTxStream, anID div $100); 803 | AddByte (FTxStream, anID mod $100); 804 | AddStr (FTxStream, aTopic); 805 | AddByte (FTxStream, ord (aQos)); 806 | if Assigned (FOnSend) then FOnSend (Self, anID, 0, FTxStream); 807 | end; 808 | 809 | procedure TMQTTParser.SendSubscribe (anID: Word; Topics: TStringList); 810 | var 811 | i : integer; 812 | s : TMemoryStream; 813 | begin 814 | FTxStream.Clear; // dup qos and retain used 815 | AddHdr (FTxStream, mtSUBSCRIBE, false, qtAT_LEAST_ONCE, false); 816 | s := TMemoryStream.Create; 817 | AddByte (s, anID div $100); 818 | AddByte (s, anID mod $100); 819 | for i := 0 to Topics.Count - 1 do 820 | begin 821 | AddStr (s, UTF8String (Topics[i])); 822 | AddByte (s, byte (Topics.Objects[i]) and $03); 823 | end; 824 | // payload 825 | s.Seek (0, soFromBeginning); 826 | AddLength (FTxStream, s.Size); 827 | FTxStream.CopyFrom (s, s.Size); 828 | s.Free; 829 | if Assigned (FOnSend) then FOnSend (Self, anID, 0, FTxStream); 830 | end; 831 | 832 | procedure TMQTTParser.SendUnsubscribe (anID: Word; Topics: TStringList); 833 | var 834 | i : integer; 835 | s : TMemoryStream; 836 | begin 837 | FTxStream.Clear; // qos and dup used 838 | AddHdr (FTxStream, mtUNSUBSCRIBE, false, qtAT_LEAST_ONCE, false); 839 | s := TMemoryStream.Create; 840 | AddByte (s, anID div $100); 841 | AddByte (s, anID mod $100); 842 | for i := 0 to Topics.Count - 1 do 843 | AddStr (s, UTF8String (Topics[i])); 844 | // payload 845 | s.Seek (0, soFromBeginning); 846 | AddLength (FTxStream, s.Size); 847 | FTxStream.CopyFrom (s, s.Size); 848 | s.Free; 849 | if Assigned (FOnSend) then FOnSend (Self, anID, 0, FTxStream); 850 | end; 851 | 852 | 853 | procedure TMQTTParser.SendSubAck (anID: Word; Qoss : array of TMQTTQOSType); 854 | var 855 | i : integer; 856 | begin 857 | FTxStream.Clear; // dup, qos, retain not used 858 | AddHdr (FTxStream, mtSUBACK, false, qtAT_MOST_ONCE, false); 859 | AddLength (FTxStream, 2 + length (Qoss)); 860 | AddByte (FTxStream, anID div $100); 861 | AddByte (FTxStream, anID mod $100); 862 | for i := low (Qoss) to high (Qoss) do 863 | AddByte (FTxStream, ord (Qoss[i])); 864 | if Assigned (FOnSend) then FOnSend (Self, anID, 0, FTxStream); 865 | end; 866 | 867 | procedure TMQTTParser.SendUnsubscribe (anID: Word; aTopic: UTF8String); 868 | begin 869 | FTxStream.Clear; // qos and dup used 870 | AddHdr (FTxStream, mtUNSUBSCRIBE, false, qtAT_LEAST_ONCE, false); 871 | AddLength (FTxStream, 4 + length (aTopic)); 872 | AddByte (FTxStream, anID div $100); 873 | AddByte (FTxStream, anID mod $100); 874 | AddStr (FTxStream, aTopic); 875 | if Assigned (FOnSend) then FOnSend (Self, anID, 0, FTxStream); 876 | end; 877 | 878 | procedure TMQTTParser.SendUnsubAck (anID: Word); 879 | begin 880 | FTxStream.Clear; // dup, qos, retain not used 881 | AddHdr (FTxStream, mtUNSUBACK, false, qtAT_MOST_ONCE, false); 882 | AddLength (FTxStream, 2); 883 | AddByte (FTxStream, anID div $100); 884 | AddByte (FTxStream, anID mod $100); 885 | if Assigned (FOnSend) then FOnSend (Self, anID, 0, FTxStream); 886 | end; 887 | 888 | procedure TMQTTParser.SendPing; 889 | begin 890 | FTxStream.Clear; // dup, qos, retain not used 891 | AddHdr (FTxStream, mtPINGREQ, false, qtAT_MOST_ONCE, false); 892 | AddLength (FTxStream, 0); 893 | if Assigned (FOnSend) then FOnSend (Self, 0, 0, FTxStream); 894 | end; 895 | 896 | procedure TMQTTParser.SendPingResp; 897 | begin 898 | FTxStream.Clear; // dup, qos, retain not used 899 | AddHdr (FTxStream, mtPINGRESP, false, qtAT_MOST_ONCE, false); 900 | AddLength (FTxStream, 0); 901 | if Assigned (FOnSend) then FOnSend (Self, 0, 0, FTxStream); 902 | end; 903 | 904 | procedure TMQTTParser.SendDisconnect; 905 | begin 906 | FTxStream.Clear; 907 | AddHdr (FTxStream, mtDISCONNECT, false, qtAT_MOST_ONCE, false); 908 | AddLength (FTxStream, 0); 909 | if Assigned (FOnSend) then FOnSend (Self, 0, 0, FTxStream); 910 | end; 911 | 912 | procedure TMQTTParser.SetKeepAlive (const Value: Word); 913 | begin 914 | FKeepAlive := Value; 915 | FKeepAliveCount := Value * 10; 916 | end; 917 | 918 | procedure TMQTTParser.SetWill (aTopic, aMessage : UTF8String; aQos : TMQTTQOSType; aRetain : boolean); 919 | begin 920 | WillTopic := aTopic; 921 | WillMessage := aMessage; 922 | WillRetain := aRetain; 923 | WillQos := aQos; 924 | FWillFlag := (length (aTopic) > 0) and (length (aMessage) > 0); 925 | end; 926 | 927 | end. 928 | -------------------------------------------------------------------------------- /src/uMQTTComps.pas: -------------------------------------------------------------------------------- 1 | unit uMQTTComps; 2 | 3 | interface 4 | uses 5 | Classes, uMQTT, OverbyteIcsWndControl, OverbyteIcsWSocket, OverbyteIcsWSocketS, Windows, Messages; 6 | 7 | 8 | (* Todo 9 | Finish Retain 10 | *) 11 | (* Web Sites 12 | http://www.alphaworks.ibm.com/tech/rsmb 13 | http://www.mqtt.org 14 | 15 | Permission to copy and display the MQ Telemetry Transport specification (the 16 | "Specification"), in any medium without fee or royalty is hereby granted by Eurotech 17 | and International Business Machines Corporation (IBM) (collectively, the "Authors"), 18 | provided that you include the following on ALL copies of the Specification, or portions 19 | thereof, that you make: 20 | A link or URL to the Specification at one of 21 | 1. the Authors' websites. 22 | 2. The copyright notice as shown in the Specification. 23 | 24 | The Authors each agree to grant you a royalty-free license, under reasonable, 25 | non-discriminatory terms and conditions to their respective patents that they deem 26 | necessary to implement the Specification. THE SPECIFICATION IS PROVIDED "AS IS," 27 | AND THE AUTHORS MAKE NO REPRESENTATIONS OR WARRANTIES, EXPRESS OR 28 | IMPLIED, INCLUDING, BUT NOT LIMITED TO, WARRANTIES OF MERCHANTABILITY, 29 | FITNESS FOR A PARTICULAR PURPOSE, NON-INFRINGEMENT, OR TITLE; THAT THE 30 | CONTENTS OF THE SPECIFICATION ARE SUITABLE FOR ANY PURPOSE; NOR THAT THE 31 | IMPLEMENTATION OF SUCH CONTENTS WILL NOT INFRINGE ANY THIRD PARTY 32 | PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER RIGHTS. THE AUTHORS WILL NOT 33 | BE LIABLE FOR ANY DIRECT, INDIRECT, SPECIAL, INCIDENTAL OR CONSEQUENTIAL 34 | DAMAGES ARISING OUT OF OR RELATING TO ANY USE OR DISTRIBUTION OF THE 35 | SPECIFICATION *) 36 | 37 | const 38 | MinVersion = 3; 39 | 40 | type 41 | TClient = class; 42 | TMQTTClient = class; 43 | TMQTTPacketStore = class; 44 | TMQTTMessageStore = class; 45 | 46 | TMQTTPacket = class 47 | ID : Word; 48 | Stamp : TDateTime; 49 | Counter : cardinal; 50 | Retries : integer; 51 | Publishing : Boolean; 52 | Msg : TMemoryStream; 53 | procedure Assign (From : TMQTTPacket); 54 | constructor Create; 55 | destructor Destroy; override; 56 | end; 57 | 58 | TMQTTMessage = class 59 | ID : Word; 60 | Stamp : TDateTime; 61 | LastUsed : TDateTime; 62 | Qos : TMQTTQOSType; 63 | Retained : boolean; 64 | Counter : cardinal; 65 | Retries : integer; 66 | Topic : UTF8String; 67 | Message : AnsiString; 68 | procedure Assign (From : TMQTTMessage); 69 | constructor Create; 70 | destructor Destroy; override; 71 | end; 72 | 73 | TMQTTSession = class 74 | ClientID : UTF8String; 75 | Stamp : TDateTime; 76 | InFlight : TMQTTPacketStore; 77 | Releasables : TMQTTMessageStore; 78 | constructor Create; 79 | destructor Destroy; override; 80 | end; 81 | 82 | TMQTTSessionStore = class 83 | List : TList; 84 | Stamp : TDateTime; 85 | function GetItem (Index: Integer): TMQTTSession; 86 | procedure SetItem (Index: Integer; const Value: TMQTTSession); 87 | property Items [Index: Integer]: TMQTTSession read GetItem write SetItem; default; 88 | function Count : integer; 89 | procedure Clear; 90 | function GetSession (ClientID : UTF8String) : TMQTTSession; 91 | procedure StoreSession (ClientID : UTF8String; aClient : TClient); overload; 92 | procedure StoreSession (ClientID : UTF8String; aClient : TMQTTClient); overload; 93 | procedure DeleteSession (ClientID : UTF8String); 94 | procedure RestoreSession (ClientID : UTF8String; aClient : TClient); overload; 95 | procedure RestoreSession (ClientID : UTF8String; aClient : TMQTTClient); overload; 96 | constructor Create; 97 | destructor Destroy; override; 98 | end; 99 | 100 | TMQTTPacketStore = class 101 | List : TList; 102 | Stamp : TDateTime; 103 | function GetItem (Index: Integer): TMQTTPacket; 104 | procedure SetItem (Index: Integer; const Value: TMQTTPacket); 105 | property Items [Index: Integer]: TMQTTPacket read GetItem write SetItem; default; 106 | function Count : integer; 107 | procedure Clear; 108 | procedure Assign (From : TMQTTPacketStore); 109 | function AddPacket (anID : Word; aMsg : TMemoryStream; aRetry : cardinal; aCount : cardinal) : TMQTTPacket; 110 | procedure DelPacket (anID : Word); 111 | function GetPacket (anID : Word) : TMQTTPacket; 112 | procedure Remove (aPacket : TMQTTPacket); 113 | constructor Create; 114 | destructor Destroy; override; 115 | end; 116 | 117 | TMQTTMessageStore = class 118 | List : TList; 119 | Stamp : TDateTime; 120 | function GetItem (Index: Integer): TMQTTMessage; 121 | procedure SetItem (Index: Integer; const Value: TMQTTMessage); 122 | property Items [Index: Integer]: TMQTTMessage read GetItem write SetItem; default; 123 | function Count : integer; 124 | procedure Clear; 125 | procedure Assign (From : TMQTTMessageStore); 126 | function AddMsg (anID : Word; aTopic : UTF8String; aMessage : AnsiString; aQos : TMQTTQOSType; aRetry : cardinal; aCount : cardinal; aRetained : Boolean = false) : TMQTTMessage; 127 | procedure DelMsg (anID : Word); 128 | function GetMsg (anID : Word) : TMQTTMessage; 129 | procedure Remove (aMsg : TMQTTMessage); 130 | constructor Create; 131 | destructor Destroy; override; 132 | end; 133 | 134 | TClient = class (TWSocketClient) 135 | private 136 | FOnMon : TMQTTMonEvent; 137 | FGraceful : boolean; 138 | FBroker : Boolean; // non standard 139 | FOnSubscriptionChange: TNotifyEvent; 140 | procedure DoSend (Sender : TObject; anID : Word; aRetry : integer; aStream : TMemoryStream); 141 | procedure RxSubscribe (Sender : TObject; anID : Word; Topics : TStringList); 142 | procedure RxUnsubscribe (Sender : TObject; anID : Word; Topics : TStringList); 143 | procedure RxPubAck (Sender : TObject; anID : Word); 144 | procedure RxPubRec (Sender : TObject; anID : Word); 145 | procedure RxPubRel (Sender : TObject; anID : Word); 146 | procedure RxPubComp (Sender : TObject; anID : Word); 147 | public 148 | Subscriptions : TStringList; 149 | Parser : TMQTTParser; 150 | InFlight : TMQTTPacketStore; 151 | Releasables : TMQTTMessageStore; 152 | procedure Mon (aStr : string); 153 | procedure DoData (Sender : TObject; ErrCode : Word); 154 | procedure DoSetWill (Sender : TObject; aTopic, aMessage : UTF8String; aQOS : TMQTTQOSType; aRetain : boolean); 155 | constructor Create (anOwner : TComponent); override; 156 | destructor Destroy; override; 157 | property OnSubscriptionChange : TNotifyEvent read FOnSubscriptionChange write FOnSubscriptionChange; 158 | property OnMon : TMQTTMonEvent read FOnMon write FOnMon; 159 | end; 160 | 161 | TMQTTClient = class (TComponent) 162 | private 163 | Timers : HWnd; 164 | FUsername, FPassword : UTF8String; 165 | FMessageID : Word; 166 | FHost : string; 167 | FPort : integer; 168 | FEnable, FOnline : Boolean; 169 | FGraceful : Boolean; 170 | FOnMon : TMQTTMonEvent; 171 | FOnOnline: TNotifyEvent; 172 | FOnOffline: TMQTTDisconnectEvent; 173 | FOnEnableChange: TNotifyEvent; 174 | FOnMsg: TMQTTMsgEvent; 175 | FOnFailure: TMQTTFailureEvent; 176 | FLocalBounce: Boolean; 177 | FAutoSubscribe: Boolean; 178 | FOnClientID : TMQTTClientIDEvent; 179 | FBroker: Boolean; // non standard 180 | procedure DoSend (Sender : TObject; anID : Word; aRetry : integer; aStream : TMemoryStream); 181 | procedure RxConnAck (Sender : TObject; aCode : byte); 182 | procedure RxSubAck (Sender : TObject; anID : Word; Qoss : array of TMQTTQosType); 183 | procedure RxPubAck (Sender : TObject; anID : Word); 184 | procedure RxPubRec (Sender : TObject; anID : Word); 185 | procedure RxPubRel (Sender : TObject; anID : Word); 186 | procedure RxPubComp (Sender : TObject; anID : Word); 187 | procedure RxPublish (Sender : TObject; anID : Word; aTopic : UTF8String; aMessage : AnsiString); 188 | procedure RxUnsubAck (Sender : TObject; anID : Word); 189 | procedure LinkConnected (Sender: TObject; ErrCode: Word); 190 | procedure LinkClosed (Sender: TObject; ErrCode: Word); 191 | procedure LinkData (Sender: TObject; ErrCode: Word); 192 | procedure TimerProc (var aMsg : TMessage); 193 | function GetClientID: UTF8String; 194 | procedure SetClientID (const Value: UTF8String); 195 | function GetKeepAlive: Word; 196 | procedure SetKeepAlive(const Value: Word); 197 | function GetMaxRetries : integer; 198 | procedure SetMaxRetries(const Value: integer); 199 | function GetRetryTime : cardinal; 200 | procedure SetRetryTime (const Value : cardinal); 201 | function GetClean: Boolean; 202 | procedure SetClean(const Value: Boolean); 203 | function GetPassword: UTF8String; 204 | function GetUsername: UTF8String; 205 | procedure SetPassword(const Value: UTF8String); 206 | procedure SetUsername(const Value: UTF8String); 207 | public 208 | Link : TWSocket; 209 | Parser : TMQTTParser; 210 | InFlight : TMQTTPacketStore; 211 | Releasables : TMQTTMessageStore; 212 | Subscriptions : TStringList; 213 | function Enabled : boolean; 214 | function Online : boolean; 215 | function NextMessageID : Word; 216 | procedure Subscribe (aTopic : UTF8String; aQos : TMQTTQOSType); overload; 217 | procedure Subscribe (Topics : TStringList); overload; 218 | procedure Unsubscribe (aTopic : UTF8String); overload; 219 | procedure Unsubscribe (Topics : TStringList); overload; 220 | procedure Ping; 221 | procedure Publish (aTopic : UTF8String; aMessage : AnsiString; aQos : TMQTTQOSType; aRetain : Boolean = false); 222 | procedure SetWill (aTopic, aMessage : UTF8String; aQos : TMQTTQOSType; aRetain : Boolean = false); 223 | procedure Mon (aStr : string); 224 | procedure Activate (Enable : Boolean); 225 | constructor Create (anOwner : TComponent); override; 226 | destructor Destroy; override; 227 | published 228 | property ClientID : UTF8String read GetClientID write SetClientID; 229 | property KeepAlive : Word read GetKeepAlive write SetKeepAlive; 230 | property MaxRetries : integer read GetMaxRetries write SetMaxRetries; 231 | property RetryTime : cardinal read GetRetryTime write SetRetryTime; 232 | property Clean : Boolean read GetClean write SetClean; 233 | property Broker : Boolean read FBroker write FBroker; // no standard 234 | property AutoSubscribe : Boolean read FAutoSubscribe write FAutoSubscribe; 235 | property Username : UTF8String read GetUsername write SetUsername; 236 | property Password : UTF8String read GetPassword write SetPassword; 237 | property Host : string read FHost write FHost; 238 | property Port : integer read FPort write FPort; 239 | property LocalBounce : Boolean read FLocalBounce write FLocalBounce; 240 | property OnClientID : TMQTTClientIDEvent read FOnClientID write FOnClientID; 241 | property OnMon : TMQTTMonEvent read FOnMon write FOnMon; 242 | property OnOnline : TNotifyEvent read FOnOnline write FOnOnline; 243 | property OnOffline : TMQTTDisconnectEvent read FOnOffline write FOnOffline; 244 | property OnEnableChange : TNotifyEvent read FOnEnableChange write FOnEnableChange; 245 | property OnFailure : TMQTTFailureEvent read FOnFailure write FOnFailure; 246 | property OnMsg : TMQTTMsgEvent read FOnMsg write FOnMsg; 247 | end; 248 | 249 | TMQTTServer = class (TComponent) 250 | private 251 | FOnMon : TMQTTMonEvent; 252 | FOnClientsChange: TMQTTIDEvent; 253 | FOnCheckUser: TMQTTCheckUserEvent; 254 | Timers : HWnd; 255 | FPort : integer; 256 | FEnable : boolean; 257 | FOnBrokerOffline: TMQTTDisconnectEvent; 258 | FOnBrokerOnline: TNotifyEvent; 259 | FOnBrokerEnableChange: TNotifyEvent; 260 | FOnObituary: TMQTTObituaryEvent; 261 | FOnEnableChange: TNotifyEvent; 262 | FLocalBounce: Boolean; 263 | FOnSubscription: TMQTTSubscriptionEvent; 264 | FOnFailure: TMQTTFailureEvent; 265 | FMaxRetries: integer; 266 | FRetryTime: cardinal; 267 | FOnStoreSession: TMQTTSessionEvent; 268 | FOnRestoreSession: TMQTTSessionEvent; 269 | FOnDeleteSession: TMQTTSessionEvent; 270 | // FOnRetain: TMQTTRetainEvent; 271 | // FOnGetRetained: TMQTTRetainedEvent; 272 | procedure TimerProc (var aMsg : TMessage); 273 | procedure DoMon (Sender: TObject; aStr : string); 274 | // broker events 275 | procedure BkrOnline (Sender : TObject); 276 | procedure BkrOffline (Sender : TObject; Graceful : boolean); 277 | procedure BkrEnableChanged (Sender : TObject); 278 | procedure BkrSubscriptionChange (Sender : TObject); 279 | procedure BkrMsg (Sender : TObject; aTopic : UTF8String; aMessage : AnsiString; aQos : TMQTTQOSType; aRetained : boolean); 280 | // socket events 281 | procedure DoClientConnect (Sender: TObject; Client: TWSocketClient; Error: Word); 282 | procedure DoClientDisconnect (Sender: TObject; Client: TWSocketClient; Error: Word); 283 | procedure DoClientCreate (Sender: TObject; Client: TWSocketClient); 284 | // parser events 285 | procedure RxDisconnect (Sender : TObject); 286 | procedure RxPing (Sender : TObject); 287 | procedure RxPublish (Sender : TObject; anID : Word; aTopic : UTF8String; aMessage : AnsiString); 288 | procedure RxHeader (Sender : TObject; MsgType: TMQTTMessageType; Dup: Boolean; 289 | Qos: TMQTTQOSType; Retain: Boolean); 290 | procedure RxConnect (Sender : TObject; 291 | aProtocol : UTF8String; 292 | aVersion : byte; 293 | aClientID, 294 | aUserName, aPassword : UTF8String; 295 | aKeepAlive : Word; aClean : Boolean); 296 | procedure RxBrokerConnect (Sender : TObject; // non standard 297 | aProtocol : UTF8String; 298 | aVersion : byte; 299 | aClientID, 300 | aUserName, aPassword : UTF8String; 301 | aKeepAlive : Word; aClean : Boolean); 302 | procedure SetMaxRetries (const Value: integer); 303 | procedure SetRetryTime (const Value: cardinal); 304 | public 305 | FOnMonHdr : TMQTTHeaderEvent; 306 | Server : TWSocketServer; 307 | MessageID : Word; 308 | Brokers : TList; // of wsocket 309 | Sessions : TMQTTSessionStore; 310 | Retained : TMQTTMessageStore; 311 | function NextMessageID : Word; 312 | procedure Mon (aStr : string); 313 | procedure Activate (Enable : boolean); 314 | procedure LoadBrokers (anIniFile : string); 315 | procedure StoreBrokers (anIniFile : string); 316 | function GetClient (aParser : TMQTTParser) : TClient; overload; 317 | function GetClient (aClientID : UTF8String) : TClient; overload; 318 | 319 | procedure PublishToAll (From : TObject; aTopic : UTF8String; aMessage : AnsiString; aQos : TMQTTQOSType; wasRetained : boolean = false); 320 | function Enabled : boolean; 321 | function AddBroker (aHost : string; aPort : integer) : TMQTTClient; 322 | procedure SyncBrokerSubscriptions (aBroker : TMQTTClient); 323 | constructor Create (anOwner : TComponent); override; 324 | destructor Destroy; override; 325 | published 326 | property MaxRetries : integer read FMaxRetries write SetMaxRetries; 327 | property RetryTime : cardinal read FRetryTime write SetRetryTime; // in secs 328 | property Port : integer read FPort write FPort; 329 | property LocalBounce : Boolean read FLocalBounce write FLocalBounce; 330 | property OnFailure : TMQTTFailureEvent read FOnFailure write FOnFailure; 331 | property OnStoreSession : TMQTTSessionEvent read FOnStoreSession write FOnStoreSession; 332 | property OnRestoreSession : TMQTTSessionEvent read FOnRestoreSession write FOnRestoreSession; 333 | property OnDeleteSession : TMQTTSessionEvent read FOnDeleteSession write FOnDeleteSession; 334 | // property OnRetain : TMQTTRetainEvent read FOnRetain write FOnRetain; 335 | // property OnGetRetained : TMQTTRetainedEvent read FOnGetRetained write FOnGetRetained; 336 | property OnBrokerOnline : TNotifyEvent read FOnBrokerOnline write FOnBrokerOnline; 337 | property OnBrokerOffline : TMQTTDisconnectEvent read FOnBrokerOffline write FOnBrokerOffline; 338 | property OnBrokerEnableChange : TNotifyEvent read FOnBrokerEnableChange write FOnBrokerEnableChange; 339 | property OnEnableChange : TNotifyEvent read FOnEnableChange write FOnEnableChange; 340 | property OnSubscription : TMQTTSubscriptionEvent read FOnSubscription write FOnSubscription; 341 | property OnClientsChange : TMQTTIDEvent read FOnClientsChange write FOnClientsChange; 342 | property OnCheckUser : TMQTTCheckUserEvent read FOnCheckUser write FOnCheckUser; 343 | property OnObituary : TMQTTObituaryEvent read FOnObituary write FOnObituary; 344 | property OnMon : TMQTTMonEvent read FOnMon write FOnMon; 345 | end; 346 | 347 | procedure Register; 348 | function SubTopics (aTopic : UTF8String) : TStringList; 349 | function IsSubscribed (aSubscription, aTopic : UTF8String) : boolean; 350 | 351 | implementation 352 | 353 | uses 354 | SysUtils, IniFiles; 355 | 356 | procedure Register; 357 | begin 358 | RegisterComponents ('MQTT', [TMQTTServer, TMQTTClient]); 359 | end; 360 | 361 | 362 | function StateStr (aState: TSocketState): string; 363 | begin 364 | case aState of 365 | wsInvalidState : result := 'Invalid State'; 366 | wsOpened : result := 'Opened'; 367 | wsBound : result := 'Bound'; 368 | wsConnecting : Result := 'Connecting'; 369 | wsSocksConnected : Result := 'Sock Connected'; 370 | wsConnected : result := 'Connected'; 371 | wsAccepting : result := 'Accepting'; 372 | wsListening : result := 'Listening'; 373 | wsClosed : result := 'Closed'; 374 | end; 375 | end; 376 | 377 | function SubTopics (aTopic : UTF8String) : TStringList; 378 | var 379 | i : integer; 380 | begin 381 | Result := TStringList.Create; 382 | Result.Add (''); 383 | for i := 1 to length (aTopic) do 384 | begin 385 | if aTopic[i] = '/' then 386 | Result.Add('') 387 | else 388 | Result[Result.Count - 1] := Result[Result.Count - 1] + Char (aTopic[i]); 389 | end; 390 | end; 391 | 392 | function IsSubscribed (aSubscription, aTopic : UTF8String) : boolean; 393 | var 394 | s, t : TStringList; 395 | i : integer; 396 | MultiLevel : Boolean; 397 | begin 398 | s := SubTopics (aSubscription); 399 | t := SubTopics (aTopic); 400 | MultiLevel := (s[s.Count - 1] = '#'); // last field is # 401 | if not MultiLevel then 402 | Result := (s.Count = t.Count) 403 | else 404 | Result := (s.Count <= t.Count + 1); 405 | if Result then 406 | begin 407 | for i := 0 to s.Count - 1 do 408 | begin 409 | if (i >= t.Count) then Result := MultiLevel 410 | else if (i = s.Count - 1) and (s[i] = '#') then break 411 | else if s[i] = '+' then continue // they match 412 | else 413 | Result := Result and (s[i] = t[i]); 414 | if not Result then break; 415 | end; 416 | end; 417 | s.Free; 418 | t.Free; 419 | end; 420 | 421 | procedure SetDup (aStream : TMemoryStream; aState : boolean); 422 | var 423 | x : byte; 424 | begin 425 | if aStream.Size = 0 then exit; 426 | aStream.Seek (0, soFromBeginning); 427 | aStream.Read (x, 1); 428 | x := (x and $F7) or (ord (aState) * $08); 429 | aStream.Seek (0, soFromBeginning); 430 | aStream.Write (x, 1); 431 | end; 432 | 433 | { TClient } 434 | 435 | constructor TClient.Create (anOwner: TComponent); 436 | begin 437 | inherited; 438 | FBroker := false; // non standard 439 | Parser := TMQTTParser.Create; 440 | Parser.OnSend := DoSend; 441 | Parser.OnSetWill := DoSetWill; 442 | Parser.OnSubscribe := RxSubscribe; 443 | Parser.OnUnsubscribe := RxUnsubscribe; 444 | Parser.OnPubAck := RxPubAck; 445 | Parser.OnPubRel := RxPubRel; 446 | Parser.OnPubRec := RxPubRec; 447 | Parser.OnPubComp := RxPubComp; 448 | InFlight := TMQTTPacketStore.Create; 449 | Releasables := TMQTTMessageStore.Create; 450 | Subscriptions := TStringList.Create; 451 | OnDataAvailable := DoData; 452 | end; 453 | 454 | destructor TClient.Destroy; 455 | begin 456 | InFlight.Clear; 457 | InFlight.Free; 458 | Releasables.Clear; 459 | Releasables.Free; 460 | Parser.Free; 461 | Subscriptions.Free; 462 | inherited; 463 | end; 464 | 465 | procedure TClient.DoData (Sender: TObject; ErrCode: Word); 466 | begin 467 | if ErrCode = 0 then Parser.Parse (ReceiveStrA); 468 | end; 469 | 470 | procedure TClient.DoSend (Sender: TObject; anID : Word; aRetry : integer; aStream: TMemoryStream); 471 | var 472 | x : byte; 473 | begin 474 | if State = wsConnected then 475 | begin 476 | aStream.Seek (0, soFromBeginning); 477 | aStream.Read (x, 1); 478 | if (TMQTTQOSType ((x and $06) shr 1) in [qtAT_LEAST_ONCE, qtEXACTLY_ONCE]) and 479 | (TMQTTMessageType ((x and $f0) shr 4) in [{mtPUBREL,} mtPUBLISH, mtSUBSCRIBE, mtUNSUBSCRIBE]) and 480 | (anID > 0) then 481 | begin 482 | InFlight.AddPacket (anID, aStream, aRetry, Parser.RetryTime); // start disabled 483 | mon (string (Parser.ClientID) + ' Message ' + IntToStr (anID) + ' created.'); 484 | end; 485 | Send (aStream.Memory, aStream.Size); 486 | Sleep (0); 487 | end; 488 | end; 489 | 490 | procedure TClient.DoSetWill (Sender: TObject; aTopic, aMessage: UTF8String; 491 | aQos : TMQTTQOSType; aRetain: boolean); 492 | begin 493 | Parser.WillTopic := aTopic; 494 | Parser.WillMessage := aMessage; 495 | Parser.WillQos := aQos; 496 | Parser.WillRetain := aRetain; 497 | end; 498 | 499 | procedure TClient.Mon (aStr: string); 500 | begin 501 | if Assigned (FOnMon) then FOnMon (Self, aStr); 502 | end; 503 | 504 | procedure TClient.RxPubAck (Sender: TObject; anID: Word); 505 | begin 506 | InFlight.DelPacket (anID); 507 | Mon (string (Parser.ClientID) + ' ACK Message ' + IntToStr (anID) + ' disposed of.'); 508 | end; 509 | 510 | procedure TClient.RxPubComp (Sender: TObject; anID: Word); 511 | begin 512 | InFlight.DelPacket (anID); 513 | Mon (string (Parser.ClientID) + ' COMP Message ' + IntToStr (anID) + ' disposed of.'); 514 | end; 515 | 516 | procedure TClient.RxPubRec (Sender: TObject; anID: Word); 517 | var 518 | aPacket : TMQTTPacket; 519 | begin 520 | aPacket := InFlight.GetPacket (anID); 521 | if aPacket <> nil then 522 | begin 523 | aPacket.Counter := Parser.RetryTime; 524 | if aPacket.Publishing then 525 | begin 526 | aPacket.Publishing := false; 527 | Mon (string (Parser.ClientID) + ' REC Message ' + IntToStr (anID) + ' recorded.'); 528 | end 529 | else 530 | Mon (string (Parser.ClientID) + ' REC Message ' + IntToStr (anID) + ' already recorded.'); 531 | end 532 | else 533 | Mon (string (Parser.ClientID) + ' REC Message ' + IntToStr (anID) + ' not found.'); 534 | Parser.SendPubRel (anID); 535 | end; 536 | 537 | procedure TClient.RxPubRel (Sender: TObject; anID: Word); 538 | var 539 | aMsg : TMQTTMessage; 540 | begin 541 | aMsg := Releasables.GetMsg (anID); 542 | if (aMsg <> nil) and (Owner.Owner is TMQTTServer) then 543 | begin 544 | Mon (string (Parser.ClientID) + ' REL Message ' + IntToStr (anID) + ' publishing @ ' + QOSNames[aMsg.Qos]); 545 | TMQTTServer (Owner.Owner).PublishToAll (Self, aMsg.Topic, aMsg.Message, aMsg.Qos); 546 | Releasables.Remove (aMsg); 547 | aMsg.Free; 548 | Mon (string (Parser.ClientID) + ' REL Message ' + IntToStr (anID) + ' removed from storage.'); 549 | end 550 | else 551 | Mon (string (Parser.ClientID) + ' REL Message ' + IntToStr (anID) + ' has been already removed from storage.'); 552 | Parser.SendPubComp (anID); 553 | end; 554 | 555 | procedure TClient.RxSubscribe (Sender: TObject; anID: Word; Topics: TStringList); 556 | var 557 | x : cardinal; 558 | q : TMQTTQOSType; 559 | i, j : integer; 560 | found : boolean; 561 | Qoss : array of TMQTTQOSType; 562 | aServer : TMQTTServer; 563 | bMsg : TMQTTMessage; 564 | aQos : TMQTTQOSType; 565 | begin 566 | SetLength (Qoss, Topics.Count); 567 | aServer := nil; 568 | if Owner is TWSocketServer then 569 | if Owner.Owner is TMQTTServer then 570 | aServer := TMQTTServer (Owner.Owner); 571 | if aServer = nil then exit; 572 | for i := 0 to Topics.Count - 1 do 573 | begin 574 | found := false; 575 | x := cardinal (Topics.Objects[i]) and $03; 576 | q := TMQTTQOSType (x); 577 | if Assigned (aServer.FOnSubscription) then 578 | aServer.FOnSubscription (Self, UTF8String (Topics[i]), q); 579 | for j := 0 to Subscriptions.Count - 1 do 580 | if Subscriptions[j] = Topics[i] then 581 | begin 582 | found := true; 583 | Subscriptions.Objects[j] := TObject (q); 584 | break; 585 | end; 586 | if not found then 587 | begin 588 | Subscriptions.AddObject (Topics[i], TObject (q)); 589 | end; 590 | Qoss[i] := q; 591 | for j := 0 to aServer.Retained.Count - 1 do // set retained 592 | begin 593 | bMsg := aServer.Retained[j]; 594 | if IsSubscribed (UTF8String (Topics[i]), bMsg.Topic) then 595 | begin 596 | aQos := bMsg.Qos; 597 | if q < aQos then aQos := q; 598 | bMsg.LastUsed := Now; 599 | Parser.SendPublish (aServer.NextMessageID, bMsg.Topic, bMsg.Message, aQos, false, true); 600 | end; 601 | end; 602 | end; 603 | if Parser.RxQos = qtAT_LEAST_ONCE then Parser.SendSubAck (anID, Qoss); 604 | if Assigned (FOnSubscriptionChange) then FOnSubscriptionChange (Self); 605 | end; 606 | 607 | procedure TClient.RxUnsubscribe (Sender: TObject; anID: Word; Topics: TStringList); 608 | var 609 | i, j : integer; 610 | changed : boolean; 611 | begin 612 | changed := false; 613 | for i := 0 to Topics.Count - 1 do 614 | begin 615 | for j := Subscriptions.Count - 1 downto 0 do 616 | begin 617 | if Subscriptions[j] = Topics[i] then 618 | begin 619 | Subscriptions.Delete (j); 620 | changed := true; 621 | end; 622 | end; 623 | end; 624 | if changed and Assigned (FOnSubscriptionChange) then 625 | FOnSubscriptionChange (Self); 626 | if Parser.RxQos = qtAT_LEAST_ONCE then Parser.SendUnSubAck (anID); 627 | end; 628 | 629 | { TMQTTServer } 630 | 631 | procedure TMQTTServer.Activate (Enable: boolean); 632 | var 633 | i : integer; 634 | begin 635 | if FEnable = Enable then exit; 636 | if (Enable) then 637 | begin 638 | Server.Banner := ''; 639 | Server.Addr := '0.0.0.0'; 640 | Server.Port := IntToStr (FPort); 641 | Server.Proto := 'tcp'; 642 | Server.ClientClass := TClient; 643 | try 644 | Server.Listen; 645 | FEnable := true; 646 | except 647 | FEnable := false; 648 | end; 649 | if FEnable then SetTimer (Timers, 3, 100, nil); 650 | end 651 | else 652 | begin 653 | FEnable := false; 654 | for i := 0 to Server.ClientCount - 1 do 655 | try 656 | TClient (Server.Client[i]).Close; 657 | except 658 | end; 659 | try 660 | Server.Close; 661 | except 662 | end; 663 | KillTimer (Timers, 1); 664 | KillTimer (Timers, 2); 665 | KillTimer (Timers, 3); 666 | end; 667 | if Assigned (FOnEnableChange) then 668 | FOnEnableChange (Self); 669 | end; 670 | 671 | function TMQTTServer.AddBroker (aHost: string; aPort: integer): TMQTTClient; 672 | begin 673 | Result := TMQTTClient.Create (Self); 674 | Result.Host := aHost; 675 | Result.Port := aPort; 676 | Result.Broker := true; 677 | Result.LocalBounce := false; 678 | Result.OnOnline := BkrOnline; 679 | Result.OnOffline := BkrOffline; 680 | Result.OnEnableChange := BkrEnableChanged; 681 | Result.OnMsg := BkrMsg; 682 | Brokers.Add (Result); 683 | end; 684 | 685 | procedure TMQTTServer.BkrEnableChanged (Sender: TObject); 686 | begin 687 | if Assigned (FOnBrokerEnableChange) then 688 | FOnBrokerEnableChange (Sender); 689 | end; 690 | 691 | procedure TMQTTServer.BkrOffline (Sender: TObject; Graceful: boolean); 692 | begin 693 | TMQTTClient (Sender).Subscriptions.Clear; 694 | if Assigned (FOnBrokerOffline) then 695 | FOnBrokerOffline (Sender, Graceful); 696 | end; 697 | 698 | procedure TMQTTServer.BkrOnline(Sender: TObject); 699 | begin 700 | SyncBrokerSubscriptions (TMQTTClient (Sender)); 701 | if Assigned (FOnBrokerOnline) then 702 | FOnBrokerOnline (Sender); 703 | end; 704 | 705 | procedure TMQTTServer.BkrMsg (Sender: TObject; aTopic : UTF8String; aMessage : AnsiString; aQos : TMQTTQOSType; aRetained : boolean); 706 | var 707 | aBroker : TMQTTClient; 708 | i : integer; 709 | aMsg : TMQTTMessage; 710 | begin 711 | aBroker := TMQTTClient (Sender); 712 | mon ('Received Retained Message from a Broker - Retained ' + ny[aRetained]); 713 | if aRetained then 714 | begin 715 | mon ('Retaining "' + string (aTopic) + '" @ ' + QOSNames[aQos]); 716 | for i := Retained.Count - 1 downto 0 do 717 | begin 718 | aMsg := Retained[i]; 719 | if aMsg.Topic = aTopic then 720 | begin 721 | Retained.Remove (aMsg); 722 | aMsg.Free; 723 | break; 724 | end; 725 | end; 726 | Retained.AddMsg (0, aTopic, aMessage, aQos, 0, 0); 727 | end 728 | else 729 | mon ('Received Message from a Broker - Publishing..'); 730 | PublishToAll (Sender, aTopic, aMessage, aBroker.Parser.RxQos, aRetained); 731 | end; 732 | 733 | procedure TMQTTServer.BkrSubscriptionChange(Sender: TObject); 734 | var 735 | i : integer; 736 | begin 737 | mon ('Subscriptions changed...'); 738 | for i := 0 to Brokers.Count - 1 do 739 | SyncBrokerSubscriptions (TMQTTClient (Brokers[i])); 740 | end; 741 | 742 | constructor TMQTTServer.Create (anOwner: TComponent); 743 | begin 744 | inherited; 745 | Timers := AllocateHWnd (TimerProc); 746 | MessageID := 1000; 747 | FOnMonHdr := nil; 748 | FPort := 1883; 749 | FMaxRetries := DefMaxRetries; 750 | FRetryTime := DefRetryTime; 751 | Brokers := TList.Create; 752 | Sessions := TMQTTSessionStore.Create; 753 | Retained := TMQTTMessageStore.Create; 754 | Server := TWSocketServer.Create (Self); 755 | Server.OnClientCreate := DoClientCreate; 756 | Server.OnClientDisconnect := DoClientDisconnect; 757 | Server.OnClientConnect := DoClientConnect; 758 | end; 759 | 760 | destructor TMQTTServer.Destroy; 761 | var 762 | i : integer; 763 | begin 764 | DeallocateHWnd (Timers); 765 | for i := 0 to Brokers.Count - 1 do 766 | TMQTTClient (Brokers[i]).Free; 767 | Brokers.Free; 768 | Retained.Free; 769 | Sessions.Free; 770 | Activate (false); 771 | Server.Free; 772 | inherited; 773 | end; 774 | 775 | procedure TMQTTServer.RxPing (Sender: TObject); 776 | begin 777 | if not (Sender is TMQTTParser) then exit; 778 | TMQTTParser (Sender).SendPingResp; 779 | end; 780 | 781 | procedure TMQTTServer.RxPublish (Sender: TObject; anID: Word; aTopic : UTF8String; 782 | aMessage: AnsiString); 783 | var 784 | aParser : TMQTTParser; 785 | aClient : TClient; 786 | aMsg : TMQTTMessage; 787 | i : integer; 788 | 789 | begin 790 | if not (Sender is TMQTTParser) then exit; 791 | aParser := TMQTTParser (Sender); 792 | aClient := GetClient (aParser); 793 | if aClient = nil then exit; 794 | if aParser.RxRetain then 795 | begin 796 | mon ('Retaining "' + string (aTopic) + '" @ ' + QOSNames[aParser.RxQos]); 797 | for i := Retained.Count - 1 downto 0 do 798 | begin 799 | aMsg := Retained[i]; 800 | if aMsg.Topic = aTopic then 801 | begin 802 | Retained.Remove (aMsg); 803 | aMsg.Free; 804 | break; 805 | end; 806 | end; 807 | Retained.AddMsg (0, aTopic, aMessage, aParser.RxQos, 0, 0); 808 | end; 809 | case aParser.RxQos of 810 | qtAT_MOST_ONCE : 811 | PublishToAll (aClient, aTopic, aMessage, aParser.RxQos, aParser.RxRetain); 812 | qtAT_LEAST_ONCE : 813 | begin 814 | aParser.SendPubAck (anID); 815 | PublishToAll (aClient, aTopic, aMessage, aParser.RxQos, aParser.RxRetain); 816 | end; 817 | qtEXACTLY_ONCE : 818 | begin 819 | aMsg := aClient.Releasables.GetMsg (anID); 820 | if aMsg = nil then 821 | begin 822 | aClient.Releasables.AddMsg (anID, aTopic, aMessage, aParser.RxQos, 0, 0); 823 | mon (string (aClient.Parser.ClientID) + ' Message ' + IntToStr (anID) + ' stored and idle.'); 824 | end 825 | else 826 | mon (string (aClient.Parser.ClientID) + ' Message ' + IntToStr (anID) + ' already stored.'); 827 | aParser.SendPubRec (anID); 828 | end; 829 | end; 830 | end; 831 | 832 | procedure TMQTTServer.LoadBrokers (anIniFile: string); 833 | var 834 | i : integer; 835 | Sections : TStringList; 836 | aBroker : TMQTTClient; 837 | EnFlag : Boolean; 838 | begin 839 | for i := 0 to Brokers.Count - 1 do 840 | TMQTTClient (Brokers[i]).Free; 841 | Brokers.Clear; 842 | Sections := TStringList.Create; 843 | with TIniFile.Create (anIniFile) do 844 | begin 845 | ReadSections (Sections); 846 | for i := 0 to Sections.Count - 1 do 847 | begin 848 | if Copy (Sections[i], 1, 6) = 'BROKER' then 849 | begin 850 | aBroker := AddBroker ('', 0); 851 | aBroker.Host := ReadString (Sections[i], 'Prim Host', ''); 852 | aBroker.Port := ReadInteger (Sections[i], 'Port', 1883); 853 | EnFlag := ReadBool (Sections[i], 'Enabled', false); 854 | if EnFlag then aBroker.Activate (true); 855 | end; 856 | end; 857 | Free; 858 | end; 859 | Sections.Free; 860 | end; 861 | 862 | procedure TMQTTServer.SetMaxRetries (const Value: integer); 863 | var 864 | i : integer; 865 | begin 866 | FMaxRetries := Value; 867 | for i := 0 to Server.ClientCount - 1 do 868 | TClient (Server.Client[i]).Parser.MaxRetries := Value; 869 | for i := 0 to Brokers.Count - 1 do 870 | TMQTTClient (Brokers[i]).Parser.MaxRetries := Value; 871 | end; 872 | 873 | procedure TMQTTServer.SetRetryTime (const Value: cardinal); 874 | var 875 | i : integer; 876 | begin 877 | FRetryTime := Value; 878 | for i := 0 to Server.ClientCount - 1 do 879 | TClient (Server.Client[i]).Parser.KeepAlive := Value; 880 | for i := 0 to Brokers.Count - 1 do 881 | TMQTTClient (Brokers[i]).Parser.KeepAlive := Value; 882 | end; 883 | 884 | procedure TMQTTServer.StoreBrokers (anIniFile: string); 885 | var 886 | i : integer; 887 | aBroker : TMQTTClient; 888 | Sections : TStringList; 889 | begin 890 | Sections := TStringList.Create; 891 | with TIniFile.Create (anIniFile) do 892 | begin 893 | ReadSections (Sections); 894 | for i := 0 to Sections.Count - 1 do 895 | if Copy (Sections[i], 1, 6) = 'BROKER' then 896 | EraseSection (Sections[i]); 897 | for i := 0 to Brokers.Count - 1 do 898 | begin 899 | aBroker := Brokers[i]; 900 | WriteString (format ('BROKER%.3d', [i]), 'Prim Host', aBroker.Host); 901 | WriteInteger (format ('BROKER%.3d', [i]), 'Port', aBroker.Port); 902 | WriteBool (format ('BROKER%.3d', [i]), 'Enabled', aBroker.Enabled); 903 | end; 904 | Free; 905 | end; 906 | Sections.Free; 907 | end; 908 | 909 | procedure TMQTTServer.SyncBrokerSubscriptions (aBroker: TMQTTClient); 910 | var 911 | i, j, k : integer; 912 | x : cardinal; 913 | ToSub, ToUnsub : TStringList; 914 | aClient : TClient; 915 | found : boolean; 916 | begin 917 | ToSub := TStringList.Create; 918 | ToUnsub := TStringList.Create; 919 | for i := 0 to Server.ClientCount - 1 do 920 | begin 921 | aClient := TClient (Server.Client[i]); 922 | for j := 0 to aClient.Subscriptions.Count - 1 do 923 | begin 924 | found := false; 925 | for k := 0 to ToSub.Count - 1 do 926 | begin 927 | if aClient.Subscriptions[j] = ToSub[k] then 928 | begin 929 | found := true; 930 | break; 931 | end; 932 | end; 933 | if not found then ToSub.AddObject (aClient.Subscriptions[j], aClient.Subscriptions.Objects[j]); 934 | end; 935 | end; 936 | // add no longer used to unsubscribe 937 | for i := aBroker.Subscriptions.Count - 1 downto 0 do 938 | begin 939 | found := false; 940 | for j := 0 to ToSub.Count - 1 do 941 | begin 942 | if aBroker.Subscriptions[i] = ToSub[j] then 943 | begin 944 | x := cardinal (aBroker.Subscriptions.Objects[i]) and $03; // change to highest 945 | if x > (cardinal (ToSub.Objects[j]) and $03) then 946 | ToSub.Objects[j] := TObject (x); 947 | found := true; 948 | break; 949 | end; 950 | end; 951 | if not found then 952 | ToUnsub.AddObject (aBroker.Subscriptions[i], aBroker.Subscriptions.Objects[i]); 953 | end; 954 | // remove those already subscribed to 955 | for i := 0 to aBroker.Subscriptions.Count - 1 do 956 | begin 957 | for j := ToSub.Count - 1 downto 0 do 958 | begin 959 | if aBroker.Subscriptions[i] = ToSub[j] then 960 | ToSub.Delete (j); // already subscribed 961 | end; 962 | end; 963 | for i := 0 to ToSub.Count - 1 do 964 | aBroker.Subscribe (UTF8String (ToSub[i]), TMQTTQOSType (cardinal (ToSub.Objects[i]) and $03)); 965 | for i := 0 to ToUnsub.Count - 1 do 966 | aBroker.Unsubscribe (UTF8String (ToUnsub[i])); 967 | ToSub.Free; 968 | ToUnsub.Free; 969 | end; 970 | 971 | procedure TMQTTServer.Mon (aStr: string); 972 | begin 973 | if Assigned (FOnMon) then FOnMon (Self, aStr); 974 | end; 975 | 976 | function TMQTTServer.NextMessageID: Word; 977 | var 978 | i, j : integer; 979 | Unused : boolean; 980 | aMsg : TMQTTPacket; 981 | aClient : TClient; 982 | begin 983 | repeat 984 | Unused := true; 985 | MessageID := MessageID + 1; 986 | if MessageID = 0 then MessageID := 1; // exclude 0 987 | for i := 0 to Server.ClientCount - 1 do 988 | begin 989 | aClient := TClient (Server.Client[i]); 990 | for j := 0 to aClient.InFlight.Count - 1 do 991 | begin 992 | aMsg := aClient.InFlight[j]; 993 | if aMsg.ID = MessageID then 994 | begin 995 | Unused := false; 996 | break; 997 | end; 998 | end; 999 | if not Unused then break; 1000 | end; 1001 | until Unused; 1002 | Result := MessageID; 1003 | end; 1004 | 1005 | procedure TMQTTServer.PublishToAll (From : TObject; aTopic : UTF8String; aMessage : AnsiString; aQos : TMQTTQOSType; wasRetained : boolean); 1006 | var 1007 | i, j : integer; 1008 | sent : boolean; 1009 | aClient : TClient; 1010 | aBroker : TMQTTClient; 1011 | bQos : TMQTTQOSType; 1012 | begin 1013 | mon ('Publishing -- Was Retained ' + ny[wasRetained]); 1014 | for i := 0 to Server.ClientCount - 1 do 1015 | begin 1016 | aClient := TClient (Server.Client[i]); 1017 | if (aClient = From) and (aClient.FBroker) then continue; // don't send back to self if broker - non standard 1018 | //not LocalBounce then continue; 1019 | sent := false; 1020 | for j := 0 to aClient.Subscriptions.Count - 1 do 1021 | begin 1022 | if IsSubscribed (UTF8String (aClient.Subscriptions[j]), aTopic) then 1023 | begin 1024 | bQos := TMQTTQOSType (cardinal (aClient.Subscriptions.Objects[j]) and $03); 1025 | if aClient.FBroker then 1026 | mon ('Publishing to Broker ' + string (aClient.Parser.ClientID) + ' "' + string (aTopic) + '" Retained ' + ny[wasRetained and aClient.FBroker]) 1027 | 1028 | else 1029 | mon ('Publishing to Client ' + string (aClient.Parser.ClientID) + ' "' + string (aTopic) + '"'); 1030 | if bQos > aQos then bQos := aQos; 1031 | aClient.Parser.SendPublish (NextMessageID, aTopic, aMessage, bQos, false, wasRetained and aClient.FBroker); 1032 | sent := true; 1033 | break; // only do first 1034 | end; 1035 | end; 1036 | if (not sent) and (wasRetained) and (aClient.FBroker) then 1037 | begin 1038 | mon ('Forwarding Retained message to broker'); 1039 | aClient.Parser.SendPublish (NextMessageID, aTopic, aMessage, qtAT_LEAST_ONCE, false, true); 1040 | end; 1041 | end; 1042 | for i := 0 to Brokers.Count - 1 do // brokers get all messages -> downstream 1043 | begin 1044 | aBroker := TMQTTClient (Brokers[i]); 1045 | if aBroker = From then continue; 1046 | if not aBroker.Enabled then continue; 1047 | // if aBroker then 1048 | mon ('Publishing to Broker ' + string (aBroker.ClientID) + ' "' + string (aTopic) + '" @ ' + QOSNames[aQos] + ' Retained ' + ny[wasretained]); 1049 | aBroker.Publish (aTopic, aMessage, aQos, wasRetained); 1050 | end; 1051 | end; 1052 | 1053 | procedure TMQTTServer.TimerProc (var aMsg: TMessage); 1054 | var 1055 | i, j : integer; 1056 | bPacket : TMQTTPacket; 1057 | aClient : TClient; 1058 | WillClose : Boolean; 1059 | begin 1060 | if aMsg.Msg = WM_TIMER then 1061 | begin 1062 | KillTimer (Timers, aMsg.WParam); 1063 | // Mon ('Timer ' + IntToStr (aMsg.WParam) + ' triggered'); 1064 | case aMsg.WParam of 1065 | 3 : begin 1066 | for i := Server.ClientCount - 1 downto 0 do 1067 | begin 1068 | aClient := TClient (Server.Client[i]); 1069 | if not aClient.Parser.CheckKeepAlive then 1070 | begin 1071 | WillClose := true; 1072 | if Assigned (FOnFailure) then FOnFailure (aClient, frKEEPALIVE, WillClose); 1073 | if WillClose then aClient.CloseDelayed; 1074 | end 1075 | else 1076 | begin 1077 | for j := aClient.InFlight.Count - 1 downto 0 do 1078 | begin 1079 | bPacket := aClient.InFlight[j]; 1080 | if bPacket.Counter > 0 then 1081 | begin 1082 | bPacket.Counter := bPacket.Counter - 1; 1083 | if bPacket.Counter = 0 then 1084 | begin 1085 | bPacket.Retries := bPacket.Retries + 1; 1086 | if bPacket.Retries <= aClient.Parser.MaxRetries then 1087 | begin 1088 | if bPacket.Publishing then 1089 | begin 1090 | aClient.InFlight.List.Remove (bPacket); 1091 | mon ('Message ' + IntToStr (bPacket.ID) + ' disposed of..'); 1092 | mon ('Re-issuing Message ' + inttostr (bPacket.ID) + ' Retry ' + inttostr (bPacket.Retries)); 1093 | SetDup (bPacket.Msg, true); 1094 | aClient.DoSend (aClient.Parser, bPacket.ID, bPacket.Retries, bPacket.Msg); 1095 | bPacket.Free; 1096 | end 1097 | else 1098 | begin 1099 | mon ('Re-issuing PUBREL Message ' + inttostr (bPacket.ID) + ' Retry ' + inttostr (bPacket.Retries)); 1100 | aClient.Parser.SendPubRel (bPacket.ID, true); 1101 | bPacket.Counter := aClient.Parser.RetryTime; 1102 | end; 1103 | end 1104 | else 1105 | begin 1106 | WillClose := true; 1107 | if Assigned (FOnFailure) then FOnFailure (Self, frMAXRETRIES, WillClose); 1108 | if WillClose then aClient.CloseDelayed; 1109 | end; 1110 | end; 1111 | end; 1112 | end; 1113 | end; 1114 | end; 1115 | SetTimer (Timers, 3, 100, nil); 1116 | end; 1117 | end; 1118 | end; 1119 | end; 1120 | 1121 | procedure TMQTTServer.DoClientConnect (Sender: TObject; Client: TWSocketClient; 1122 | Error: Word); 1123 | begin 1124 | if Sender = Server then 1125 | Mon ('Client Connected...'); 1126 | end; 1127 | 1128 | procedure TMQTTServer.DoClientCreate (Sender: TObject; Client: TWSocketClient); 1129 | begin 1130 | with TClient (Client) do 1131 | begin 1132 | Parser.OnPing := RxPing; 1133 | Parser.OnDisconnect := RxDisconnect; 1134 | Parser.OnPublish := RxPublish; 1135 | Parser.OnPubRec := RxPubRec; 1136 | Parser.OnConnect := RxConnect; 1137 | Parser.OnBrokerConnect := RxBrokerConnect; // non standard 1138 | Parser.OnHeader := RxHeader; 1139 | Parser.MaxRetries := FMaxRetries; 1140 | Parser.RetryTime := FRetryTime; 1141 | OnMon := DoMon; 1142 | OnSubscriptionChange := BkrSubscriptionChange; 1143 | end; 1144 | end; 1145 | 1146 | procedure TMQTTServer.DoClientDisconnect (Sender: TObject; 1147 | Client: TWSocketClient; Error: Word); 1148 | var 1149 | aTopic, aMessage : UTF8String; 1150 | aQos : TMQTTQOSType; 1151 | begin 1152 | with TClient (Client) do 1153 | begin 1154 | Mon ('Client Disconnected. Graceful ' + ny[TClient (Client).FGraceful]); 1155 | if (InFlight.Count > 0) or (Releasables.Count > 0) then 1156 | begin 1157 | if Assigned (FOnStoreSession) then 1158 | FOnStoreSession (Client, Parser.ClientID) 1159 | else 1160 | Sessions.StoreSession (Parser.ClientID, TClient (Client)); 1161 | end; 1162 | if not FGraceful then 1163 | begin 1164 | aTopic := Parser.WillTopic; 1165 | aMessage := Parser.WillMessage; 1166 | aQos := Parser.WillQos; 1167 | if Assigned (FOnObituary) then 1168 | FOnObituary (Client, aTopic, aMessage, aQos); 1169 | PublishToAll (nil, aTopic, AnsiString (aMessage), aQos); 1170 | end; 1171 | end; 1172 | if Assigned (FOnClientsChange) then 1173 | FOnClientsChange (Server, Server.ClientCount - 1); 1174 | end; 1175 | 1176 | procedure TMQTTServer.DoMon (Sender: TObject; aStr: string); 1177 | begin 1178 | Mon (aStr); 1179 | end; 1180 | 1181 | function TMQTTServer.Enabled: boolean; 1182 | begin 1183 | Result := FEnable; 1184 | end; 1185 | 1186 | function TMQTTServer.GetClient (aClientID: UTF8String): TClient; 1187 | var 1188 | i : integer; 1189 | begin 1190 | for i := 0 to Server.ClientCount - 1 do 1191 | begin 1192 | Result := TClient (Server.Client[i]); 1193 | if Result.Parser.ClientID = aClientID then exit; 1194 | end; 1195 | (* for i := 0 to BrokerServer.ClientCount - 1 do 1196 | begin 1197 | Result := TClient (BrokerServer.Client[i]); 1198 | if Result.Parser.ClientID = aClientID then exit; 1199 | end; *) 1200 | Result := nil; 1201 | end; 1202 | 1203 | function TMQTTServer.GetClient (aParser: TMQTTParser): TClient; 1204 | var 1205 | i : integer; 1206 | begin 1207 | for i := 0 to Server.ClientCount - 1 do 1208 | begin 1209 | Result := TClient (Server.Client[i]); 1210 | if Result.Parser = aParser then exit; 1211 | end; 1212 | (* for i := 0 to BrokerServer.ClientCount - 1 do 1213 | begin 1214 | Result := TClient (BrokerServer.Client[i]); 1215 | if Result.Parser = aParser then exit; 1216 | end; *) 1217 | Result := nil; 1218 | end; 1219 | 1220 | 1221 | procedure TMQTTServer.RxBrokerConnect(Sender: TObject; aProtocol: UTF8String; 1222 | aVersion: byte; aClientID, aUserName, aPassword: UTF8String; aKeepAlive: Word; 1223 | aClean: Boolean); 1224 | var 1225 | aClient : TClient; 1226 | begin 1227 | if not (Sender is TMQTTParser) then exit; 1228 | aClient := GetClient (TMQTTParser (Sender)); 1229 | if aClient = nil then exit; 1230 | aClient.FBroker := true; 1231 | RxConnect (Sender, aProtocol, aVersion, aClientID, aUserName, aPassword, aKeepAlive, aClean); 1232 | end; 1233 | 1234 | procedure TMQTTServer.RxConnect (Sender: TObject; aProtocol: UTF8String; 1235 | aVersion: byte; aClientID, aUserName, aPassword: UTF8String; aKeepAlive: Word; 1236 | aClean: Boolean); 1237 | var 1238 | aClient : TClient; 1239 | aServer : TWSocketServer; 1240 | Allowed : Boolean; 1241 | begin 1242 | Allowed := false; 1243 | if not (Sender is TMQTTParser) then exit; 1244 | aClient := GetClient (TMQTTParser (Sender)); 1245 | if aClient = nil then exit; 1246 | aServer := TWSocketServer (aClient.Owner); 1247 | aClient.FGraceful := true; 1248 | if Assigned (FOnCheckUser) then 1249 | FOnCheckUser (aServer, aUserName, aPassword, Allowed); 1250 | if Allowed then 1251 | begin 1252 | if aVersion < MinVersion then 1253 | begin 1254 | aClient.Parser.SendConnAck (rcPROTOCOL); // identifier rejected 1255 | aClient.CloseDelayed; 1256 | end 1257 | else if (length (aClientID) < 1) or (length (aClientID) > 23) then 1258 | begin 1259 | aClient.Parser.SendConnAck (rcIDENTIFIER); // identifier rejected 1260 | aClient.CloseDelayed; 1261 | end 1262 | else if GetClient (aClientID) <> nil then 1263 | begin 1264 | aClient.Parser.SendConnAck (rcIDENTIFIER); // identifier rejected 1265 | aClient.CloseDelayed; 1266 | end 1267 | else 1268 | begin 1269 | // mon ('Client ID ' + ClientID + ' User ' + striUserName + ' Pass ' + PassWord); 1270 | aClient.Parser.Username := aUserName; 1271 | aClient.Parser.Password := aPassword; 1272 | aClient.Parser.ClientID := aClientID; 1273 | aClient.Parser.KeepAlive := aKeepAlive; 1274 | aClient.Parser.Clean := aClean; 1275 | mon ('Clean ' + ny[aClean]); 1276 | if not aClean then 1277 | begin 1278 | if Assigned (FOnRestoreSession) then 1279 | FOnRestoreSession (aClient, aClientID) 1280 | else 1281 | Sessions.RestoreSession (aClientID, aClient); 1282 | end; 1283 | if Assigned (FOnDeleteSession) then 1284 | FOnDeleteSession (aClient, aClientID) 1285 | else 1286 | Sessions.DeleteSession (aClientID); 1287 | aClient.Parser.SendConnAck (rcACCEPTED); 1288 | aClient.FGraceful := false; 1289 | mon ('Accepted. Is Broker ' + ny[aClient.FBroker]); 1290 | if Assigned (FOnClientsChange) then 1291 | FOnClientsChange (aServer, aServer.ClientCount); 1292 | end; 1293 | end 1294 | else 1295 | begin 1296 | aClient.Parser.SendConnAck (rcUSER); 1297 | aClient.CloseDelayed; 1298 | end; 1299 | end; 1300 | 1301 | procedure TMQTTServer.RxDisconnect (Sender: TObject); 1302 | var 1303 | aClient : TClient; 1304 | begin 1305 | if not (Sender is TMQTTParser) then exit; 1306 | aClient := GetClient (TMQTTParser (Sender)); 1307 | if aClient = nil then exit; 1308 | aClient.FGraceful := true; 1309 | end; 1310 | 1311 | procedure TMQTTServer.RxHeader (Sender: TObject; MsgType: TMQTTMessageType; 1312 | Dup: Boolean; Qos: TMQTTQOSType; Retain: Boolean); 1313 | begin 1314 | if Assigned (FOnMonHdr) then FOnMonHdr (Self, MsgType, Dup, Qos, Retain); 1315 | end; 1316 | 1317 | { TMQTTClient } 1318 | 1319 | procedure TMQTTClient.Activate (Enable: Boolean); 1320 | begin 1321 | if Enable = FEnable then exit; 1322 | FEnable := Enable; 1323 | try 1324 | if (Link.State = wsConnected) then 1325 | begin 1326 | Parser.SendDisconnect; 1327 | FGraceful := true; 1328 | end; 1329 | Link.CloseDelayed; 1330 | except 1331 | end; 1332 | if Enable then 1333 | SetTimer (Timers, 1, 100, nil) 1334 | else 1335 | begin 1336 | KillTimer (Timers, 1); 1337 | KillTimer (Timers, 2); 1338 | KillTimer (Timers, 3); 1339 | end; 1340 | if Assigned (FOnEnableChange) then FOnEnableChange (Self); 1341 | end; 1342 | 1343 | constructor TMQTTClient.Create (anOwner: TComponent); 1344 | begin 1345 | inherited; 1346 | FHost := ''; 1347 | FUsername := ''; 1348 | FPassword := ''; 1349 | FPort := 1883; 1350 | FEnable := false; 1351 | FGraceful := false; 1352 | FOnline := false; 1353 | FBroker := false; // non standard 1354 | FLocalBounce := false; 1355 | FAutoSubscribe := false; 1356 | FMessageID := 0; 1357 | Subscriptions := TStringList.Create; 1358 | Releasables := TMQTTMessageStore.Create; 1359 | Parser := TMQTTParser.Create; 1360 | Parser.OnSend := DoSend; 1361 | Parser.OnConnAck := RxConnAck; 1362 | Parser.OnPublish := RxPublish; 1363 | Parser.OnSubAck := RxSubAck; 1364 | Parser.OnUnsubAck := RxUnsubAck; 1365 | Parser.OnPubAck := RxPubAck; 1366 | Parser.OnPubRel := RxPubRel; 1367 | Parser.OnPubRec := RxPubRec; 1368 | Parser.OnPubComp := RxPubComp; 1369 | Parser.KeepAlive := 10; 1370 | Timers := AllocateHWnd (TimerProc); 1371 | InFlight := TMQTTPacketStore.Create; 1372 | Link := TWSocket.Create (Self); 1373 | Link.OnDataAvailable := LinkData; 1374 | Link.OnSessionConnected := LinkConnected; 1375 | Link.OnSessionClosed := LinkClosed; 1376 | end; 1377 | 1378 | destructor TMQTTClient.Destroy; 1379 | begin 1380 | Releasables.Clear; 1381 | Releasables.Free; 1382 | Subscriptions.Free; 1383 | InFlight.Clear; 1384 | InFlight.Free; 1385 | KillTimer (Timers, 1); 1386 | KillTimer (Timers, 2); 1387 | KillTimer (Timers, 3); 1388 | DeAllocateHWnd (Timers); 1389 | try 1390 | Link.Close; 1391 | finally 1392 | Link.Free; 1393 | end; 1394 | Parser.Free; 1395 | inherited; 1396 | end; 1397 | 1398 | procedure TMQTTClient.RxConnAck (Sender: TObject; aCode: byte); 1399 | var 1400 | i : integer; 1401 | x : cardinal; 1402 | begin 1403 | Mon ('Connection ' + codenames(aCode)); 1404 | if aCode = rcACCEPTED then 1405 | begin 1406 | FOnline := true; 1407 | FGraceful := false; 1408 | SetTimer (Timers, 3, 100, nil); // start retry counters 1409 | if Assigned (FOnOnline) then FOnOnline (Self); 1410 | if (FAutoSubscribe) and (Subscriptions.Count > 0) then 1411 | begin 1412 | for i := 0 to Subscriptions.Count - 1 do 1413 | begin 1414 | x := cardinal (Subscriptions.Objects[i]) and $03; 1415 | Parser.SendSubscribe (NextMessageID, UTF8String (Subscriptions[i]), TMQTTQOSType (x)); 1416 | end; 1417 | end; 1418 | end 1419 | else 1420 | Activate (false); // not going to connect 1421 | end; 1422 | // publishing 1423 | procedure TMQTTClient.RxPublish (Sender: TObject; anID: Word; aTopic : UTF8String; 1424 | aMessage : AnsiString); 1425 | var 1426 | aMsg : TMQTTMessage; 1427 | begin 1428 | case Parser.RxQos of 1429 | qtAT_MOST_ONCE : 1430 | if Assigned (FOnMsg) then FOnMsg (Self, aTopic, aMessage, Parser.RxQos, Parser.RxRetain); 1431 | qtAT_LEAST_ONCE : 1432 | begin 1433 | Parser.SendPubAck (anID); 1434 | if Assigned (FOnMsg) then FOnMsg (Self, aTopic, aMessage, Parser.RxQos, Parser.RxRetain); 1435 | end; 1436 | qtEXACTLY_ONCE : 1437 | begin 1438 | Parser.SendPubRec (anID); 1439 | aMsg := Releasables.GetMsg (anID); 1440 | if aMsg = nil then 1441 | begin 1442 | Releasables.AddMsg (anID, aTopic, aMessage, Parser.RxQos, 0, 0, Parser.RxRetain); 1443 | mon ('Message ' + IntToStr (anID) + ' stored and idle.'); 1444 | end 1445 | else 1446 | mon ('Message ' + IntToStr (anID) + ' already stored.'); 1447 | end; 1448 | end; 1449 | end; 1450 | 1451 | procedure TMQTTClient.RxPubAck (Sender: TObject; anID: Word); 1452 | begin 1453 | InFlight.DelPacket (anID); 1454 | Mon ('ACK Message ' + IntToStr (anID) + ' disposed of.'); 1455 | end; 1456 | 1457 | procedure TMQTTClient.RxPubComp (Sender: TObject; anID: Word); 1458 | begin 1459 | InFlight.DelPacket (anID); 1460 | Mon ('COMP Message ' + IntToStr (anID) + ' disposed of.'); 1461 | end; 1462 | 1463 | procedure TMQTTClient.RxPubRec (Sender: TObject; anID: Word); 1464 | var 1465 | aPacket : TMQTTPacket; 1466 | begin 1467 | aPacket := InFlight.GetPacket (anID); 1468 | if aPacket <> nil then 1469 | begin 1470 | aPacket.Counter := Parser.RetryTime; 1471 | if aPacket.Publishing then 1472 | begin 1473 | aPacket.Publishing := false; 1474 | Mon ('REC Message ' + IntToStr (anID) + ' recorded.'); 1475 | end 1476 | else 1477 | Mon ('REC Message ' + IntToStr (anID) + ' already recorded.'); 1478 | end 1479 | else 1480 | Mon ('REC Message ' + IntToStr (anID) + ' not found.'); 1481 | Parser.SendPubRel (anID); 1482 | end; 1483 | 1484 | procedure TMQTTClient.RxPubRel (Sender: TObject; anID: Word); 1485 | var 1486 | aMsg : TMQTTMessage; 1487 | begin 1488 | aMsg := Releasables.GetMsg (anID); 1489 | if aMsg <> nil then 1490 | begin 1491 | Mon ('REL Message ' + IntToStr (anID) + ' publishing @ ' + QOSNames[aMsg.Qos]); 1492 | if Assigned (FOnMsg) then FOnMsg (Self, aMsg.Topic, aMsg.Message, aMsg.Qos, aMsg.Retained); 1493 | Releasables.Remove (aMsg); 1494 | aMsg.Free; 1495 | Mon ('REL Message ' + IntToStr (anID) + ' removed from storage.'); 1496 | end 1497 | else 1498 | Mon ('REL Message ' + IntToStr (anID) + ' has been already removed from storage.'); 1499 | Parser.SendPubComp (anID); 1500 | end; 1501 | 1502 | procedure TMQTTClient.SetClean (const Value: Boolean); 1503 | begin 1504 | Parser.Clean := Value; 1505 | end; 1506 | 1507 | procedure TMQTTClient.SetClientID (const Value: UTF8String); 1508 | begin 1509 | Parser.ClientID := Value; 1510 | end; 1511 | 1512 | procedure TMQTTClient.SetKeepAlive (const Value: Word); 1513 | begin 1514 | Parser.KeepAlive := Value; 1515 | end; 1516 | 1517 | procedure TMQTTClient.SetMaxRetries (const Value: integer); 1518 | begin 1519 | Parser.MaxRetries := Value; 1520 | end; 1521 | 1522 | procedure TMQTTClient.SetPassword (const Value: UTF8String); 1523 | begin 1524 | Parser.Password := Value; 1525 | end; 1526 | 1527 | procedure TMQTTClient.SetRetryTime (const Value: cardinal); 1528 | begin 1529 | Parser.RetryTime := Value; 1530 | end; 1531 | 1532 | procedure TMQTTClient.SetUsername (const Value: UTF8String); 1533 | begin 1534 | Parser.UserName := Value; 1535 | end; 1536 | 1537 | procedure TMQTTClient.SetWill (aTopic, aMessage : UTF8String; aQos: TMQTTQOSType; 1538 | aRetain: Boolean); 1539 | begin 1540 | Parser.SetWill (aTopic, aMessage, aQos, aRetain); 1541 | end; 1542 | 1543 | procedure TMQTTClient.Subscribe (Topics: TStringList); 1544 | var 1545 | j : integer; 1546 | i, x : cardinal; 1547 | anID : Word; 1548 | found : boolean; 1549 | begin 1550 | if Topics = nil then exit; 1551 | anID := NextMessageID; 1552 | for i := 0 to Topics.Count - 1 do 1553 | begin 1554 | found := false; 1555 | // 255 denotes acked 1556 | if i > 254 then 1557 | x := (cardinal (Topics.Objects[i]) and $03) 1558 | else 1559 | x := (cardinal (Topics.Objects[i]) and $03) + (anID shl 16) + (i shl 8) ; 1560 | for j := 0 to Subscriptions.Count - 1 do 1561 | if Subscriptions[j] = Topics[i] then 1562 | begin 1563 | found := true; 1564 | Subscriptions.Objects[j] := TObject (x); 1565 | break; 1566 | end; 1567 | if not found then 1568 | Subscriptions.AddObject (Topics[i], TObject (x)); 1569 | end; 1570 | Parser.SendSubscribe (anID, Topics); 1571 | end; 1572 | 1573 | procedure TMQTTClient.Subscribe (aTopic: UTF8String; aQos: TMQTTQOSType); 1574 | var 1575 | i : integer; 1576 | x : cardinal; 1577 | found : boolean; 1578 | anID : Word; 1579 | begin 1580 | if aTopic = '' then exit; 1581 | found := false; 1582 | anID := NextMessageID; 1583 | x := ord (aQos) + (anID shl 16); 1584 | for i := 0 to Subscriptions.Count - 1 do 1585 | if Subscriptions[i] = string (aTopic) then 1586 | begin 1587 | found := true; 1588 | Subscriptions.Objects[i] := TObject (x); 1589 | break; 1590 | end; 1591 | if not found then 1592 | Subscriptions.AddObject (string (aTopic), TObject (x)); 1593 | Parser.SendSubscribe (anID, aTopic, aQos); 1594 | end; 1595 | 1596 | procedure TMQTTClient.DoSend (Sender: TObject; anID : Word; aRetry : integer; aStream: TMemoryStream); 1597 | var 1598 | x : byte; 1599 | begin 1600 | if Link.State = wsConnected then 1601 | begin 1602 | KillTimer (Timers, 2); // 75% of keep alive 1603 | if KeepAlive > 0 then SetTimer (Timers, 2, KeepAlive * 750, nil); 1604 | aStream.Seek (0, soFromBeginning); 1605 | aStream.Read (x, 1); 1606 | if (TMQTTQOSType ((x and $06) shr 1) in [qtAT_LEAST_ONCE, qtEXACTLY_ONCE]) and 1607 | (TMQTTMessageType ((x and $f0) shr 4) in [{mtPUBREL,} mtPUBLISH, mtSUBSCRIBE, mtUNSUBSCRIBE]) and 1608 | (anID > 0) then 1609 | begin 1610 | InFlight.AddPacket (anID, aStream, aRetry, Parser.RetryTime); 1611 | mon ('Message ' + IntToStr (anID) + ' created.'); 1612 | end; 1613 | Link.Send (aStream.Memory, aStream.Size); 1614 | Sleep (0); 1615 | end; 1616 | end; 1617 | 1618 | function TMQTTClient.Enabled: boolean; 1619 | begin 1620 | Result := FEnable; 1621 | end; 1622 | 1623 | function TMQTTClient.GetClean: Boolean; 1624 | begin 1625 | Result := Parser.Clean; 1626 | end; 1627 | 1628 | function TMQTTClient.GetClientID: UTF8String; 1629 | begin 1630 | Result := Parser.ClientID; 1631 | end; 1632 | 1633 | function TMQTTClient.GetKeepAlive: Word; 1634 | begin 1635 | Result := Parser.KeepAlive; 1636 | end; 1637 | 1638 | function TMQTTClient.GetMaxRetries: integer; 1639 | begin 1640 | Result := Parser.MaxRetries; 1641 | end; 1642 | 1643 | function TMQTTClient.GetPassword: UTF8String; 1644 | begin 1645 | Result := Parser.Password; 1646 | end; 1647 | 1648 | function TMQTTClient.GetRetryTime: cardinal; 1649 | begin 1650 | Result := Parser.RetryTime; 1651 | end; 1652 | 1653 | function TMQTTClient.GetUsername: UTF8String; 1654 | begin 1655 | Result := Parser.UserName; 1656 | end; 1657 | 1658 | procedure TMQTTClient.RxSubAck (Sender: TObject; anID: Word; Qoss : array of TMQTTQosType); 1659 | var 1660 | j : integer; 1661 | i, x : cardinal; 1662 | begin 1663 | InFlight.DelPacket (anID); 1664 | Mon ('Message ' + IntToStr (anID) + ' disposed of.'); 1665 | for i := low (Qoss) to high (Qoss) do 1666 | begin 1667 | if i > 254 then break; // only valid for first 254 1668 | for j := 0 to Subscriptions.Count - 1 do 1669 | begin 1670 | x := cardinal (Subscriptions.Objects[j]); 1671 | if (hiword (x) = anID) and ((x and $0000ff00) shr 8 = i) then 1672 | Subscriptions.Objects[j] := TObject ($ff00 + ord (Qoss[i])); 1673 | end; 1674 | end; 1675 | end; 1676 | 1677 | procedure TMQTTClient.RxUnsubAck (Sender: TObject; anID: Word); 1678 | begin 1679 | InFlight.DelPacket (anID); 1680 | Mon ('Message ' + IntToStr (anID) + ' disposed of.'); 1681 | end; 1682 | 1683 | procedure TMQTTClient.LinkConnected (Sender: TObject; ErrCode: Word); 1684 | var 1685 | aClientID : UTF8String; 1686 | 1687 | function TimeString : UTF8string; 1688 | begin 1689 | // 86400 secs 1690 | Result := UTF8String (IntToHex (Trunc (Date), 5) + IntToHex (Trunc (Frac (Time) * 864000), 7)); 1691 | end; 1692 | 1693 | begin 1694 | if ErrCode = 0 then 1695 | begin 1696 | FGraceful := false; // still haven't connected but expect to 1697 | Parser.Reset; 1698 | // mon ('Time String : ' + Timestring); 1699 | //= mon ('xaddr ' + Link.GetXAddr); 1700 | aClientID := ClientID; 1701 | if aClientID = '' then 1702 | aClientID := 'CID' + UTF8String (Link.GetXPort); // + TimeString; 1703 | if Assigned (FOnClientID) then 1704 | FOnClientID (Self, aClientID); 1705 | ClientID := aClientID; 1706 | if Parser.Clean then 1707 | begin 1708 | InFlight.Clear; 1709 | Releasables.Clear; 1710 | end; 1711 | if FBroker then 1712 | Parser.SendBrokerConnect (aClientID, Parser.UserName, Parser.Password, KeepAlive, Parser.Clean) 1713 | else 1714 | Parser.SendConnect (aClientID, Parser.UserName, Parser.Password, KeepAlive, Parser.Clean); 1715 | end; 1716 | end; 1717 | 1718 | procedure TMQTTClient.LinkData (Sender: TObject; ErrCode: Word); 1719 | begin 1720 | if ErrCode = 0 then Parser.Parse (Link.ReceiveStrA); 1721 | end; 1722 | 1723 | procedure TMQTTClient.Mon(aStr: string); 1724 | begin 1725 | if Assigned (FOnMon) then FOnMon (Self, aStr); 1726 | end; 1727 | 1728 | function TMQTTClient.NextMessageID: Word; 1729 | var 1730 | i : integer; 1731 | Unused : boolean; 1732 | aMsg : TMQTTPacket; 1733 | begin 1734 | repeat 1735 | Unused := true; 1736 | FMessageID := FMessageID + 1; 1737 | if FMessageID = 0 then FMessageID := 1; // exclude 0 1738 | for i := 0 to InFlight.Count - 1 do 1739 | begin 1740 | aMsg := InFlight.List[i]; 1741 | if aMsg.ID = FMessageID then 1742 | begin 1743 | Unused := false; 1744 | break; 1745 | end; 1746 | end; 1747 | until Unused; 1748 | Result := FMessageID; 1749 | end; 1750 | 1751 | function TMQTTClient.Online: boolean; 1752 | begin 1753 | Result := FOnline; 1754 | end; 1755 | 1756 | procedure TMQTTClient.Ping; 1757 | begin 1758 | Parser.SendPing; 1759 | end; 1760 | 1761 | procedure TMQTTClient.Publish (aTopic : UTF8String; aMessage : AnsiString; aQos : TMQTTQOSType; aRetain : Boolean); 1762 | var 1763 | i : integer; 1764 | found : boolean; 1765 | begin 1766 | if FLocalBounce and Assigned (FOnMsg) then 1767 | begin 1768 | found := false; 1769 | for i := 0 to Subscriptions.Count - 1 do 1770 | if IsSubscribed (UTF8String (Subscriptions[i]), aTopic) then 1771 | begin 1772 | found := true; 1773 | break; 1774 | end; 1775 | if found then 1776 | begin 1777 | Parser.RxQos := aQos; 1778 | FOnMsg (Self, aTopic, aMessage, aQos, false); 1779 | end; 1780 | end; 1781 | Parser.SendPublish (NextMessageID, aTopic, aMessage, aQos, false, aRetain); 1782 | end; 1783 | 1784 | procedure TMQTTClient.TimerProc (var aMsg: TMessage); 1785 | var 1786 | i : integer; 1787 | bPacket : TMQTTPacket; 1788 | WillClose : Boolean; 1789 | begin 1790 | if aMsg.Msg = WM_TIMER then 1791 | begin 1792 | KillTimer (Timers, aMsg.WParam); 1793 | case aMsg.WParam of 1794 | 1 : begin 1795 | Mon ('Connecting to ' + Host + ' on Port ' + IntToStr (Port)); 1796 | Link.Addr := Host; 1797 | Link.Port := IntToStr (Port); 1798 | Link.Proto := 'tcp'; 1799 | try 1800 | Link.Connect; 1801 | except 1802 | end; 1803 | end; 1804 | 2 : Ping; 1805 | 3 : begin // send duplicates 1806 | for i := InFlight.Count - 1 downto 0 do 1807 | begin 1808 | bPacket := InFlight.List[i]; 1809 | if bPacket.Counter > 0 then 1810 | begin 1811 | bPacket.Counter := bPacket.Counter - 1; 1812 | if bPacket.Counter = 0 then 1813 | begin 1814 | bPacket.Retries := bPacket.Retries + 1; 1815 | if bPacket.Retries <= MaxRetries then 1816 | begin 1817 | if bPacket.Publishing then 1818 | begin 1819 | InFlight.List.Remove (bPacket); 1820 | mon ('Message ' + IntToStr (bPacket.ID) + ' disposed of..'); 1821 | mon ('Re-issuing Message ' + inttostr (bPacket.ID) + ' Retry ' + inttostr (bPacket.Retries)); 1822 | SetDup (bPacket.Msg, true); 1823 | DoSend (Parser, bPacket.ID, bPacket.Retries, bPacket.Msg); 1824 | bPacket.Free; 1825 | end 1826 | else 1827 | begin 1828 | mon ('Re-issuing PUBREL Message ' + inttostr (bPacket.ID) + ' Retry ' + inttostr (bPacket.Retries)); 1829 | Parser.SendPubRel (bPacket.ID, true); 1830 | bPacket.Counter := Parser.RetryTime; 1831 | end; 1832 | end 1833 | else 1834 | begin 1835 | WillClose := true; 1836 | if Assigned (FOnFailure) then FOnFailure (Self, frMAXRETRIES, WillClose); 1837 | if WillClose then Link.CloseDelayed; 1838 | end; 1839 | end; 1840 | end; 1841 | end; 1842 | SetTimer (Timers, 3, 100, nil); 1843 | end; 1844 | end; 1845 | end; 1846 | end; 1847 | 1848 | procedure TMQTTClient.Unsubscribe (Topics: TStringList); 1849 | var 1850 | i, J : integer; 1851 | begin 1852 | if Topics = nil then exit; 1853 | for i := 0 to Topics.Count - 1 do 1854 | begin 1855 | for j := Subscriptions.Count - 1 downto 0 do 1856 | if Subscriptions[j] = Topics[i] then 1857 | begin 1858 | Subscriptions.Delete (j); 1859 | break; 1860 | end; 1861 | end; 1862 | Parser.SendUnsubscribe (NextMessageID, Topics); 1863 | end; 1864 | 1865 | procedure TMQTTClient.Unsubscribe (aTopic: UTF8String); 1866 | var 1867 | i : integer; 1868 | begin 1869 | if aTopic = '' then exit; 1870 | for i := Subscriptions.Count - 1 downto 0 do 1871 | if Subscriptions[i] = string (aTopic) then 1872 | begin 1873 | Subscriptions.Delete (i); 1874 | break; 1875 | end; 1876 | Parser.SendUnsubscribe (NextMessageID, aTopic); 1877 | end; 1878 | 1879 | procedure TMQTTClient.LinkClosed (Sender: TObject; ErrCode: Word); 1880 | begin 1881 | // Mon ('Link Closed...'); 1882 | KillTimer (Timers, 2); 1883 | KillTimer (Timers, 3); 1884 | if Assigned (FOnOffline) and (FOnline) then 1885 | FOnOffline (Self, FGraceful); 1886 | FOnline := false; 1887 | if FEnable then SetTimer (Timers, 1, 6000, nil); 1888 | end; 1889 | 1890 | { TMQTTPacketStore } 1891 | 1892 | function TMQTTPacketStore.AddPacket (anID : Word; aMsg : TMemoryStream; aRetry : cardinal; aCount : cardinal) : TMQTTPacket; 1893 | begin 1894 | Result := TMQTTPacket.Create; 1895 | Result.ID := anID; 1896 | Result.Counter := aCount; 1897 | Result.Retries := aRetry; 1898 | aMsg.Seek (0, soFromBeginning); 1899 | Result.Msg.CopyFrom (aMsg, aMsg.Size); 1900 | List.Add (Result); 1901 | end; 1902 | 1903 | procedure TMQTTPacketStore.Assign (From : TMQTTPacketStore); 1904 | var 1905 | i : integer; 1906 | aPacket, bPacket : TMQTTPacket; 1907 | begin 1908 | Clear; 1909 | for i := 0 to From.Count - 1 do 1910 | begin 1911 | aPacket := From[i]; 1912 | bPacket := TMQTTPacket.Create; 1913 | bPacket.Assign (aPacket); 1914 | List.Add (bPacket); 1915 | end; 1916 | end; 1917 | 1918 | procedure TMQTTPacketStore.Clear; 1919 | var 1920 | i : integer; 1921 | begin 1922 | for i := 0 to List.Count - 1 do 1923 | TMQTTPacket (List[i]).Free; 1924 | List.Clear; 1925 | end; 1926 | 1927 | function TMQTTPacketStore.Count: integer; 1928 | begin 1929 | Result := List.Count; 1930 | end; 1931 | 1932 | constructor TMQTTPacketStore.Create; 1933 | begin 1934 | Stamp := Now; 1935 | List := TList.Create; 1936 | end; 1937 | 1938 | procedure TMQTTPacketStore.DelPacket (anID: Word); 1939 | var 1940 | i : integer; 1941 | aPacket : TMQTTPacket; 1942 | begin 1943 | for i := List.Count - 1 downto 0 do 1944 | begin 1945 | aPacket := List[i]; 1946 | if aPacket.ID = anID then 1947 | begin 1948 | List.Remove (aPacket); 1949 | aPacket.Free; 1950 | exit; 1951 | end; 1952 | end; 1953 | end; 1954 | 1955 | destructor TMQTTPacketStore.Destroy; 1956 | begin 1957 | Clear; 1958 | List.Free; 1959 | inherited; 1960 | end; 1961 | 1962 | function TMQTTPacketStore.GetItem (Index: Integer): TMQTTPacket; 1963 | begin 1964 | if (Index >= 0) and (Index < Count) then 1965 | Result := List[Index] 1966 | else 1967 | Result := nil; 1968 | end; 1969 | 1970 | function TMQTTPacketStore.GetPacket (anID: Word): TMQTTPacket; 1971 | var 1972 | i : integer; 1973 | begin 1974 | for i := 0 to List.Count - 1 do 1975 | begin 1976 | Result := List[i]; 1977 | if Result.ID = anID then exit; 1978 | end; 1979 | Result := nil; 1980 | end; 1981 | 1982 | procedure TMQTTPacketStore.Remove (aPacket : TMQTTPacket); 1983 | begin 1984 | List.Remove (aPacket); 1985 | end; 1986 | 1987 | procedure TMQTTPacketStore.SetItem (Index: Integer; const Value: TMQTTPacket); 1988 | begin 1989 | if (Index >= 0) and (Index < Count) then 1990 | List[Index] := Value; 1991 | end; 1992 | 1993 | { TMQTTPacket } 1994 | 1995 | procedure TMQTTPacket.Assign (From: TMQTTPacket); 1996 | begin 1997 | ID := From.ID; 1998 | Stamp := From.Stamp; 1999 | Counter := From.Counter; 2000 | Retries := From.Retries; 2001 | Msg.Clear; 2002 | From.Msg.Seek (0, soFromBeginning); 2003 | Msg.CopyFrom (From.Msg, From.Msg.Size); 2004 | Publishing := From.Publishing; 2005 | end; 2006 | 2007 | constructor TMQTTPacket.Create; 2008 | begin 2009 | ID := 0; 2010 | Stamp := Now; 2011 | Publishing := true; 2012 | Counter := 0; 2013 | Retries := 0; 2014 | Msg := TMemoryStream.Create; 2015 | end; 2016 | 2017 | destructor TMQTTPacket.Destroy; 2018 | begin 2019 | Msg.Free; 2020 | inherited; 2021 | end; 2022 | 2023 | { TMQTTMessage } 2024 | 2025 | procedure TMQTTMessage.Assign (From: TMQTTMessage); 2026 | begin 2027 | ID := From.ID; 2028 | Stamp := From.Stamp; 2029 | LastUsed := From.LastUsed; 2030 | Retained := From.Retained; 2031 | Counter := From.Counter; 2032 | Retries := From.Retries; 2033 | Topic := From.Topic; 2034 | Message := From.Message; 2035 | Qos := From.Qos; 2036 | end; 2037 | 2038 | constructor TMQTTMessage.Create; 2039 | begin 2040 | ID := 0; 2041 | Stamp := Now; 2042 | LastUsed := Stamp; 2043 | Retained := false; 2044 | Counter := 0; 2045 | Retries := 0; 2046 | Qos := qtAT_MOST_ONCE; 2047 | Topic := ''; 2048 | Message := ''; 2049 | end; 2050 | 2051 | destructor TMQTTMessage.Destroy; 2052 | begin 2053 | inherited; 2054 | end; 2055 | 2056 | { TMQTTMessageStore } 2057 | 2058 | function TMQTTMessageStore.AddMsg (anID: Word; aTopic : UTF8String; aMessage : AnsiString; aQos : TMQTTQOSType; 2059 | aRetry, aCount: cardinal; aRetained : Boolean) : TMQTTMessage; 2060 | begin 2061 | Result := TMQTTMessage.Create; 2062 | Result.ID := anID; 2063 | Result.Topic := aTopic; 2064 | Result.Message := aMessage; 2065 | Result.Qos := aQos; 2066 | Result.Counter := aCount; 2067 | Result.Retries := aRetry; 2068 | Result.Retained := aRetained; 2069 | List.Add (Result); 2070 | end; 2071 | 2072 | procedure TMQTTMessageStore.Assign (From: TMQTTMessageStore); 2073 | var 2074 | i : integer; 2075 | aMsg, bMsg : TMQTTMessage; 2076 | begin 2077 | Clear; 2078 | for i := 0 to From.Count - 1 do 2079 | begin 2080 | aMsg := From[i]; 2081 | bMsg := TMQTTMessage.Create; 2082 | bMsg.Assign (aMsg); 2083 | List.Add (bMsg); 2084 | end; 2085 | end; 2086 | 2087 | procedure TMQTTMessageStore.Clear; 2088 | var 2089 | i : integer; 2090 | begin 2091 | for i := 0 to List.Count - 1 do 2092 | TMQTTMessage (List[i]).Free; 2093 | List.Clear; 2094 | end; 2095 | 2096 | function TMQTTMessageStore.Count: integer; 2097 | begin 2098 | Result := List.Count; 2099 | end; 2100 | 2101 | constructor TMQTTMessageStore.Create; 2102 | begin 2103 | Stamp := Now; 2104 | List := TList.Create; 2105 | end; 2106 | 2107 | procedure TMQTTMessageStore.DelMsg (anID: Word); 2108 | var 2109 | i : integer; 2110 | aMsg : TMQTTMessage; 2111 | begin 2112 | for i := List.Count - 1 downto 0 do 2113 | begin 2114 | aMsg := List[i]; 2115 | if aMsg.ID = anID then 2116 | begin 2117 | List.Remove (aMsg); 2118 | aMsg.Free; 2119 | exit; 2120 | end; 2121 | end; 2122 | end; 2123 | 2124 | destructor TMQTTMessageStore.Destroy; 2125 | begin 2126 | Clear; 2127 | List.Free; 2128 | inherited; 2129 | end; 2130 | 2131 | function TMQTTMessageStore.GetItem (Index: Integer): TMQTTMessage; 2132 | begin 2133 | if (Index >= 0) and (Index < Count) then 2134 | Result := List[Index] 2135 | else 2136 | Result := nil; 2137 | end; 2138 | 2139 | function TMQTTMessageStore.GetMsg (anID: Word): TMQTTMessage; 2140 | var 2141 | i : integer; 2142 | begin 2143 | for i := 0 to List.Count - 1 do 2144 | begin 2145 | Result := List[i]; 2146 | if Result.ID = anID then exit; 2147 | end; 2148 | Result := nil; 2149 | end; 2150 | 2151 | procedure TMQTTMessageStore.Remove (aMsg: TMQTTMessage); 2152 | begin 2153 | List.Remove (aMsg); 2154 | end; 2155 | 2156 | procedure TMQTTMessageStore.SetItem (Index: Integer; const Value: TMQTTMessage); 2157 | begin 2158 | if (Index >= 0) and (Index < Count) then 2159 | List[Index] := Value; 2160 | end; 2161 | 2162 | { TMQTTSession } 2163 | 2164 | constructor TMQTTSession.Create; 2165 | begin 2166 | ClientID := ''; 2167 | Stamp := Now; 2168 | InFlight := TMQTTPacketStore.Create; 2169 | Releasables := TMQTTMessageStore.Create; 2170 | end; 2171 | 2172 | destructor TMQTTSession.Destroy; 2173 | begin 2174 | InFlight.Clear; 2175 | InFlight.Free; 2176 | Releasables.Clear; 2177 | Releasables.Free; 2178 | inherited; 2179 | end; 2180 | 2181 | { TMQTTSessionStore } 2182 | 2183 | procedure TMQTTSessionStore.Clear; 2184 | var 2185 | i : integer; 2186 | begin 2187 | for i := 0 to List.Count - 1 do 2188 | TMQTTSession (List[i]).Free; 2189 | List.Clear; 2190 | end; 2191 | 2192 | function TMQTTSessionStore.Count: integer; 2193 | begin 2194 | Result := List.Count; 2195 | end; 2196 | 2197 | constructor TMQTTSessionStore.Create; 2198 | begin 2199 | Stamp := Now; 2200 | List := TList.Create; 2201 | end; 2202 | 2203 | procedure TMQTTSessionStore.DeleteSession (ClientID: UTF8String); 2204 | var 2205 | aSession : TMQTTSession; 2206 | begin 2207 | aSession := GetSession (ClientID); 2208 | if aSession <> nil then 2209 | begin 2210 | List.Remove (aSession); 2211 | aSession.Free; 2212 | end; 2213 | end; 2214 | 2215 | destructor TMQTTSessionStore.Destroy; 2216 | begin 2217 | Clear; 2218 | List.Free; 2219 | inherited; 2220 | end; 2221 | 2222 | function TMQTTSessionStore.GetItem (Index: Integer): TMQTTSession; 2223 | begin 2224 | if (Index >= 0) and (Index < Count) then 2225 | Result := List[Index] 2226 | else 2227 | Result := nil; 2228 | end; 2229 | 2230 | function TMQTTSessionStore.GetSession (ClientID: UTF8String): TMQTTSession; 2231 | var 2232 | i : integer; 2233 | begin 2234 | for i := 0 to List.Count - 1 do 2235 | begin 2236 | Result := List[i]; 2237 | if Result.ClientID = ClientID then exit; 2238 | end; 2239 | Result := nil; 2240 | end; 2241 | 2242 | procedure TMQTTSessionStore.RestoreSession (ClientID: UTF8String; 2243 | aClient: TClient); 2244 | var 2245 | aSession : TMQTTSession; 2246 | begin 2247 | aClient.InFlight.Clear; 2248 | aClient.Releasables.Clear; 2249 | aSession := GetSession (ClientID); 2250 | if aSession <> nil then 2251 | begin 2252 | aClient.InFlight.Assign (aSession.InFlight); 2253 | aClient.Releasables.Assign (aSession.Releasables); 2254 | end; 2255 | end; 2256 | 2257 | procedure TMQTTSessionStore.RestoreSession (ClientID: UTF8String; 2258 | aClient: TMQTTClient); 2259 | var 2260 | aSession : TMQTTSession; 2261 | begin 2262 | aClient.InFlight.Clear; 2263 | aClient.Releasables.Clear; 2264 | aSession := GetSession (ClientID); 2265 | if aSession <> nil then 2266 | begin 2267 | aClient.InFlight.Assign (aSession.InFlight); 2268 | aClient.Releasables.Assign (aSession.Releasables); 2269 | end; 2270 | end; 2271 | 2272 | procedure TMQTTSessionStore.StoreSession (ClientID: UTF8String; 2273 | aClient: TMQTTClient); 2274 | var 2275 | aSession : TMQTTSession; 2276 | begin 2277 | aSession := GetSession (ClientID); 2278 | if aSession <> nil then 2279 | begin 2280 | aSession := TMQTTSession.Create; 2281 | aSession.ClientID := ClientID; 2282 | List.Add (aSession); 2283 | end; 2284 | 2285 | aSession.InFlight.Assign (aClient.InFlight); 2286 | aSession.Releasables.Assign (aClient.Releasables); 2287 | end; 2288 | 2289 | procedure TMQTTSessionStore.StoreSession (ClientID: UTF8String; 2290 | aClient: TClient); 2291 | var 2292 | aSession : TMQTTSession; 2293 | begin 2294 | aClient.InFlight.Clear; 2295 | aClient.Releasables.Clear; 2296 | aSession := GetSession (ClientID); 2297 | if aSession <> nil then 2298 | begin 2299 | aSession := TMQTTSession.Create; 2300 | aSession.ClientID := ClientID; 2301 | List.Add (aSession); 2302 | end; 2303 | aSession.InFlight.Assign (aClient.InFlight); 2304 | aSession.Releasables.Assign (aClient.Releasables); 2305 | end; 2306 | 2307 | procedure TMQTTSessionStore.SetItem (Index: Integer; const Value: TMQTTSession); 2308 | begin 2309 | if (Index >= 0) and (Index < Count) then 2310 | List[Index] := Value; 2311 | end; 2312 | 2313 | end. 2314 | --------------------------------------------------------------------------------