Chip 1998 March/CHIPCD_3_98.iso/software/testsoft/exchange/webdata/usa/lib/session.inc

Text File | 1997-08-25 | 17KB | 648 lines

<%
'!--Microsoft Outlook Web Access-->
'!--Session.inc - Session Management-->
'!--Copyright (c) Microsoft Corporation 1993-1997. All rights reserved.-->

'===============================
' the objOMSession we always use
' note that this has FILE scope
'===============================

Dim objOMSession
Dim iFontSize
iFontSize=Session("iFontSize")

'=======================
' CheckSession
'
' Check session is still valid and logon if not.
' Side Effect: Initializes objOMSession
'=======================
'***
Public Sub CheckSession
    CheckSession2 ""
End Sub

'for backwards compatability but now returns a boolean
Public Function CheckSession2(bstrRedirectURL)
    CheckSession2 = CheckSession3(bstrRedirectURL,"top",-1)
End Function

Public Function SessionIsValid()
    On Error Resume Next
    SessionGet
    If IsEmpty(objOMSession) Or (objOMSession Is Nothing) Then
        SessionIsValid = false
    Else
        SessionImpersonate
        SessionIsValid = true
    End If
End Function


'returns boolean success
'use CheckSession3(url, location, iStore)
'use CheckSession3("0","newwindow",1) for new window logon no viewer button
'use CheckSession3("1","newwindow",1) for new window logon with open viewer button
'bstrLogonLocation can be self, parent, parent.parent, top, etc
Public Function CheckSession3(bstrRedirectURL,bstrLogonLocation,iStore)

    On Error Resume Next
    Err.Clear

    If Not SessionIsValid() Then
        'if no redirect url given then
        If bstrRedirectURL = "" Then
            'use the current script file for redirection and it's current URL
            bstrName = Request.ServerVariables("SCRIPT_NAME")
            bstrQuery = Request.ServerVariables("QUERY_STRING")
            If Len(bstrQuery) > 0 Then
                bstrName = bstrName + "?" + bstrQuery
            End If
        Else 'passed in both the redirect file and url
            bstrName = bstrRedirectURL
            bstrQuery = ""
        End If

        ' user is not logged on, send them to logon page now
        If InStr(1, bstrName, "/logon", 1) = 0 Then
            If bstrLogonLocation = "newwindow" Then
                fNewWindow = true
                Session(bstrURLReq) = ""
                Session("iStoreReq")=iStore
            Else
                fNewWindow = false
                Session(bstrURLReq) = bstrName
            End If

            Response.Write "<script language=""JavaScript"">"

            If ((InStr(1, bstrName,  "anon", 1) <> 0)  OR _
                (InStr(1, bstrQuery, "acs=anon", 1) <> 0)) Then
                ' Anon users don't need to see logon page
                bstrLogonFile = bstrVirtRoot+"/logonfrm.asp"
            Else
                bstrLogonFile = bstrVirtRoot+"/logon.asp"
            End If

            If fNewWindow Then
                Response.Write "window.open(""" + bstrLogonFile + "?newwindow=1&viewer=" + bstrRedirectURL + """,""newLogon"",""toolbar=0,location=0,directories=0,status=1,menubar=1,scrollbars=1,resizable=1,width=600,height=400"")"
            Else
                Response.Write bstrLogonLocation + ".location='" + bstrLogonFile + "'"
            End If

            Response.Write "</script>"
            If Not fNewWindow Then Response.End
            CheckSession3 = false
        End If
    Else
        CheckSession3 =true
    End If


End Function

Public Sub SessionGet

    On Error Resume Next

    If (Not IsEmpty(Session(bstrAuthenticated)) ) Then
        Set objOMSession = Session(bstrOMSession)
    End If

End Sub

Public Sub SessionImpersonate
    On Error Resume Next

    hImp = Session("hImp")

    set objRA = Application(bstrRenderApp)
    If objRA Is Nothing Then
        ReportError1 L_errApplicNull_ErrorMessage
    Else
        fOk = objRA.Impersonate(hImp)
        If fOk <> 1 Then
            ReportError1 L_errFailedToAuthenticate_ErrorMessage
        End If
    End If

End Sub

'=======================
' ClearSession
' Clears the session for a new logon
'=======================
Public Sub ClearSession

    On Error Resume Next

    ' Commented this out since as far as we know, strings don't need
    ' to get freed in a specific security context, and we need to keep
    ' this particular var around, so it can be used to redirect in MainLogon.
    ' (raid 23673)
    ' Set Session(bstrURLReq) = Nothing
    'Get the cached dictionary object
    Set objCacheID =  Session(bstrCacheObject)
    'Ask the object for the array that contains the ID's for all the session objects
    rgObjectIDs = objCacheID.Items



    For i = Lbound(rgObjectIDs) to Ubound(rgObjectIDs)


        Set Session(rgObjectIDs(i)) = Nothing
    Next







    Set Session(bstrRenderObject) = Nothing
    Set Session(bstrRenderMessage) = Nothing
    Set Session(bstrRenderFolder) = Nothing
    Set Session(bstrRenderAddressContainer) = Nothing
    Set Session(bstrRenderAddressEntry) = Nothing
    Set Session(bstrRenderHierarchy) = Nothing
    Set Session(bstrRenderRecipients) = Nothing
    Set Session(bstrRenderCalendar) = Nothing

    ' Clear Format flags for HierarchyRenderer
    Session("fPublicFormats") = False
    Session("fPrivateFormats") = False

    Set Session(bstrObjPrivateStore) = Nothing
    Set Session(bstrObjPublicStore) = Nothing
    Set Session(bstrObjThisFolderLink) = Nothing

    Set Session(bstrPublicStoreID) = Nothing
    Set Session(bstrPublicStoreEntryID) = Nothing
    Set Session(bstrPublicStoreRootID) = Nothing
    Set Session(bstrDeletedItemsID) = Nothing

    Set Session(CURRENT_FOLDER) = Nothing
    Set Session(CURRENT_HIERARCHY) = Nothing
    Set Session(CURRENT_CONTENTS) = Nothing
    Set Session(CURRENT_INDEX) = Nothing
    Set Session(CURRENT_COUNT) = Nothing
    Set Session(CURRENT_PAGES) = Nothing
    Set Session(CURRENT_ROWS) = Nothing
    Set Session(CURRENT_VIEW) = Nothing
    Set Session(CURRENT_PAGE) = Nothing
    Set Session(CURRENT_MSG)  = Nothing

    If Not objOMSession Is Nothing Then
        Set Session(bstrOMSession) = Nothing
        objOMSession.Logoff
    End If
    hImp = Session("hImp")
    If Not IsEmpty(hImp) Then
        If hImp <> 0 Then
            set objRenderApp = Application(bstrRenderApp)
            set Session("hImp") = Nothing
            objRenderApp.CloseSysHandle(hImp)
        End If
    End If

    Set Session(bstrAuthenticated) = Nothing

End Sub

'=======================
' ReportError*
'
' Error handling functions
'=======================
Public Function ReportError2(bstrWhat, bstrErr)
    DisplayError bstrWhat & bstrErr, 0, "" '= back once
End Function

Public Function ReportError1(bstrErr)
    DisplayError bstrErr, 0, "" '= back once
End Function

Public Function ReportError3(bstrErr)
    DisplayError bstrErr, 3, "" '= no back
End Function

Public Function DisplayError(bstrErr, nAction, bstrLocation)
    ' nAction:
    '
    ' 0: the function will navigate to the previous location in the history
    ' 1: the current window is closed
    ' 2: will go to bstrLocation after displaying error
    ' 3: will display error and return (no redirect)

    ' Displays Active Messaging Error Descriptions if Debug Parameter
    ' is set to one.
    Dim bstrMessage
    Dim objRenderer
    Set objRenderer = Nothing
    bstrMessage = bstrErr
    Set objRenderApp = Application(bstrRenderApp)
    If objRenderApp.ConfigParameter("Debug") = 1 Then
        If Err.Number <> 0 Then
            bstrMessage = bstrMessage & "\n\n" & Err.Description
            bstrMessage = bstrMessage & "\n\n" & Request.ServerVariables("SCRIPT_NAME")
        End If
    End If

    Set objRenderer = objRenderApp.CreateRenderer(2)
    objRenderer.CodePage = Request.ServerVariables("HTTP_ACCEPT_LANGUAGE")
    Session.CodePage = objRenderer.CodePage    'set the denali session codepage

    Response.write("<HTML>")


%>
    <body text=000000 link=black vlink=black onLoad="statusAlert()">
    <script language="javascript">
    function statusAlert() {
<%
    Set br = Request.ServerVariables("HTTP_USER_AGENT")

    If objRenderer Is Nothing Then
    ' Can't get a rendering object, output error
    ' without codepage conversion
        If (isUNIX and isNav) Then %>
            confirm("<%=bstrMessage%>");
        <% Else %>
            alert("<%=bstrMessage%>");
        <% End If
     Else
     ' We have a rendering object, output error
     ' with codepage conversion
        If (isUNIX and isNav) Then %>
            confirm("<%objRenderer.Write bstrMessage, Response%>");
        <% Else %>
            alert("<%objRenderer.Write bstrMessage, Response%>");
        <% End If
    End If

    If nAction = 0 Then %>
            self.history.back();
<%  ElseIf nAction = 2 Then %>
            top.location = "<%=bstrLocation%>";
<%  ElseIf nAction = 3 Then ' no redirect %>
<%  Else %>
            self.close();
<%  End If %>
   }
   </script>
   </body>
<%
    Response.write("</HTML>")
    Set objRenderApp = Nothing
    Set objRenderer = Nothing
    Response.End
End Function

Public Function ReportError
    ReportError1 ""
End Function

Public Function ReportErrorClose2(bstrWhat, bstrErr)
    DisplayMessage bstrWhat & bstrErr, 1, "" '= Close window
End Function

Public Function ReportErrorClose(bstrErr)
    DisplayError bstrErr, 1, "" '= Close window
End Function

Public Function ReportErrorLoad(bstrErr, bstrLocation)
    DisplayError bstrErr, 2, bstrLocation '= go to location
End Function

Public Function SetPageDefaults
    Session(CURRENT_INDEX) = 1
    Session(CURRENT_COUNT) = 0
    Session(CURRENT_PAGES) = 1
    Session(CURRENT_ROWS) = iDefaultNumRows
    Session(CURRENT_VIEW) = 1
    Session(CURRENT_PAGE) = 1
End Function

Public Function isWin16
    Set br = Request.ServerVariables("HTTP_USER_AGENT")
    if (instr(br, "Win") <> 0) Then
        isWin16 = (instr(br, "3.1") <> 0) OR  (instr(br, "16") <> 0)
    else
        isWin16 = false
    End If
End Function

Public Function isWin32
    Set br = Request.ServerVariables("HTTP_USER_AGENT")
    If (instr(br, "Win") <> 0) Then
        isWin32 = (instr(br, "95") <> 0) OR  (instr(br, "NT") <> 0)
    Else
        isWin32 = false
    End If
End Function

Public Function isMac
    Set br = Request.ServerVariables("HTTP_USER_AGENT")
    isMac = instr(br, "Mac")
End Function

'returns ver 3 or 4 if success or 1 if ver unknown
'returns 0 on fail
Public Function isSun
    'Mozilla/4.02 [en] (X11;I;SunOS 5.5.1 sun4u)
    Set br = Request.ServerVariables("HTTP_USER_AGENT")
    if instr(br, "Sun") then
        if instr(br,"4.0") then
            isSun=4
        elseif instr(br,"3.0") then
            isSun=3
        else
            isSun=1
        end if
    else
        isSun=0
    end if
End Function

Public Function isUNIX
    Set br = Request.ServerVariables("HTTP_USER_AGENT")
    isUNIX = ((instr(br, "Win") = 0) AND (instr(br, "Mac") = 0))
End Function

Public Function isMSIE
    Set br = Request.ServerVariables("HTTP_USER_AGENT")
    isMSIE = instr(br, "MSIE")
End Function

Public Function isNav
    Set br = Request.ServerVariables("HTTP_USER_AGENT")
    isNav = (instr(br, "MSIE") = 0)
End Function

Function isAttachSupported()
    If getVersion() >= 3.02 or isNav() or isMac() Then
       isAttachSupported=true
    Else
       isAttachSupported=false
    End If
End Function

Function getVersion()
    ' What browser requested this page?
    set szClient = Request.ServerVariables("HTTP_USER_AGENT")

    ' Are we using Microsoft Internet Explorer?
    nPos = Instr(szClient, "MSIE")

    ' Strip everything left of the major version #
    if (nPos <> 0) then
        ' MSIE Agents are of the form "Mozilla/#.# (compatable; MSIE M.m; Platform)"
        szVersion = Right(szClient, len(szClient) - nPos - len("MSIE"))
      else
        ' NS Nav Agents are of the form "Mozilla/M.m (Platform; I; Processor)"
        szVersion = Right(szClient, len(szClient) - len("Mozilla/"))
    end if

    ' Get the major version #
    nPos = Instr(szVersion, ".")
    szMajor = Left(szVersion, nPos - 1)

    ' Get the minor version #
    nPos = Instr(szVersion, ".")
    for nPos2=nPos+1 to len(szVersion)
        a = asc(Mid(szVersion, nPos2, 1))
        if  (a < asc("0")) OR (a > asc("9")) Then
            Exit For
        end if
    Next
    szMinor = Mid(szVersion, nPos+1, nPos2 - nPos - 1)

    ' If your browser is version 3.x or higher, your supported
    getVersion =  CSng(szMinor) / (10 ^ Len(szMinor)) + CSng(szMajor)
End Function

Sub SendHeader (nSensitive, nForm)
    'nSensitive
    ' 0: not sensitive
    ' 1: contains sensitive info
    'nForm
    ' 0: no form on page
    ' 1: form on page
    If isMSIE Then
       If (nSensitive <> 0) Then
          Response.AddHeader "pragma", "no-cache"
       End If
       If (nForm <> 0) Then
          Response.Expires=0
       End If
    End IF
End Sub

Public Function IsEXAddress(strAddress)
    If InStr(strAddress, "EX:") = 1 Then
        IsEXAddress = True
    Else
        IsEXAddress = False
    End If
End Function

Public Sub GetSMTPAddress(objAddressEntry, ByRef strAddress)
    strAddress = ""

    If Not objAddressEntry Is Nothing Then
        astrAddresses = objAddressEntry.Fields.Item(ActMsgPR_EMS_AB_PROXY_ADDRESSES)
        cAddresses = UBound(astrAddresses)
        For iAddress = LBound(astrAddresses) To cAddresses
            strTempAddress = astrAddresses(iAddress)
            If (InStr(strTempAddress, "SMTP:") = 1) Then
                strAddress = strTempAddress
                Exit For
            End If
        Next
    End If
End Sub

Public Function EscapeAddresses(str)
    Dim startpos
    Dim endpos
    Dim cBrackets
    Dim strlen
    Dim done
    Dim item
    Dim ch
    Dim prevch
    Dim nextch
    Dim i
    Dim newstr

    startpos  = 1
    endpos    = 1
    cBrackets = 0
    strlen    = Len(str)
    done      = False

    Do While endpos <= strlen
        cBrackets = 0
        done      = False

        Do While done = False
            If Mid(str, endpos, 1) = "[" Then
                cBrackets = cBrackets + 1
            End If

            If Mid(str, endpos, 1) = "]" Then
                cBrackets = cBrackets - 1
            End If

            If (((Mid(str, endpos, 1) = ";") And (cBrackets = 0)) Or (endpos = strlen)) Then
                done = True
                Exit Do
            End If

            endpos = endpos + 1
        Loop

        item   = Mid(str, startpos, endpos - startpos + 1)

        If InStr(item, "[") > 0 Then

            item   = ""
            ch     = ""
            prevch = ""
            nextch = ""

            i = 0

            For i = startpos To endpos
                ch     = Mid(str, i, 1)
                nextch = Mid(str, i+1, 1)

                If (ch = ":") And (prevch <> "\") Then
                    ch = "\:"
                End If

                If (ch = "]") And (prevch <> "\") Then
                    ch = "\]"
                End If

                If (ch = "\") And (prevch <> "\") And (InStr("[:]\", nextch) = 0) Then
                    ch = "\\"
                End If

                item = item + ch

                If ch = "[" Then
                Exit For
                End If

                prevch = Mid(str, i, 1)
            Next

            ch       = ""
            prevch   = ""
            nextch   = ""
            startpos = i + 1

            For i = startpos To endpos
                ch     = Mid(str, i, 1)
                nextch = Mid(str, i+1, 1)

                If (ch = "[") And (prevch <> "\") Then
                    ch = "\["
                End If

                If (ch = "]") And (prevch <> "\") Then
                    ch = "\]"
                End If

                If (ch = "\") And (prevch <> "\") And (InStr("[:]\", nextch) = 0) Then
                    ch = "\\"
                End If

                item = item + ch

                If ch = ":" Then
                    Exit For
                End If

                prevch = Mid(str, i, 1)
            Next

            ch       = ""
            prevch   = ""
            nextch   = ""
            startpos = i + 1

            For i = startpos To endpos
                ch     = Mid(str, i, 1)
                nextch = Mid(str, i+1, 1)

                If (ch = "[") And (prevch <> "\") Then
                    ch = "\["
                End If

                If (ch = ":") And (prevch <> "\") Then
                    ch = "\:"
                End If

                If (ch = "\") And (prevch <> "\") And (InStr("[:]\", nextch) = 0) Then
                    ch = "\\"
                End If

                item = item + ch

                If ch = "]" Then
                    Exit For
                End If

                prevch = Mid(str, i, 1)
            Next

            startpos = i + 1

            For i = startpos To endpos
                ch   = Mid(str, i, 1)
                item = item + ch
            Next
        End If

        newstr = newstr + item

        startpos  = endpos + 1
        endpos    = startpos
        cBrackets = 0
    Loop

    EscapeAddresses = newstr
End Function

Public Sub AddIDToCache(bstrObjID)
    On Error Resume Next
    Set objCacheID =  Session(bstrCacheObject)
    objCacheID.Add bstrObjID, bstrObjID
    Set Session(bstrCacheObject) = objCacheID
End Sub

Public Sub RemoveIDFromCache(bstrObjID)
    On Error Resume Next
    Set objCacheID =  Session(bstrCacheObject)
    objCacheID.Remove bstrObjID
    Set Session(bstrCacheObject) = objCacheID
End Sub

Public Function BStringToJString(bstrString)
    On Error Resume Next
    bstrString = Replace(bstrString, "\", "\\")
    bstrString = Replace(bstrString, " ", "\ ")
    bstrString = Replace(bstrString, """", "\""")
    bstrString = Replace(bstrString, "&", "&")
    bstrString = Replace(bstrString, "<", "<")
    bstrString = Replace(bstrString, ">", ">")
    BStringToJString =  bstrString
End Function


%>