<%@ Language=VBScript %>
<% Option Explicit %>
<%
' ASP error 404 handler
' =====================
' http://walter.bislins.ch/doku/error404
'
' Note: local virtual webs have urls like http://localhost/<virtualweb>/...
' To resolve local urls, you must specify VIRTUALWEB = "<virtualweb>"

const REDIRECT_FOLDER = "../../wiki_secure/pages/work"
const REDIRECT_FILE   = "Spezial: Redirect Data"
const REDIRECT_EDITOR = "work/index.asp?page=Spezial%3A+Redirect+Data"
const CUSTOM_HANDLER  = "index.asp?page=Fehler%3A+Seite+nicht+gefunden"
const VIRTUALWEB      = "walti"
const PASS_URL_BY_PAR = false

dim EXCLUDE_LIST
EXCLUDE_LIST = Array( "/apple-touch-icon.*\.png" )

' include = pattern.inc
' =====================

dim GPattern_RegExp, GPattern_LastPattern, GPattern_LastIC
set GPattern_RegExp = new RegExp
GPattern_RegExp.Global = true
GPattern_RegExp.Multiline = true
GPattern_LastPattern = ""
GPattern_LastIC = false

dim GPattern_RegExpT, GPattern_LastPatternT, GPattern_LastICT
set GPattern_RegExpT = new RegExp
GPattern_RegExpT.Global = false
GPattern_RegExpT.Multiline = true
GPattern_LastPatternT = ""
GPattern_LastICT = false

dim GPattern_ExtractResult
GPattern_ExtractResult = Array()

function TestPattern( aString, aPattern, bIgnoreCase )
  if (GPattern_LastPatternT <> aPattern) or (GPattern_LastICT <> bIgnoreCase) then
    GPattern_RegExpT.IgnoreCase = bIgnoreCase
    GPattern_RegExpT.Pattern = aPattern
    GPattern_LastPatternT = aPattern
    GPattern_LastICT = bIgnoreCase
  end if
  TestPattern = GPattern_RegExpT.Test(aString)
end function

function ExtractPattern( aStr, aPattern )
  dim x
  if (GPattern_LastPattern <> aPattern) or (GPattern_LastIC <> true) then
    GPattern_RegExp.IgnoreCase = true
    GPattern_RegExp.Pattern = aPattern
    GPattern_LastPattern = aPattern
    GPattern_LastIC = true
  end if
  GPattern_ExtractResult = Array()
  x = GPattern_RegExp.Replace( aStr, GetRef("GPattern_ExtractPattern") )
  ExtractPattern = GPattern_ExtractResult
end function

function GPattern_ExtractPattern(match,p1,pos,source)
  dim last
  if IsEmpty(p1) then p1 = ""
  last = UBound(GPattern_ExtractResult) + 1
  redim preserve GPattern_ExtractResult(last)
  GPattern_ExtractResult(last) = p1
  GPattern_ExtractPattern = match
end function

' include = seq.inc
' =================

class CParser
  private mString
  private mPos

  private sub Class_Initialize()
    mString = ""
    mPos = 1
  end sub

  sub Init( aString )
    mString = aString
    mPos = 1
  end sub

  sub SkipSubData( )
    ' skips a whole sub data struct
    dim x
    x = GetStrD("")
  end sub

  function GetNumD( aDefault )
    dim p, s
    GetNumD = aDefault
    p = InStr(mPos,mString,"|")
    if p > 0 then
      s = Mid(mString,mPos,p-mPos)
      if IsNumeric(s) then
        GetNumD = CLng(s)
        mPos = p + 1
      end if
    end if
  end function

  function GetStrD( aDefaultStr )
    dim n
    GetStrD = aDefaultStr
    n = GetNumD( -1 )
    if n = 0 then
      GetStrD = ""
    elseif n > 0 and mPos+n <= Len(mString) then
      GetStrD = Mid(mString,mPos,n)
      mPos = mPos + n + 1
    end if
  end function

  function GetFixStr( aStrLen )
    GetFixStr = ""
    if mPos+aStrLen-1 <= Len(mString) then
      GetFixStr = Mid(mString,mPos,aStrLen)
      mPos = mPos + aStrLen
    end if
  end function

