Imports System.Runtime.Remoting.Contexts
Imports System.Runtime.Remoting.Activation
Imports System.Runtime.Remoting.Messaging
Imports System.Reflection

Namespace AccessControl

  ' This attribute is applied to our Measurement class; 
  ' it injects the AccessControlProperty to the context, 
  ' which, in turn, adds the AccessControlServerSink to
  ' the context.
  <AttributeUsage(AttributeTargets.Class)> _
  Public Class AccessControlAttribute
    Inherits ContextAttribute

    Public Sub New()
      ' Call the base class' constructor providing it with
      ' the attribute name.
      MyBase.New("AccessControlAttribute")
    End Sub

    Public Overrides Sub GetPropertiesForNewContext( _
     ByVal ctorMsg As IConstructionCallMessage)

      ' Add our access control property to the new context.
      ctorMsg.ContextProperties.Add(New AccessControlProperty)
    End Sub

    Public Overrides Function IsContextOK( _
     ByVal ctx As Context, _
     ByVal ctorMsg As IConstructionCallMessage) As Boolean

      ' Does the context already have the property and,
      ' is it of valid type?
      Return AccessControlProperty.ExistsInContext(ctx)
    End Function

  End Class


  ' The property injects the AccessControlSink into the context
  ' with which it is associated.
  Public Class AccessControlProperty
    Implements IContextProperty
    Implements IContributeServerContextSink

    Public Const PropertyName As String = "AccessControlProperty"

    Public Sub Freeze( _
     ByVal newContext As Context) _
     Implements IContextProperty.Freeze

    End Sub

    Public Function IsNewContextOK( _
     ByVal newCtx As Context) As Boolean _
     Implements IContextProperty.IsNewContextOK

      ' Verify the context has this property.
      Return ExistsInContext(newCtx)
    End Function

    Public ReadOnly Property Name() As String _
     Implements IContextProperty.Name
      Get
        Return PropertyName
      End Get
    End Property

    ' Shared helper employed by this class as well 
    ' as the AccessControlAttribute class.
    Public Shared Function ExistsInContext( _
     ByVal ctx As Context) As Boolean

      Dim ExistingProperty As IContextProperty = _
       ctx.GetProperty(PropertyName)

      If (ExistingProperty Is Nothing) OrElse _
			   (Not TypeOf ExistingProperty Is AccessControlProperty) Then
        Return False
      End If
      Return True
    End Function


    ' Called by CLR when setting up a new context.
    ' Injects our sink into the context's sink chain.
    Public Function GetServerContextSink( _
     ByVal nextSink As IMessageSink) As IMessageSink _
     Implements IContributeServerContextSink.GetServerContextSink

      Return New AccessControlServerSink(nextSink)
    End Function
  End Class


  ' Preprocesses calls to the Measurement class (currently
  ' the only class within the context containing our
  ' AccessControlAttribute context attribute).
  Public Class AccessControlServerSink
    Implements IMessageSink

    Private _NextSink As IMessageSink

    Public Sub New(ByVal nextSink As IMessageSink)
      _NextSink = nextSink
    End Sub

    Public ReadOnly Property NextSink() As IMessageSink _
      Implements IMessageSink.NextSink
      Get
        Return _NextSink
      End Get
    End Property


    Public Function AsyncProcessMessage( _
     ByVal msg As IMessage, _
     ByVal replySink As IMessageSink) As IMessageCtrl _
     Implements IMessageSink.AsyncProcessMessage

      ' Access control not supported (yet:-)
      Return _NextSink.AsyncProcessMessage(msg, replySink)
    End Function


    Public Function SyncProcessMessage( _
     ByVal msg As IMessage) As IMessage _
     Implements IMessageSink.SyncProcessMessage

      ' If AccessCheck returns Nothing, the check has passed
      ' and we allow the method to execute.
      ' If it returns a valid return message, it has the 
      ' Exception member set to an access denied exception;
      ' we return that message and don't execute the method.
      Dim RetMsg As IMethodReturnMessage = Me.AccessCheck(msg)
      If RetMsg Is Nothing Then
        Return _NextSink.SyncProcessMessage(msg)
      Else
        Return RetMsg
      End If
    End Function


    ' Checks to see if execution of the method identified
    ' by the message is allowed. If the execution is allowed,
    ' the method return Nothing. If the execution is denied,
    ' the method returns an IMethodReturnMessage with the
    ' Exception member initialized.
    Private Function AccessCheck( _
     ByVal msg As IMessage) As IMethodReturnMessage

      If Not TypeOf msg Is IMethodCallMessage Then
        Return Nothing
      End If

      Dim CallMsg As IMethodCallMessage = _
       DirectCast(msg, IMethodCallMessage)

      If AccessControlGuard.CanExecuteMethod(CallMsg.MethodName) Then
        Return Nothing
      End If

      Return New ReturnMessage( _
       AccessControlGuard.GetAccessDeniedException(), _
       CallMsg)
    End Function

  End Class


  Public Class AccessControlGuard

    Private Shared _MethodToPropertyMap As New Hashtable

    Shared Sub New()
      _MethodToPropertyMap.Add("MarkValuesInvalid", "CanModifyDataAttributes")
      _MethodToPropertyMap.Add("UpdateMinValues", "CanModifyDataValues")
      _MethodToPropertyMap.Add("ApplyLineConstants", "CanModifyDataValues")
      _MethodToPropertyMap.Add("MultiplyValues", "CanModifyDataValues")
      _MethodToPropertyMap.Add("UploadMeasuredValues", "CanModifyDataAttributes")
    End Sub


    Public Shared Function CanExecuteMethod( _
     ByVal method As String) As Boolean

      ' Lookup the UserToken property name that must
      ' return True in order to allow the method to execute.
      Dim PropName As String = CStr(_MethodToPropertyMap(method))
      If PropName Is Nothing Then
        ' The method is not in our table so by definition,
        ' we allow it to be executed (it is not data modifi-
        ' cation method) as long as the user token has ANY
        ' access to the application.
        Return Not App.User.NoAccess
      End If

      ' Invoke the property through reflection.
      Dim PropInfo As PropertyInfo = App.User.GetType().GetProperty(PropName)
      Debug.Assert(Not PropInfo Is Nothing)
      Return CBool(PropInfo.GetValue(App.User, Nothing))
    End Function


    Public Shared Sub AccessCheck( _
     ByVal method As String)

      If Not CanExecuteMethod(method) Then
        Throw GetAccessDeniedException()
      End If
    End Sub


    Public Shared Function GetAccessDeniedException() As _
     System.Security.SecurityException

      Return New System.Security.SecurityException( _
       "Nemáte oprávnenie vykonať požadovaný príkaz.")
    End Function

  End Class


End Namespace