175 lines
4.6 KiB
VB.net
175 lines
4.6 KiB
VB.net
Imports System.Reflection
|
|
Imports System.Security
|
|
Imports System.Security.Policy
|
|
Imports System.Security.Permissions
|
|
|
|
Public Class Launcher
|
|
Inherits MarshalByRefObject
|
|
|
|
Private mAppURL As String
|
|
Private mAppDir As String
|
|
Private mAppName As String
|
|
|
|
Private mGroupExisted As Boolean
|
|
|
|
Public Sub RunApp(ByVal AppURL As String)
|
|
|
|
' before we do anything, invoke the workaround
|
|
' for the serialization bug
|
|
SerializationWorkaround()
|
|
|
|
Try
|
|
' get and parse the URL for the app we are
|
|
' launching
|
|
mAppURL = AppURL
|
|
mAppDir = GetAppDirectory(mAppURL)
|
|
mAppName = GetAppName(mAppURL)
|
|
|
|
' TODO: MAKE SURE TO TIGHTEN SECURITY BEFORE USING!!!!
|
|
' see http://www.lhotka.net/Articles.aspx?id=2f5a8115-b425-4aa1-bae2-b8f80766ecb3
|
|
SetSecurity()
|
|
|
|
' load the assembly into our AppDomain
|
|
Dim asm As [Assembly]
|
|
asm = [Assembly].LoadFrom(AppURL)
|
|
|
|
' run the program by invoking its entry point
|
|
asm.EntryPoint.Invoke(asm.EntryPoint, Nothing)
|
|
|
|
Finally
|
|
RemoveSecurity()
|
|
End Try
|
|
|
|
End Sub
|
|
|
|
#Region " Serialization bug workaround "
|
|
|
|
Private Sub SerializationWorkaround()
|
|
|
|
' hook up the AssemblyResolve
|
|
' event so deep serialization works properly
|
|
' this is a workaround for a bug in the .NET runtime
|
|
Dim currentDomain As AppDomain = AppDomain.CurrentDomain
|
|
|
|
AddHandler currentDomain.AssemblyResolve, _
|
|
AddressOf ResolveEventHandler
|
|
|
|
End Sub
|
|
|
|
Private Function ResolveEventHandler(ByVal sender As Object, ByVal args As ResolveEventArgs) As [Assembly]
|
|
|
|
' get a list of all the assemblies loaded in our appdomain
|
|
Dim list() As [Assembly] = AppDomain.CurrentDomain.GetAssemblies()
|
|
|
|
' search the list to find the assemby that was not found automatically
|
|
' and return the assembly from the list
|
|
Dim asm As [Assembly]
|
|
|
|
For Each asm In list
|
|
If asm.FullName = args.Name Then
|
|
Return asm
|
|
End If
|
|
Next
|
|
|
|
End Function
|
|
|
|
#End Region
|
|
|
|
#Region " SetSecurity to FullTrust "
|
|
|
|
Private Sub SetSecurity()
|
|
|
|
Dim ph As System.Collections.IEnumerator
|
|
Dim pl As System.Security.Policy.PolicyLevel
|
|
Dim found As Boolean
|
|
|
|
' retrieve the security policy hierarchy
|
|
ph = SecurityManager.PolicyHierarchy
|
|
|
|
' loop through to find the Machine level sub-tree
|
|
Do While ph.MoveNext
|
|
pl = CType(ph.Current, PolicyLevel)
|
|
If pl.Label = "Machine" Then
|
|
found = True
|
|
Exit Do
|
|
End If
|
|
Loop
|
|
|
|
If found Then
|
|
' see if the codegroup for this app already exists
|
|
' as a machine-level entry
|
|
Dim cg As CodeGroup
|
|
For Each cg In pl.RootCodeGroup.Children
|
|
If cg.Name = mAppName Then
|
|
' codegroup already exists
|
|
' we assume it is set to a valid
|
|
' permission level
|
|
mGroupExisted = True
|
|
Exit Sub
|
|
End If
|
|
Next
|
|
|
|
' the codegroup doesn't already exist, so
|
|
' we'll add a url group with FullTrust
|
|
mGroupExisted = False
|
|
Dim ucg As UnionCodeGroup = _
|
|
New UnionCodeGroup(New UrlMembershipCondition(mAppDir & "/*"), _
|
|
New PolicyStatement(New NamedPermissionSet("FullTrust")))
|
|
ucg.Description = "Temporary entry for " & mAppURL
|
|
ucg.Name = mAppName
|
|
pl.RootCodeGroup.AddChild(ucg)
|
|
SecurityManager.SavePolicy()
|
|
End If
|
|
|
|
End Sub
|
|
|
|
#End Region
|
|
|
|
#Region " RemoveSecurity "
|
|
|
|
Private Sub RemoveSecurity()
|
|
|
|
' if the group existed before NetRun was used
|
|
' we want to leave the group intact, so we
|
|
' can just exit
|
|
If mGroupExisted Then Exit Sub
|
|
|
|
' on the other hand, if the group didn't already
|
|
' exist then we need to remove it now that
|
|
' the business application is closed
|
|
Dim ph As System.Collections.IEnumerator
|
|
Dim pl As System.Security.Policy.PolicyLevel
|
|
Dim found As Boolean
|
|
|
|
' retrieve the security policy hierarchy
|
|
ph = SecurityManager.PolicyHierarchy
|
|
|
|
' loop through to find the Machine level sub-tree
|
|
Do While ph.MoveNext
|
|
pl = CType(ph.Current, PolicyLevel)
|
|
If pl.Label = "Machine" Then
|
|
found = True
|
|
Exit Do
|
|
End If
|
|
Loop
|
|
|
|
If found Then
|
|
' see if the codegroup for this app exists
|
|
' as a machine-level entry
|
|
Dim cg As CodeGroup
|
|
For Each cg In pl.RootCodeGroup.Children
|
|
If cg.Name = mAppName Then
|
|
' codegroup exits - remove it
|
|
pl.RootCodeGroup.RemoveChild(cg)
|
|
SecurityManager.SavePolicy()
|
|
Exit For
|
|
End If
|
|
Next
|
|
End If
|
|
|
|
End Sub
|
|
|
|
#End Region
|
|
|
|
End Class
|