WaBis

walter.bislins.ch

Datei: coder.inc

Inhalt der Datei: ./asp/coder/coder.inc
<%
' coder.inc: Copyright (C) 2008-2014 Walter Bislin
' http://walter.bislins.ch/doku/coder
'
' A very simple class to encode/decode strings with a 128 bit key,
' generated from a password of any length. The encoded string is allways
' a valid ASCII string using only upper case letters A to P.
' Any encoded string is exactly double the size of the decoded string.
'
' Dependencies:
' - perf.inc (CStream)
'
' Exported Object:
' - Coder (as CCoder)
'
' Exported functions:
' - sub SetPassword( aPassword )
' - function EncodeName( aName )
' - function DecodeName( aCode )
' - function EncodeValue( aValueStr )
' - function DecodeValue( aCode )
' - function EncodeValueSec( aValueStr )
' - function DecodeValueSec( aCode )
' - function IsDecodeValueSec( aCode, aValueRet )
' - function IsValidValueSec( aCode )
' - function EncodeUnique( aID, aValue )
' - function DecodeUnique( aID, aDefault )
' - function IsDecodeUnique( aID, aCode, aValueRet )
' - function EncodeString( aStr, bRandomize )
' - function DecodeString( aCode, bRandomize )
' - sub SetCookie( aCookieName, aName, aValue )
' - function GetCookie( aCookieName, aName )
' - function GetValidCookie( aCookieName, aName, aValueRet )
' - sub SetSession( aName, aValue )
' - function GetSession( aName )
' - function GetHash( aStr, aLen )
'
' Simple Usage Example:
'
' Set bRandomize to false to encode/decode names and true to encode/decode values.
'
' Coder.SetPassword "mypassword"
' s = "my text"
' c = Coder.EncodeValue(s)
' x = Coder.DecodeValue(c)
' now s = x and x is the encoded s

