01
' Copyright (C) 2004 - 2006 db4objects Inc. http://www.db4o.com
02
Imports System
03
Imports System.Collections
04
Imports Db4objects.Db4o
05
Imports Db4objects.Db4o.Config
06
Imports Db4objects.Db4o.Ext
07
Imports Db4objects.Db4o.Query
08
09
10
Namespace Db4objectsNamespace Db4objects.Db4odoc.Semaphores
11
'
12
' This class demonstrates how semaphores can be used
13
' to rule race conditions when providing exact and
14
' up-to-date information about all connected clients
15
' on a server. The class also can be used to make sure
16
' that only one login is possible with a give user name
17
' and ipAddress combination.
18
'
19
Public Class ConnectedUserClass ConnectedUser
20
21
Public Shared ReadOnly SEMAPHORE_CONNECTED As String = "ConnectedUser_"
22
Public Shared ReadOnly SEMAPHORE_LOCK_ACCESS As String = "ConnectedUser_Lock_"
23
24
Public Shared ReadOnly TIMEOUT As Integer = 10000 ' concurrent access timeout 10 seconds
25
26
Dim userName As String
27
Dim ipAddress As String
28
29
Public Sub New()Sub New(ByVal userName As String, ByVal ipAddress As String)
30
Me.userName = userName
31
Me.ipAddress = ipAddress
32
End Sub
33
34
' make sure to call this on the server before opening the database
35
' to improve querying speed
36
Public Shared Sub Configure()Sub Configure()
37
Dim objectClass As IObjectClass = Db4oFactory.Configure().ObjectClass(GetType(ConnectedUser))
38
objectClass.ObjectField("userName").Indexed(True)
39
objectClass.ObjectField("ipAddress").Indexed(True)
40
End Sub
41
42
' call this on the client to ensure to have a ConnectedUser record
43
' in the database file and the semaphore set
44
Public Shared Sub Login()Sub Login(ByVal client As IObjectContainer, ByVal userName As String, ByVal ipAddress As String)
45
If Not client.Ext().SetSemaphore(SEMAPHORE_LOCK_ACCESS, TIMEOUT) Then
46
Throw New Exception("Timeout Trying to get access to ConnectedUser lock")
47
End If
48
Dim q As IQuery = client.Query()
49
q.Constrain(GetType(ConnectedUser))
50
q.Descend("userName").Constrain(userName)
51
q.Descend("ipAddress").Constrain(ipAddress)
52
If q.Execute().Size() = 0 Then
53
client.Set(New ConnectedUser(userName, ipAddress))
54
client.Commit()
55
End If
56
Dim connectedSemaphoreName As String = SEMAPHORE_CONNECTED + userName + ipAddress
57
Dim unique As Boolean = client.Ext().SetSemaphore(connectedSemaphoreName, 0)
58
client.Ext().ReleaseSemaphore(SEMAPHORE_LOCK_ACCESS)
59
If Not unique Then
60
Throw New Exception("Two clients with same userName and ipAddress")
61
End If
62
End Sub
63
64
' here is your list of all connected users, callable on the server
65
Public Shared Function ConnectedUsers()Function ConnectedUsers(ByVal server As IObjectServer) As IList
66
Dim serverObjectContainer As IExtObjectContainer = server.Ext().ObjectContainer().Ext()
67
If serverObjectContainer.SetSemaphore(SEMAPHORE_LOCK_ACCESS, TIMEOUT) Then
68
Throw New Exception("Timeout Trying to get access to ConnectedUser lock")
69
End If
70
Dim list As IList = New ArrayList()
71
Dim q As IQuery = serverObjectContainer.Query()
72
q.Constrain(GetType(ConnectedUser))
73
Dim objectSet As IObjectSet = q.Execute()
74
While objectSet.HasNext()
75
Dim connectedUser As ConnectedUser = CType(objectSet.Next(), ConnectedUser)
76
Dim connectedSemaphoreName As String = SEMAPHORE_CONNECTED + connectedUser.userName + connectedUser.ipAddress
77
If serverObjectContainer.SetSemaphore(connectedSemaphoreName, TIMEOUT) Then
78
serverObjectContainer.Delete(connectedUser)
79
Else
80
list.Add(connectedUser)
81
End If
82
End While
83
serverObjectContainer.Commit()
84
serverObjectContainer.ReleaseSemaphore(SEMAPHORE_LOCK_ACCESS)
85
Return list
86
End Function
87
End Class
88
End Namespace