end class

function NewParser( aString )
  set NewParser = new CParser
  NewParser.Init aString
end function

' include = fs.inc
' ================

class CFileSystem
  public  FileFormat ' 0 -> ASCII (default), -1 -> Unicode, -2 -> System Settings
  private mFSO

  private sub Class_Initialize()
    FileFormat = 0
    set mFSO = Server.CreateObject("Scripting.FileSystemObject")
  end sub

  function MapPath( aPath )
    ' returns the absolute path to aPath
    if aPath = "" then
      MapPath = Server.MapPath(".")
    elseif InStr(aPath,":\") then
      ' path is absolute already
      MapPath = aPath
    else
      MapPath = Server.MapPath(aPath)
    end if
  end function

  function AppendSlash( aPath )
    AppendSlash = aPath
    if InStrRev(AppendSlash,"/") <> Len(AppendSlash) then
      AppendSlash = AppendSlash & "/"
    end if
  end function

  function AppendName( aPath, aName )
    AppendName = AppendSlash(aPath) & aName
  end function

  function FileExists( aPath )
    dim absPath
    on error resume next
    absPath = MapPath(aPath)
    FileExists = mFSO.FileExists(absPath)
    if Err <> 0 then
      FileExists = false
      Err.Clear
    end if
  end function

  function FolderExists( aPath )
    dim absPath
    absPath = MapPath(aPath)
    on error resume next
    FolderExists = mFSO.FolderExists(absPath)
    if Err <> 0 then
      FolderExists = false
      Err.Clear
    end if
  end function

  function ReadFile( aPath )
    ' require FileExists(aPath)
    dim file, tstream
    set file = mFSO.GetFile(MapPath(aPath))
    set tstream = file.OpenAsTextStream(1, FileFormat)
    if tstream.AtEndOfStream then
      ReadFile = ""
    else
      ReadFile = tstream.Readall
    end if
  end function

end class

dim FS
set FS = new CFileSystem

' include = cvsread.inc
' =====================
' Single function to read latest content of a CVS file: CvsRead
'
' Uses:
' - fs.inc  : FS.AppendName, FS.FileExists, FS.ReadFile
' - seq.inc : CParser

const CvsMagic = "CVS|"

function CvsRead( aRepository, aFilename )
  ' aRepository must be a valid file system folder name (e.g. "../folder")
  ' aFilename as raw page name
  ' returns latest content as string
  dim rawData, p, path
  CvsRead = ""
  path = FS.AppendName( aRepository, Server.UrlEncode(aFilename) )
  if not FS.FileExists(path) then exit function
  rawData = FS.ReadFile(path)
  set p = NewParser( rawData )
  if (p.GetFixStr(Len(CvsMagic)) = CvsMagic) then
    ' skip Header
    p.SkipSubData
    ' skip VersionData
    p.SkipSubData
    CvsRead = p.GetStrD("")
  else
    CvsRead = rawData
  end if
end function

' Main
' ====================================

class CRedir
  public FromList
  public ToList
  public LocalUrl
  public State

  private sub Class_Initialize()
    FromList = Array()
    ToList = Array()
    LocalUrl = ""
    State = "Empty Redirection List"
    InitRelPath
  end sub

  private sub ArrayAdd( ByRef aArray, aStr )
    dim pos
    pos = UBound(aArray) + 1
    redim preserve aArray(pos)
    aArray(pos) = aStr
  end sub

  function Load()
    dim page, nl, path, pat, list, i, entry, src, dest
    Load = false
    nl = vbCRLF
    ' first try to read from CVS repository then from file system
    State = "Reading fom CVS"
    page = CvsRead( REDIRECT_FOLDER, REDIRECT_FILE )
    if page = "" then
      State = "Searching data file"
      path = FS.AppendName( REDIRECT_FOLDER, REDIRECT_FILE )
      if not FS.FileExists( path ) then exit function
      State = "Reading data file"
      page = FS.ReadFile( path )
    end if
    if page = "" then exit function
    State = "Extracting redirects"
    ' try to extract data from wiki page or use all data
    pat = ExtractPattern( page, "{{data}}"&nl&"([^\0]*)"&nl&"{{end data}}" )
    if UBound(pat) >= 0 then page = Join( pat, vbCRLF&vbCRLF )
    pat = ExtractPattern( page, "<code>"&nl&"([^\0]*)"&nl&"</code>" )
    if UBound(pat) >= 0 then page = Join( pat, vbCRLF&vbCRLF )
    ' reformat lines
    page = Replace( page, nl & "->", " ->" )
    list = Split( page, nl )
    if UBound(list) < 0 then exit function
    for i = 0 to UBound(list)
      entry = Trim(list(i))
      if InStr(entry," -> ") then
        pat = Split(entry," -> ")
        src = Trim(pat(0))
        dest = Trim(pat(1))
        if InStrRev(src,"/") = Len(src) then src = Left(src,Len(src)-1)
        ArrayAdd FromList, src
        ArrayAdd ToList, dest
        Load = true
      end if
    next
    if Load then State = ""
  end function

  function FindRedirect(aPath)
    dim i
    for i = 0 to UBound(FromList)
      if LCase(FromList(i)) = LCase(aPath) then
        FindRedirect = i
        exit function
      end if
    next
    FindRedirect = -1
  end function

  sub InitRelPath()
    dim p, host, path
    host = Request.ServerVariables("HTTP_HOST")
    ' handle local webs
    if (host = "localhost") or (host = "127.0.0.1") and VIRTUALWEB <> "" then
      path = Request.ServerVariables("PATH_INFO")
      if InStr(1,path,VIRTUALWEB,1) <= 2 then
        LocalUrl = VIRTUALWEB
      end if
    end if
  end sub

  function GetParams( aUrl )
    ' returns from http://www.aphs.ch/d/dir/file.ext?params -> params
    dim p
    GetParams = ""
    ' remove parameters
    p = InStrRev(aUrl,"?")
    if p > 0 then GetParams = Right(aUrl,Len(aUrl)-p)
  end function

  function GetRelPath( aUrl )
    ' returns from http://www.aphs.ch/d/dir/file.ext?params -> d/dir/file.ext
    ' returns from http://localhost/<virtualweb>/d/dir/file.ext?params -> d/dir/file.ext
    dim p, path
    path = aUrl
    ' remove parameters
    p = InStrRev(path,"?")
    if p > 0 then path = Left(path,p-1)
    ' remove protocol and host
    p = InStr(path,"//")
    if p > 0 then
      path = Right(path,Len(path)-p-1)
      p = InStr(path,"/")
      if p > 0 then path = Right(path,Len(path)-p)
    else
      if InStr(path,"/") = 1 then path = Right(path,Len(path)-1)
    end if
    ' remove virtual web id
    if VIRTUALWEB <> "" then
      if InStr(1,path,VIRTUALWEB,1) = 1 then
        path = Right(path,Len(path)-Len(VIRTUALWEB)-1)
      end if
    end if
    GetRelPath = path
  end function

  function CutName( aPath )
    dim p
    p = InStrRev(aPath,"/")
    if p > 0 then
      CutName = Left(aPath,p-1)
    else
      CutName = aPath
    end if
  end function

  sub DoRedirect(aPath, aPars)
    dim path
    path = CompleteToPath(aPath)
    ' append aPars if last char of aPath is "?"
    if Mid(path,Len(path),1) = "?" then
      if aPars <> "" then
        path = path & aPars
      else
        ' remove "?" from path
        path = Left(path,Len(path)-1)
      end if
    end if
    Response.Clear
    Response.Status = "301 Moved Permanently"
    Response.AddHeader "Location", path
    Response.End
  end sub

  function CompleteToPath( aPath )
    ' completes aPath to an absolute path taking into account virtual urls
    dim path
    path = aPath
    if InStr(path,"/") <> 1 then path = "/" & path
    if LocalUrl <> "" then path = "/" & LocalUrl & path
    CompleteToPath = path
  end function

  function IsUrlInExcludeList( aUrl )
    dim i, excl
    IsUrlInExcludeList = true
    for i = 0 to UBound(EXCLUDE_LIST)
      excl = EXCLUDE_LIST(i)
      if TestPattern( aUrl, excl, true ) then exit function
    next
    IsUrlInExcludeList = false
  end function

  sub RedirectTo( aUrl )
    ' aUrl: original url that failed (e.g. http://host/dir/file.ext?params)
    ' Note: aUrl is passed to other pages by a session var named "FailedUrl"
    ' a localized version of aUrl is passed by session var "FaildPath" (e.g. dir/file.exp)
    dim relPath, oldPath, pars, i, saveRelPath
    if IsUrlInExcludeList(aUrl) then exit sub
    pars = GetParams( aUrl )
    relPath = GetRelPath( aUrl )
    saveRelPath = relPath
    Session("FailedUrl") = ""
    Session("FailedPath") = ""
    ' try to find a valid redirect by cutting parts of url step by step
    if relPath <> "" then
      i = FindRedirect(relPath)
      if i >= 0 then DoRedirect ToList(i), pars
      do
        oldPath = relPath
        relPath = CutName(relPath)
        if oldPath <> relPath then
          i = FindRedirect(relPath)
          if i >= 0 then DoRedirect ToList(i), pars
        end if
      loop until oldPath = relPath
    end if
    ' call custom handler
    Session("FailedUrl") = aUrl
    Session("FailedPath") = saveRelPath
    if CUSTOM_HANDLER <> "" then
      if DestinationExists( CUSTOM_HANDLER ) then
        relPath = CompleteToPath(CUSTOM_HANDLER)
        if PASS_URL_BY_PAR then relPath = relPath & "?url=" & Server.UrlEncode(aUrl)
        Response.Redirect relPath
        Response.End
      end if
    end if
    ' fallback to simple error page of this asp file
  end sub

  function DestinationExists( aPath )
    dim p, path
    path = aPath
    p = InStrRev(path,"?")
    if p > 0 then path = Left(path,p-1)
    path = CompleteToPath( path )
    DestinationExists = FS.FileExists(path)
    if not DestinationExists then DestinationExists = FS.FolderExists(path)
  end function

  function Check()
    dim path, i
    for i = 0 to UBound(ToList)
      path = ToList(i)
      if not DestinationExists(path) then
        Check = "Error: Nonexistent redirect destination " & (i+1) & ": " & ToList(i)
        exit function
      end if
    next
    if CUSTOM_HANDLER <> "" then
      if not DestinationExists( CUSTOM_HANDLER ) then
        Check = "Error: Nonexistent CUSTOM_HANDLER: " & CUSTOM_HANDLER
        exit function
      end if
    end if
    Check = "All OK, Redirect-List-Size = " & UBound(FromList)+1
  end function
end class

function Redirect()
  dim redir, path, p
  Redirect = ""
  path = Request.QueryString
  ' remove 404; at start inserted from webserver
  p = InStr(path,";")
  if p > 0 and p <= 4 then path = Right(path,Len(path)-p)
  set redir = new CRedir
  if not redir.Load() then
    if path = "" then Redirect = "Loading redirect list failed: " & redir.State
    exit function
  end if
  ' Testmode
  if path = "" then
    Redirect = redir.Check()
    exit function
  end if
  redir.RedirectTo path
end function

dim msg
msg = Redirect()

' Fallback error 404 page
' =======================
%>

<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
<html>
<head>
<title>Fehler: Seite nicht gefunden</title>
</head>
<body>
<% if msg = "" then %>
<h1>Fehler: Seite nicht gefunden</h1>
<% else %>
<h1>Test of Error 404 Redirect Page</h1>
<% end if %>
<p>
<%
  if msg <> "" then
    Response.Write "<h2>State of Selftest</h2>" & vbCRLF
    Response.Write "<p>" & msg & "</p>" & vbCRLF
    if REDIRECT_EDITOR <> "" then
      Response.Write "<p><a href=""" & REDIRECT_EDITOR & """>Edit Redirect Datas</a></p>" & vbCRLF
    end if
  else
%>
    Sie sind über einen ungültigen Link auf diese Seite gestossen. <br>
    Leider konnte keine Weiterleitung auf eine passende Seite gefunden werden. <br>
    Überprüfen Sie die Addresse im Browser oder besuchen Sie die Homepage:</p>
    <p><a href="/">Zur Homepage</a>
<%
  end if
%>
</p>
</body>
</html>