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