class CCoder
  public  ChecksumSize ' x 4 Bit
  public  SaltSize     ' x 4 Bit
  private mKey         ' array(32) of 4 Bit values
  private mPwdKey      ' is the initializer for mKey
  private mKeyIx
  private mAscBigA
  private mAscBigP
  private mAscSmallA
  private mAscSmallP

  private sub Class_Initialize()
    dim i
    ChecksumSize = 3
    SaltSize = 4
    mAscBigA = Asc("A")
    mAscBigP = mAscBigA + 15
    mAscSmallA = Asc("a")
    mAscSmallP = mAscSmallA + 15
    mKey = Array()
    mPwdKey = Array()
    redim mKey(31)
    redim mPwdKey(31)
    for i = 0 to UBound(mKey)
      mKey(i) = 0
    next
    SetPassword "" ' generate default key
  end sub

  sub SetPassword( aPassword )
    ' generates from the password a 128 bit key to encode/decode strings
    ' the password may have any length
    ' this class uses a default password, if none is specified
    dim lastx, x, i
    FillKey "pfv/be%2b.7Bd*8B" ' default Password
    FillKey aPassword
    lastx = CInt((Len(aPassword) and 15) xor 5)
    for i = 0 to UBound(mPwdKey)
      x = mPwdKey(i)
      mPwdKey(i) = x xor lastx
      lastx = x
    next
  end sub

  private sub FillKey( aPassword )
    dim pw, ci, i, c
    pw = aPassword
    if Len(pw) > 16 then pw = Right(pw,16)
    ci = 0
    for i = 1 to Len(pw)
      c = Asc(Mid(pw,i,1))
      mPwdKey(ci) = (c and 240) \ 16   ' mask 00F0h -> 000Fh
      ci = ci + 1
      mPwdKey(ci) = (c and 15)  ' mask 000Fh
      ci = ci + 1
    next
  end sub

  private sub InitKey()
    dim i
    for i = 0 to UBound(mKey)
      mKey(i) = mPwdKey(i)
    next
    mKeyIx = 0
  end sub

  private function GetNextKey()
    dim x
    x = CInt(Rnd() * 16) and 15
    mKey(mKeyIx) = (mKey(mKeyIx) + x) and 15
    GetNextKey = mKey(mKeyIx)
    mKeyIx = (mKeyIx + 1) and 31
  end function

  function EncodeName( aName )
    EncodeName = EncodeString( aName, false )
  end function

  function DecodeName( aCode )
    DecodeName = DecodeString( aCode, false )
  end function

  function EncodeValue( aValueStr )
    EncodeValue = EncodeString( aValueStr, true )
  end function

  function DecodeValue( aCode )
    DecodeValue = DecodeString( aCode, true )
  end function

  function EncodeValueSec( aValueStr )
    EncodeValueSec = EncodeString( aValueStr & GetHash( aValueStr, ChecksumSize ), true )
  end function

  function DecodeValueSec( aCode )
    dim value
    if IsDecodeValueSec( aCode, value ) then
      DecodeValueSec = value
    else
      DecodeValueSec = ""
    end if
  end function

  function IsDecodeValueSec( aCode, byRef aValueRet )
    dim codeLen, hash, code, value
    aValueRet = ""
    IsDecodeValueSec = false
    codeLen = Len(aCode)
    if codeLen < (2+2*ChecksumSize) then exit function
    code = DecodeString( aCode, true )
    if code = "" then exit function
    codeLen = Len(code)
    if codeLen < ChecksumSize then exit function
    hash = Right( code, ChecksumSize )
    value = Left( code, codeLen-ChecksumSize )
    if GetHash(value,ChecksumSize) <> hash then exit function
    aValueRet = value
    IsDecodeValueSec = true
  end function

  function IsValidValueSec( aCode )
    dim s
    IsValidValueSec = IsDecodeValueSec( aCode, s )
  end function

  function EncodeUnique( aID, aValue )
    EncodeUnique = EncodeValueSec( GetHash( aID, SaltSize ) & aValue )
  end function

  function DecodeUnique( aID, aCode, aDefault )
    dim value
    if IsDecodeUnique( aID, aCode, value ) then
      DecodeUnique = value
    else
      DecodeUnique = aDefault
    end if
  end function

  function IsDecodeUnique( aID, aCode, byRef aValueRet )
    dim valueUnique, salt, valueSalt, valLen
    aValueRet = ""
    IsDecodeUnique = false
    if not IsDecodeValueSec( aCode, valueUnique ) then exit function
    valLen = Len(valueUnique)
    if valLen < SaltSize then exit function
    salt = GetHash( aID, SaltSize )
    valueSalt = Left( valueUnique, SaltSize )
    if salt <> valueSalt then exit function
    aValueRet = Right( valueUnique, valLen-SaltSize )
    IsDecodeUnique = true
  end function

  function GetHash( aStr, aLen )
    ' Computes a hash value for aStr of len aLen characters.
    ' Hash is computed by encoding aStr and taking the last aLen characters of that string.
    ' aStr is padded and repeated to generate a long enough string for a encoded string of len >= aLen.
    dim ns, s, hash
    ns = CLng((aLen+1)/2)
    if Len(aStr) < ns then
      s = aStr & "+/?%"
      while Len(s) < ns
        s = s & s
      wend
      s = Left( s, ns )
    else
      s = aStr
    end if
    hash = EncodeString( s, false )
    GetHash = Right( hash, aLen )
  end function

  function EncodeString( aStr, bRandomize )
    dim seed
    ' save and restore seed to get same random numbers every time
    ' but not affecting other Rnd() calls
    seed = Rnd()
    InitKey
    EncodeString = DoEncode( aStr, bRandomize )
    Rnd(-seed)
  end function

  private function DoEncode( aStr, bRandomize )
    ' aStr as string in unicode 16 bit
    dim code, i, ch, x, chLast
    chLast = 0
    if aStr = "" then
      DoEncode = ""
      exit function
    end if
    set code = NewStream( Len(aStr) + 1 )
    ' make a random key
    if bRandomize then
      Randomize
      x = CInt(Rnd() * 16384) and 16383
      Rnd(-0.838723648) ' encode x with this seed
      code.Add EncodeInt( x )
      Rnd(-x/16384) ' encode string with seed = x
    else
      Rnd(-0.838723648) ' encode string with this fix seed
    end if
    for i = 1 to Len(aStr)
      ch = AscW(Mid(aStr,i,1)) ' ch is unicode 16 bit!
      code.Add EncodeInt( ch xor chLast )
      chLast = ch
    next
    DoEncode = code.GetString(false)
  end function

  private function EncodeInt( aInt16 )
    dim chH, chL, msb, lsb
    EncodeInt = ""
    chH = (aInt16 and 65280) \ 256 ' mask FF00h -> 00FFh
    chL = (aInt16 and 255)         ' mask 00FFh
    ' encode high byte if not zero
    if chH > 0 then
      msb = ((chH and 240) \ 16) xor GetNextKey() ' mask 00F0h -> 000Fh
      lsb = (chH and 15) xor GetNextKey()         ' mask 000Fh
      EncodeInt = Chr(mAscSmallA + msb) & Chr(mAscSmallA + lsb)
    end if
    ' encode low byte of unicode
    msb = ((aInt16 and 240) \ 16) xor GetNextKey() ' mask 00F0h -> 000Fh
    lsb = (aInt16 and 15) xor GetNextKey()         ' mask 000Fh
    EncodeInt = EncodeInt & Chr(mAscBigA + msb) & Chr(mAscBigA + lsb)
  end function

  function DecodeString( aCode, bRandomize )
    dim seed
    ' save and restore seed to get same random numbers every time
    ' but not affecting other Rnd() calls
    seed = Rnd()
    InitKey
    DecodeString = DoDecode( aCode, bRandomize )
    Rnd(-seed)
  end function

  function DoDecode( aCode, bRandomize )
    ' aCode as string in unicode, where each character is [A-Pa-p] only!
    ' returns "" if aCode is malformed!
    dim str, i, cl, x, ch, chLast
    chLast = 0
    DoDecode = ""
    cl = Len(aCode)
    if cl < 2 then exit function
    set str = NewStream( CLng(cl\2) )
    i = 1
    ' read random key
    if bRandomize then
      Rnd(-0.838723648) ' decode x with this seed
      if not DecodeInt( aCode, cl, i, x ) then exit function
      Rnd(-x/16384) ' decode string with seed = x
    else
      Rnd(-0.838723648) ' decode string with this fix seed
    end if
    while i <= cl
      if not DecodeInt( aCode, cl, i, ch ) then exit function
      chLast = ch xor chLast
      str.Add ChrW( chLast )
    wend
    DoDecode = str.GetString(false)
  end function

  function DecodeInt( aCode, aLen, byRef aPos, byRef aIntRet )
    dim msb, lsb, ch1, ch2, chH, chL
    DecodeInt = false
    aIntRet = 0
    chH = 0
    ch1 = Asc(Mid(aCode,aPos,1))
    aPos = aPos + 1
    if aPos > aLen then exit function
    ' encode high byte if not zero (encoded as small a-p)
    if ch1 >= mAscSmallA and ch1 <= mAscSmallP then
      if aPos+2 > aLen then exit function
      ch2 = Asc(Mid(aCode,aPos,1))
      aPos = aPos + 1
      if ch2 < mAscSmallA or ch2 > mAscSmallP then exit function
      msb = (ch1 - mAscSmallA) xor GetNextKey()
      lsb = (ch2 - mAscSmallA) xor GetNextKey()
      chH = (msb * 16) + lsb
      ch1 = Asc(Mid(aCode,aPos,1))
      aPos = aPos + 1
    end if
    if ch1 < mAscBigA or ch1 > mAscBigP then exit function
    ch2 = Asc(Mid(aCode,aPos,1))
    aPos = aPos + 1
    if ch2 < mAscBigA or ch2 > mAscBigP then exit function
    msb = (ch1 - mAscBigA) xor GetNextKey()
    lsb = (ch2 - mAscBigA) xor GetNextKey()
    chL = (msb * 16) + lsb
    aIntRet = chH * 256 + chL
    DecodeInt = true
  end function

  sub SetCookie( aCookieName, aName, aValue )
    ' save value in encrypted cookie; Name is also encrypted!
    dim xName, xValue
    xName = EncodeName( aName )
    if aValue = "" then
      xValue = ""
    else
      xValue = EncodeValueSec( aValue )
    end if
    Response.Cookies(aCookieName)(xName) = xValue
  end sub

  function GetCookie( aCookieName, aName )
    ' get encrypted cookie
    dim xName, xValue
    xName = EncodeName( aName )
    xValue = Request.Cookies(aCookieName)(xName)
    if xValue <> "" then
      GetCookie = DecodeValueSec( xValue )
    else
      GetCookie = ""
    end if
  end function

  function GetValidCookie( aCookieName, aName, byRef aValueRet )
    ' get encrypted cookie
    dim xName, xValue
    GetValidCookie = false
    aValueRet = ""
    xName = EncodeName( aName )
    xValue = Request.Cookies(aCookieName)(xName)
    if xValue = "" then exit function
    GetValidCookie = IsDecodeValueSec( xValue, aValueRet )
  end function

  sub SetSession( aName, aValue )
    ' save value in encrypted session var; Name is also encrypted!
    dim xName, xValue
    xName = EncodeName( aName )
    if aValue = "" then
      xValue = ""
    else
      xValue = EncodeValueSec( aValue )
    end if
    Session(xName) = xValue
  end sub

  function GetSession( aName )
    ' get encrypted session var
    dim xName, xValue
    xName = EncodeName( aName )
    xValue = Session(xName)
    if xValue = "" then
      GetSession = ""
    else
      GetSession = DecodeValueSec( xValue )
    end if
  end function

end class

dim Coder
set Coder = new CCoder
%>

Weitere Infos zur Seite
Erzeugt Freitag, 28. Februar 2014
von wabis
Zum Seitenanfang
Geändert Mittwoch, 5. März 2014
von *System*