source/csla10/NetRun/Launcher.vb

@@ -0,0 +1,174 @@
+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