Imports System.DirectoryServices Imports System.IO Imports System.Reflection Imports CICRadarR.SMS Imports CICRadarR.LogFile Imports System.Security.Cryptography Imports System.Text Imports System Imports System.Net.Mail Public Class CICRadarR Public Shared LDAPDomain As String = "" Public Shared ADField As String = "" Public Shared ADMailField As String = "" ' TODO: What this? Public Shared encCode As String = "gewsyy#sjs2!" Private DEBUG As Boolean Public Shared EnableOTP As Boolean Private Log As New LogWriter Private UserAccessLog As New LogWriter Private secrets As NASAuthList Private radius1812 As RADIUSServer Private radius1645 As RADIUSServer Private userHash As New Hashtable Private packetHash As New Hashtable Private clientHash As New Hashtable Private NetBiosDomain As String = "" Private Provider As String = "" Private ModemType As String = "" Private ComPort As String = "" Private SmsC As String = "" Private MailServer As String = "" Private SenderEmail As String = "" Private TSGW As String = "" Private TSGWSessionIdHash As New Hashtable Private TSGWSessionIdTimeStampHash As New Hashtable Private TSGWLaunchIdTimeStampHash As New Hashtable Private TSGWFirstLoginHash As New Hashtable ' Ensure that only one sms is send even if radius need to re-authenticate. Private TSGWFirstLoginTimeStampHash As New Hashtable ' Ensure that only one sms is send even if radius need to re-authenticate. Public Shared SessionTimeOut As Integer = 30 ' in minutes Private LaunchTimeOut As Integer = 30 ' in seconds Private EnableSMS As Boolean = False Private EnableEmail As Boolean = False Protected Overrides Sub OnStart(ByVal args() As String) Log.filePath = ApplicationPath() & "\log.txt" UserAccessLog.filePath = ApplicationPath() & "\UserAccessLog.txt" Log.WriteLog("---------------------------------------------------------------------------------------------------") ServerLog("Starting Service") ServerLog("Loading Configuration...") Call loadConfiguration() ServerLog("Starting Radius listner ports...") Call StartUpServer() End Sub Public Sub OnstartTest() Log.filePath = ApplicationPath() & "\log.txt" UserAccessLog.filePath = ApplicationPath() & "\UserAccessLog.txt" ServerLog("---------------------------------------------------------------------------------------------------") ServerLog("Starting Service") ServerLog("Loading Configuration...") Call loadConfiguration() ServerLog("Starting Radius listner ports...") Call StartUpServer() End Sub Protected Overrides Sub OnStop() ServerLog("Stopping Radius listner ports...") End Sub Public Sub OnStopTest() ServerLog("Stopping Radius listner ports...") End Sub Public Sub StartUpServer() ' First, let's load a list of RADIUS shared secrets ' in a NASAuthList object (a glorified Dictionary, basically) secrets = New NASAuthList ' Populate from DB, I suppose ... For Each cl As DictionaryEntry In clientHash ServerLog("Adding Shared Secret to Radius Server") secrets.AddSharedSecret(cl.Key, cl.Value) Next ' Then, we just create a RADIUS server ... Try radius1812 = New RADIUSServer(1812, AddressOf ProcessPacket1812, secrets) ServerLog("Starting Radius Server on Port 1812...OK") Catch ServerLog("Starting Radius Server on Port 1812...FAILED") End Try Try radius1645 = New RADIUSServer(1645, AddressOf ProcessPacket1645, secrets) ServerLog("Starting Radius Server on Port 1645...OK") Catch ServerLog("Starting Radius Server on Port 1645...FAILED") End Try End Sub ' Every valid RADIUS request generated by the server(s) we created earlier ' will fire up the callback procedure. Invalid requests are dropped, per RFC. Private Sub ProcessPacket1812(ByVal packet As RADIUSPacket) 'Console.WriteLine("packet " & Now) If packet.IsValid Then ProcessPacket(radius1812, packet) Else Console.WriteLine("Packet is not valid. Dropping.") End If End Sub Private Sub ProcessPacket1645(ByVal packet As RADIUSPacket) If packet.IsValid Then ProcessPacket(radius1645, packet) Else Console.WriteLine("Packet is not valid. Dropping.") End If End Sub Private Sub AccessLog(ByVal message) If DEBUG = True Then UserAccessLog.WriteLog(Now & ": DEBUG: " & message) End If End Sub Private Sub ServerLog(ByVal message) Log.WriteLog(Now & ":" & message) End Sub Private Sub ProcessPacket(ByVal server As RADIUSServer, ByVal packet As RADIUSPacket) Dim muuh As New VendorSpecificAttribute(VendorSpecificType.Generic, "LAUNCH") Dim atts As New RADIUSAttributes muuh.SetRADIUSAttribute(atts) If TSGW = "1" Then Dim rds As New RDSHandler(packet) rds.ProcessRequest() 'ProcessPacketTSGW(server, packet) Else ProcessPacketCSG(server, packet) End If End Sub Sub ProcessPacketTSGW(ByVal server As RADIUSServer, ByVal packet As RADIUSPacket) ' Let's take a look at just authentication requests, ' and drop other requests silently ... If packet.Code <> RadiusPacketCode.AccessRequest Then AccessLog("Not a valid radius packet.. Drop!") Exit Sub End If AccessLog("Radius packet recived") Dim LaunchApp As String = "" Dim launchTSGW As String = "" If packet.Attributes.AttributeExists(RadiusAttributeType.VendorSpecific) Then Dim VSAtt As RADIUSAttribute = packet.Attributes.GetFirstAttribute(RadiusAttributeType.VendorSpecific) Dim VSAtts As RADIUSAttributes = packet.Attributes.GetAllAttributes(RadiusAttributeType.VendorSpecific) For Each atts As RADIUSAttribute In VSAtts 'Dim opt As String = atts.GetHex().Trim 'Console.WriteLine(atts.GetVendorSpecific.VendorValue.ToString) 'Select Case opt ' Case "4C 41 55 4E 43 48" ' ok, I was lasy. Need to write code to resolve value in (26) Vendor specific. ' LaunchApp = "LAUNCH" ' Case "00 00 01 37 2F 06 00 00 00 01" ' launchTSGW = "LAUNCH" 'End Select 'Console.WriteLine(atts.GetHex()) Dim opt As String = atts.GetVendorSpecific.VendorValue.ToString Select Case UCase(opt) Case "LAUNCH" LaunchApp = "LAUNCH" Case "TSGATEWAY" launchTSGW = "LAUNCH" End Select Next ' LaunchApp = VSAtt.GetString End If ' Let's see if we have a username present ... Dim username As RADIUSAttribute = packet.Attributes.GetFirstAttribute(RadiusAttributeType.UserName) Dim pass As RADIUSAttribute = packet.Attributes.GetFirstAttribute(RadiusAttributeType.UserPassword) If LaunchApp = "LAUNCH" Then Dim sRadiusSessionId = packet.UserPassword Dim SessionId_Ok As Boolean = False Dim sUserName As String = username.ToString.ToLower AccessLog("RDWeb app launch: Checking token validity of user: " & sUserName) If TSGWSessionIdHash.Contains(sUserName) And TSGWSessionIdTimeStampHash.Contains(sUserName) Then Dim hashTime As DateTime = DirectCast(TSGWSessionIdTimeStampHash(sUserName), DateTime) Dim tValid = DateDiff(DateInterval.Minute, hashTime, Now) If tValid < SessionTimeOut Then ' check session id If sRadiusSessionId = DirectCast(TSGWSessionIdHash(sUserName), String) Then ' Session id match SessionId_Ok = True If TSGWLaunchIdTimeStampHash.Contains(sUserName) Then TSGWLaunchIdTimeStampHash(sUserName) = Now Else TSGWLaunchIdTimeStampHash.Add(sUserName, Now) End If End If End If End If If SessionId_Ok Then packet.AcceptAccessRequest() Else packet.RejectAccessRequest() End If ElseIf launchTSGW = "LAUNCH" Then Dim sRadiusSessionId = packet.UserPassword Dim attributes As New RADIUSAttributes Dim proxyState As String Dim LaunchId_Ok As Boolean = False Dim sUserName As String = username.ToString.ToLower AccessLog("TSGateway Connection checking token validity of user: " & sUserName) Dim existProxyState As Boolean = packet.Attributes.AttributeExists(RadiusAttributeType.ProxyState) If existProxyState = True Then proxyState = packet.Attributes.GetFirstAttribute(RadiusAttributeType.ProxyState).ToString AccessLog("Packet contains a state attribute ProxyState=" & proxyState) attributes.Add(packet.Attributes.GetFirstAttribute(RadiusAttributeType.ProxyState)) End If 'Check launchHash to see if user hash a valid launch window (default 30 sec.) If TSGWLaunchIdTimeStampHash.Contains(sUserName) = True Then ' user has a launch id lets check if it valid Dim hashTime As DateTime = DirectCast(TSGWLaunchIdTimeStampHash(sUserName), DateTime) Dim tValid = DateDiff(DateInterval.Second, hashTime, Now) If tValid < LaunchTimeOut Then AccessLog("User " & sUserName & " has valid token.") LaunchId_Ok = True ' Launch ok now add launch hash key TSGWLaunchIdTimeStampHash.Remove(sUserName) Else AccessLog("Token of " & sUserName & " timed out.") End If Else AccessLog(sUserName & " has no entry in db.") End If If LaunchId_Ok Then ' found match in hash table' Return ok packet.AcceptAccessRequest(attributes) Else packet.RejectAccessRequest() End If Else Dim sid As String = "" Dim mobile As String = "" Dim email As String = "" Dim smsCode As String = "" ' If an attribute of a particular type is not found, the function ' will return Nothing. If username Is Nothing Then ' Technically, this case is against RFC, so ... drop. AccessLog("Not a valid radius packet.. No username present.. Drop!") Exit Sub End If AccessLog("Processing packet for user: " & username.ToString) Dim existState As Boolean = packet.Attributes.AttributeExists(RadiusAttributeType.State) Dim existProxyState As Boolean = packet.Attributes.AttributeExists(RadiusAttributeType.ProxyState) If existState = True Then ' Ok we have at packet with the State attribute set. Check if we can identify the authtentication packet. (User provides the sms token) Dim state As String Dim proxyState As String state = packet.Attributes.GetFirstAttribute(RadiusAttributeType.State).ToString AccessLog("Packet contains a state attribute State=" & state) If existProxyState = True Then proxyState = packet.Attributes.GetFirstAttribute(RadiusAttributeType.ProxyState).ToString AccessLog("Packet contains a state attribute State=" & proxyState) End If Dim UserDomain As String = "" 'lets see if user login using upd or UPN name Dim sUserName As String = username.ToString.ToLower Dim sPassword As String = packet.UserPassword AccessLog("SMSToken supplied by user: " & sUserName) sid = "" If InStr(sUserName, "@") > 0 Then 'UPN UserDomain = sUserName Else 'UPD 'read domain from Hashtable UserDomain = sUserName End If sid = EncDec.Encrypt(UserDomain & "_" & packet.UserPassword, encCode) Dim attributes As New RADIUSAttributes AccessLog("Checking for userHash " & sid) If sid = state Then ' All good allow user access to the Web Interface AccessLog("State and Sid match. Sending accept packet to Netscaler") If existProxyState = True Then attributes.Add(packet.Attributes.GetFirstAttribute(RadiusAttributeType.ProxyState)) End If Dim sGUID As String sGUID = System.Guid.NewGuid.ToString() ' Add the user and guid to the access master list. This hash will be chech each time an application is launched. This prevents access through TS gateway without going through the Webinterface first. If TSGWSessionIdHash.Contains(UserDomain) Then TSGWSessionIdHash(UserDomain) = sGUID Else TSGWSessionIdHash.Add(UserDomain, sGUID) End If If TSGWSessionIdTimeStampHash.Contains(UserDomain) Then TSGWSessionIdTimeStampHash(UserDomain) = Now Else TSGWSessionIdTimeStampHash.Add(UserDomain, Now) End If Dim guidAttribute As New RADIUSAttribute(RadiusAttributeType.ReplyMessage, sGUID) attributes.Add(guidAttribute) packet.AcceptAccessRequest(attributes) Else packet.RejectAccessRequest() End If If TSGWFirstLoginTimeStampHash.Contains(UserDomain) Then ' Clean first login hash table TSGWFirstLoginTimeStampHash.Remove(UserDomain) TSGWFirstLoginHash.Remove(UserDomain) End If Else ' process the first login (sending sms token) 'Now lets get some information from ad if password is valid Dim success As Boolean = False Dim UserDomain As String = "" 'lets see if user login using upd or UPN name Dim sUserName As String = username.ToString.ToLower Dim sPassword As String = packet.UserPassword If InStr(sUserName, "@") > 0 Then 'UPN UserDomain = sUserName Else 'UPD 'read domain from Hashtable ' UserDomain = NetBiosDomain & "\" & sUserName UserDomain = sUserName End If AccessLog("User " & UserDomain & " is trying to log in ...") Try Dim dirEntry As New DirectoryEntry("LDAP://" & LDAPDomain, UserDomain, sPassword) Dim obj As Object = dirEntry.NativeObject Dim search As New DirectorySearcher(dirEntry) If InStr(sUserName, "@") > 0 Then search.Filter = "(userPrincipalName=" + sUserName + ")" Else search.Filter = "(SAMAccountName=" + Split(sUserName, "\")(1) + ")" End If 'Load the Properties we need from AD search.PropertiesToLoad.Add("distinguishedName") 'search.PropertiesToLoad.Add("primaryTelexNumber") If EnableOTP = True Then search.PropertiesToLoad.Add(ADField) search.PropertiesToLoad.Add(ADMailField) End If ' Time to find out if user entered the correct username and pasword AccessLog("Authenticating: LDAPPAth: " & "LDAP://" & LDAPDomain & ", Username: " & UserDomain) Dim result As SearchResult = search.FindOne() 'Get the setting form AD. Yes we uses the field primaryTelexNumber, for who the f... still users telex. (I bet half the people reading this code don't even know what a telex is!) 'Dim code As String = DirectCast(result.Properties("primaryTelexNumber")(0), String) 'Dim aCode As String() = code.Split("/") 'Dim userLdap As String = "LDAP://" & LDAPPath & "/" & result.Properties("distinguishedName")(0) 'Dim userEntry As New DirectoryEntry(userLdap, UserDomain, sPassword) If EnableOTP = True Then ' smsCode = GenerateCode() ' REMEMBER to put at check for empty phone string Try If EnableSMS = True Then mobile = DirectCast(result.Properties(ADField)(0), String) mobile = Replace(mobile, "+", "") If mobile.Trim.Length = 0 Then success = False AccessLog("Unable to find correct phone number for user " & UserDomain) Else success = True End If End If If EnableEmail = True Then email = DirectCast(result.Properties(ADMailField)(0), String) If InStr(email, "@") = 0 Then success = False AccessLog("Unable to find correct email for user " & UserDomain) Else success = True End If End If Catch AccessLog("Unable to find correct phone number or email for user " & UserDomain) success = False End Try ' sid = EncDec.Encrypt(UserDomain & "_" & smsCode, encCode) 'generate unique code Else End If ' sid = UserDomain & "_" & smsCode 'userEntry.Properties("primaryTelexNumber").Value = aCode(0) & "/" & smsCode & "/" & aCode(2) & "/" & aCode(3) 'userEntry.CommitChanges() 'userEntry.Dispose() If 1 = 1 Then ' check if smscode is disabled for the user (Need to write this code) 'If userHash.ContainsKey(sid) Then ' userHash(sid) = sPassword ' If DEBUG = True Then ' AccessLog("Updating userHash " & sid) ' End If 'Else ' userHash.Add(sid, sPassword) ' If DEBUG = True Then ' AccessLog("Adding userHash " & sid) ' End If 'End If ' new code stored in AD now send it to the users phone ' Console.WriteLine(smsCode) success = True Else success = False End If Catch AccessLog("Failed to authenticate user against Active Directory using the following parameters: " & "LDAPPAth: " & "LDAP://" & LDAPDomain & ", Username: " & UserDomain & ", Password: " & sPassword) success = False End Try Dim attributes As New RADIUSAttributes If success Then ' Yay! Someone guess the password ... Dim sendType As String = "" AccessLog("User " & UserDomain & " authenticated against Active Directory") If EnableOTP = True Then If packet.Attributes.AttributeExists(RadiusAttributeType.VendorSpecific) Then Dim VSAtts As RADIUSAttributes = packet.Attributes.GetAllAttributes(RadiusAttributeType.VendorSpecific) For Each atts As RADIUSAttribute In VSAtts Dim opt As String = atts.GetVendorSpecific.VendorValue.ToString Select Case UCase(opt) Case "SMS" sendType = "SMS" Case "EMAIL" sendType = "EMAIL" End Select Next Else sendType = "SMS" End If If TSGWFirstLoginTimeStampHash.Contains(UserDomain) Then Dim hTime As DateTime = DirectCast(TSGWFirstLoginTimeStampHash(UserDomain), DateTime) Dim tValid = DateDiff(DateInterval.Second, hTime, Now) If tValid >= 5 Then TSGWFirstLoginTimeStampHash.Remove(UserDomain) TSGWFirstLoginHash.Remove(UserDomain) End If End If If TSGWFirstLoginHash.Contains(UserDomain) Then sid = TSGWFirstLoginHash(UserDomain).ToString AccessLog("Access token already send to phonenumber " & mobile) Else smsCode = GenerateCode() sid = EncDec.Encrypt(UserDomain & "_" & smsCode, encCode) 'generate unique code AccessLog("Sending access token: " & smsCode & " to phonenumber " & mobile) TSGWFirstLoginHash.Add(UserDomain, sid) TSGWFirstLoginTimeStampHash.Add(UserDomain, Now) If sendType = "SMS" Then Call SendSMS(mobile, smsCode) Else Call SendEmail(email, smsCode) End If End If Dim attr As New RADIUSAttribute(RadiusAttributeType.ReplyMessage, "SMS Token") Dim state As New RADIUSAttribute(RadiusAttributeType.State, sid) attributes.Add(attr) attributes.Add(state) packet.SendAccessChallenge(attributes) Else ' One time Password not enabled, so we let the user in ' add session key so user can access applications. Dim sGUID As String sGUID = System.Guid.NewGuid.ToString() If TSGWSessionIdHash.Contains(UserDomain) Then TSGWSessionIdHash(UserDomain) = sGUID Else TSGWSessionIdHash.Add(UserDomain, sGUID) End If If TSGWSessionIdTimeStampHash.Contains(UserDomain) Then TSGWSessionIdTimeStampHash(UserDomain) = Now Else TSGWSessionIdTimeStampHash.Add(UserDomain, Now) End If Dim guidAttribute As New RADIUSAttribute(RadiusAttributeType.ReplyMessage, sGUID) attributes.Add(guidAttribute) packet.AcceptAccessRequest(attributes) End If ' packetHash.Remove(username.GetString & "_" & pass.GetString) Else AccessLog("User " & UserDomain & " failed to authenticate against Active Directory") packet.RejectAccessRequest() End If End If End If End Sub Private Sub ProcessPacketCSG(ByVal server As RADIUSServer, ByVal packet As RADIUSPacket) ' Let's take a look at just authentication requests, ' and drop other requests silently ... If packet.Code <> RadiusPacketCode.AccessRequest Then AccessLog("Not a valid radius packet.. Drop!") Exit Sub End If ' Let's see if we have a username present ... Dim username As RADIUSAttribute = packet.Attributes.GetFirstAttribute(RadiusAttributeType.UserName) Dim pass As RADIUSAttribute = packet.Attributes.GetFirstAttribute(RadiusAttributeType.UserPassword) Dim sid As String = "" Dim mobile As String = "" Dim smsCode As String = "" Dim UserEmail As String = "" ' If an attribute of a particular type is not found, the function ' will return Nothing. If username Is Nothing Then ' Technically, this case is against RFC, so ... drop. AccessLog("Not a valid radius packet.. No username pressent.. Drop!") Exit Sub End If AccessLog("Processing packet for user: " & username.ToString) 'If packetHash.ContainsKey(username.GetString & "_" & pass.GetString) Then ' Exit Sub 'End If Dim existState As Boolean = packet.Attributes.AttributeExists(RadiusAttributeType.State) AccessLog("Packet contains a state attribute? State=" & existState.ToString) If existState = True Then ' Ok we have at packet with the State attribute set. Check if we can identify the authtentication packet. Dim state As String = packet.Attributes.GetFirstAttribute(RadiusAttributeType.State).ToString AccessLog("Packet contains a state attribute State=" & state) Dim UserDomain As String = "" 'lets see if user login using upd or UPN name Dim sUserName As String = username.ToString Dim sPassword As String = packet.UserPassword AccessLog("SMSToken supplied by user: " & sUserName) sid = "" If InStr(sUserName, "@") > 0 Then 'UPN UserDomain = sUserName Else 'UPD 'read domain from Hashtable UserDomain = NetBiosDomain & "\" & sUserName End If sid = EncDec.Encrypt(UserDomain & "_" & packet.UserPassword, encCode) AccessLog("Checking for userHash " & sid) If sid = state Then packet.AcceptAccessRequest() Else packet.RejectAccessRequest() End If Else ' process the first login ' packetHash.Add(username.GetString & "_" & pass.GetString, 0) ' Console.WriteLine(username.GetString & " is trying to log in ... ") ' Note that an attribute can represent a string, number, IP, etc. ' RADAR will not guess that automatically, so use the appropriate ' function according to the attribute you're trying to read. Otherwise, ' the Value property is just a bunch of bytes as received in the ' RADIUS packet. 'Now lets get some information from ad if password is valid Dim success As Boolean = False Dim UserDomain As String = "" 'lets see if user login using upd or UPN name Dim sUserName As String = username.ToString Dim sPassword As String = packet.UserPassword If InStr(sUserName, "@") > 0 Then 'UPN UserDomain = sUserName Else 'UPD 'read domain from Hashtable UserDomain = NetBiosDomain & "\" & sUserName End If AccessLog("User " & UserDomain & " is trying to log in ...") Try Dim dirEntry As New DirectoryEntry("LDAP://" & LDAPDomain, UserDomain, sPassword) Dim obj As Object = dirEntry.NativeObject Dim search As New DirectorySearcher(dirEntry) If InStr(sUserName, "@") > 0 Then search.Filter = "(userPrincipalName=" + sUserName + ")" Else search.Filter = "(SAMAccountName=" + sUserName + ")" End If 'Load the Properties we need from AD search.PropertiesToLoad.Add("distinguishedName") 'search.PropertiesToLoad.Add("primaryTelexNumber") If EnableOTP = True Then If EnableEmail = True Then search.PropertiesToLoad.Add(ADMailField) End If If EnableSMS = True Then search.PropertiesToLoad.Add(ADField) End If End If ' Time to find out if user entered the correct username and pasword AccessLog("Trying to authenticate user agains Active Directory using te following parameters: " & "LDAPPAth: " & "LDAP://" & LDAPDomain & ", Username: " & UserDomain & ", Password: " & sPassword) Dim result As SearchResult = search.FindOne() 'Get the setting form AD. Yes we uses the field primaryTelexNumber, for who the f... still users telex. (I bet half the people reading this code don't even know what a telex is!) 'Dim code As String = DirectCast(result.Properties("primaryTelexNumber")(0), String) 'Dim aCode As String() = code.Split("/") 'Dim userLdap As String = "LDAP://" & LDAPPath & "/" & result.Properties("distinguishedName")(0) 'Dim userEntry As New DirectoryEntry(userLdap, UserDomain, sPassword) If EnableOTP = True Then smsCode = GenerateCode() ' REMEMBER to put at check for empty phone string If EnableEmail = True Then Try UserEmail = DirectCast(result.Properties(ADMailField)(0), String) If UserEmail.Trim.Length = 0 Or InStr(UserEmail, "@") = 0 Then success = False AccessLog("Unable to find correct email for user " & UserDomain) Else success = True End If Catch AccessLog("Unable to find correct email for user " & UserDomain) success = False End Try End If If EnableSMS = True Then Try mobile = DirectCast(result.Properties(ADField)(0), String) mobile = Replace(mobile, "+", "") If mobile.Trim.Length = 0 Then success = False AccessLog("Unable to find correct phone number for user " & UserDomain) Else success = True End If Catch AccessLog("Unable to find correct phone number for user " & UserDomain) success = False End Try End If sid = EncDec.Encrypt(UserDomain & "_" & smsCode, encCode) 'generate unique code End If ' sid = UserDomain & "_" & smsCode 'userEntry.Properties("primaryTelexNumber").Value = aCode(0) & "/" & smsCode & "/" & aCode(2) & "/" & aCode(3) 'userEntry.CommitChanges() 'userEntry.Dispose() If 1 = 1 Then ' check if smscode is disabled for the user (Need to write this code) 'If userHash.ContainsKey(sid) Then ' userHash(sid) = sPassword ' If DEBUG = True Then ' AccessLog("Updating userHash " & sid) ' End If 'Else ' userHash.Add(sid, sPassword) ' If DEBUG = True Then ' AccessLog("Adding userHash " & sid) ' End If 'End If ' new code stored in AD now send it to the users phone ' Console.WriteLine(smsCode) success = True Else success = False End If Catch AccessLog("Failed to authenticate user agains Active Directory using the following parameters: " & "LDAPPAth: " & "LDAP://" & LDAPDomain & ", Username: " & UserDomain & ", Password: " & sPassword) success = False End Try Dim attributes As New RADIUSAttributes If success Then ' Yay! Someone guess the password ... AccessLog("User " & UserDomain & " authenticated agains Active Directory") If EnableOTP = True Then Dim attr As New RADIUSAttribute(RadiusAttributeType.ReplyMessage, "SMS Token") attributes.Add(attr) Dim state As New RADIUSAttribute(RadiusAttributeType.State, sid) attributes.Add(state) ' Console.WriteLine("len " & packet.Authenticator.Length.ToString) server.SendAsResponse( _ New RADIUSPacket(RadiusPacketCode.AccessChallenge, _ packet.Identifier, attributes, _ packet.EndPoint), _ packet.Authenticator) If EnableSMS = True Then AccessLog("Sending access token: " & smsCode & " to phonenumber " & mobile) Call SendSMS(mobile, smsCode) End If If EnableEmail = True Then AccessLog("Sending access token: " & smsCode & " to email " & UserEmail) Call SendEmail(UserEmail, smsCode) End If Else AccessLog("One time Password not enabled, so we let the user in") packet.AcceptAccessRequest() End If ' packetHash.Remove(username.GetString & "_" & pass.GetString) Else ' Wrong username / password ... AccessLog("User " & UserDomain & " failed to authenticate against Active Directory") Dim pk As New RADIUSPacket(RadiusPacketCode.AccessReject, packet.Identifier, Nothing, packet.EndPoint) server.SendAsResponse(pk, packet.Authenticator) ' FYI ... if no additional attributes need to be added ' to the response, you can sepcify Nothing instead of ' creating an empty RADIUSAttributes object. ' packetHash.Remove(username.GetString & "_" & pass.GetString) End If End If End Sub Public Shared Function GenerateCode() As String Dim dummy As Integer = 0 Dim ordRand As New System.Random() Dim temp As New System.Collections.ArrayList() While temp.Count < 6 dummy = ordRand.[Next](1, 9) If Not temp.Contains(dummy) Then temp.Add(dummy) End If End While Dim strVar As String = temp(0).ToString() + temp(1).ToString() + temp(2).ToString() + temp(3).ToString() + temp(4).ToString() + temp(5).ToString() Return strVar End Function Public Sub loadConfiguration() Dim ConfOk As Boolean = True Dim RConfig As New IniFile Try RConfig.Load(ApplicationPath() & "\CICRadarR.ini") DEBUG = RConfig.GetKeyValue("CICRadarR", "Debug") NetBiosDomain = RConfig.GetKeyValue("CICRadarR", "NetBiosDomain") If NetBiosDomain.Length = 0 Then ServerLog("ERROR: NetBiosDomain can not be empty") ConfOk = False End If LDAPDomain = RConfig.GetKeyValue("CICRadarR", "LDAPDomain") If LDAPDomain.Length = 0 Then ServerLog("ERROR: LDAPDomain can not be empty") ConfOk = False End If TSGW = RConfig.GetKeyValue("CICRadarR", "TSGW") EnableOTP = RConfig.GetKeyValue("CICRadarR", "EnableOTP") If EnableOTP = True Then If RConfig.GetKeyValue("CICRadarR", "EnableEmail") = "1" Then EnableEmail = True SenderEmail = RConfig.GetKeyValue("CICRadarR", "SenderEmail") MailServer = RConfig.GetKeyValue("CICRadarR", "MailServer") ADMailField = RConfig.GetKeyValue("CICRadarR", "ADMailField") End If ADField = RConfig.GetKeyValue("CICRadarR", "ADField") If ADField.Length = 0 Then ServerLog("ERROR: ADField can not be empty") ConfOk = False End If If RConfig.GetKeyValue("CICRadarR", "EnableSMS") = "1" Then EnableSMS = True ModemType = RConfig.GetKeyValue("CICRadarR", "USELOCALMODEM") Select Case ModemType Case "0" Provider = RConfig.GetKeyValue("CICRadarR", "Provider") If Provider.Length = 0 Then ServerLog("ERROR: Provider can not be empty") ConfOk = False End If Case "1" ComPort = RConfig.GetKeyValue("CICRadarR", "COMPORT") If ComPort.Length = 0 Then ServerLog("ERROR: ComPort can not be empty") ConfOk = False End If SmsC = RConfig.GetKeyValue("CICRadarR", "SMSC") If SmsC.Length = 0 Then ServerLog("ERROR: SMSC can not be empty. See http://smsclist.com/downloads/default.txt for valid values") ConfOk = False End If Case Else ServerLog("ERROR: USELOCALMODEM contain invalid configuration. Correct value are 1 or 0") ConfOk = False End Select End If End If Dim ClientList As String = "" ClientList = RConfig.GetKeyValue("CICRadarR", "ClientList") Dim ClientArray() As String ClientArray = Split(ClientList, ",") For i As Integer = 0 To ClientArray.Length - 1 ServerLog("Loading Shared Secret for Client: " & ClientArray(i)) clientHash.Add(ClientArray(i), EncDec.Decrypt(RConfig.GetKeyValue("Clients", ClientArray(i)), encCode)) Next If ConfOk = True Then ServerLog("Loading Configuration...OK") Else ServerLog("Loading Configuration...FAILED") End If Catch ServerLog("ERROR: Missing CICRadarR.ini from startup path or CICRadarR.ini contains invalid configuration") ServerLog("Loading Configuration...FAILED") End End Try End Sub Public Function ApplicationPath() As String Return Path.GetDirectoryName([Assembly].GetExecutingAssembly().Location) End Function Public Function SendSMS(ByVal number As String, ByVal passcode As String) As String ' test if using online sms provider or local modem If ModemType = 1 Then ' local modem Dim modem As New SmsClass(ComPort) modem.Opens() modem.sendSms(number, passcode, SmsC) modem.Closes() modem = Nothing Return "Ok" Else Dim baseurl As String = Provider.Split("?")(0) Dim client As New System.Net.WebClient() ' Add a user agent header in case the requested URI contains a query. client.Headers.Add("user-agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.2; .NET CLR1.0.3705;)") Dim parameters As String = Provider.Split("?")(1) Dim pary As String() = parameters.Split("&") For i As Integer = 0 To pary.Length - 1 If pary(i).IndexOf("***TEXTMESSAGE***") > 0 Then Dim qpar As String() = pary(i).Split("=") client.QueryString.Add(qpar(0), passcode) ElseIf pary(i).IndexOf("***NUMBER***") > 0 Then Dim qpar As String() = pary(i).Split("=") client.QueryString.Add(qpar(0), number) Else Dim qpar As String() = pary(i).Split("=") client.QueryString.Add(qpar(0), qpar(1)) End If Next Dim data As Stream = client.OpenRead(baseurl) Dim reader As New StreamReader(data) Dim s As String = reader.ReadToEnd() data.Close() reader.Close() Return (s) End If End Function Public Function SendEmail(email As String, passcode As String) As String Dim mail As New MailMessage() mail.To.Add(email) mail.From = New MailAddress(SenderEmail) mail.Subject = "Token: " & passcode mail.Body = "Subject contains the token code to login to you site" mail.IsBodyHtml = False Dim smtp As New SmtpClient(MailServer) Try smtp.Send(mail) If DEBUG = True Then AccessLog(Now & ": Mail send to: " & email) End If Return "SEND" Catch e As InvalidCastException If DEBUG = True Then AccessLog(Now & " : Debug: " & e.Message) AccessLog(Now & " : Unable to send mail to: " & email & " ## Check that MAILSERVER and SENDEREMAIL are configured correctly in smscode.conf. Also check that your Webinterface server is allowed to relay through the mail server specified") End If Return "FAILED" End Try End Function Private Sub TimerCleanUpHash_Elapsed(sender As System.Object, e As System.Timers.ElapsedEventArgs) Handles TimerCleanUpHash.Elapsed ' Clean Session and Launch hash for TSGW Try Dim Item As DictionaryEntry For Each Item In TSGWSessionIdTimeStampHash Dim hTime As DateTime = DirectCast(Item.Value, DateTime) Dim tValid = DateDiff(DateInterval.Minute, hTime, Now) If tValid >= SessionTimeOut Then TSGWSessionIdTimeStampHash.Remove(Item.Key) If TSGWSessionIdHash.Contains(Item.Key) Then TSGWSessionIdHash.Remove(Item.Key) End If End If Next For Each Item In TSGWLaunchIdTimeStampHash Dim hTime As DateTime = DirectCast(Item.Value, DateTime) Dim tValid = DateDiff(DateInterval.Second, hTime, Now) If tValid >= LaunchTimeOut Then TSGWLaunchIdTimeStampHash.Remove(Item.Key) End If Next Catch End Try End Sub End Class