#Implement MSCHAPv2 Protocol(RFC2759) by TCL
#Useage:(Client side) GenerateNTResponse $AuthenticatorChallenge $PeerChallenge $UserName $Password
#       (Server side) Not implement yet.
#This file was originally written by warmeng<[email protected]>
#Following package can be added by teacup if there isn't have it.
package require md4 1.0.5
package require sha1 2.0.3
package require des 1.1.0

#   The MS-CHAP-V2 Response packet is identical in format to the standard
#   CHAP Response packet.  However, the Value field is sub-formatted
#   differently as follows:
#
#   16 octets: Peer-Challenge
#    8 octets: Reserved, must be zero
#   24 octets: NT-Response
#    1 octet : Flags
#   The NT-Response field is an encoded function of the password, the
#   user name, the contents of the Peer-Challenge field and the received
#   challenge as output by the routine GenerateNTResponse()
#   example: GenerateNTResponse 17065a1393e73c761a05024e4ce2730b a0f39414f71bc3d31fac9f0a746e4743 test1 test


proc GenerateNTResponse {AuthenticatorChallenge PeerChallenge UserName Password} {
    #   GenerateNTResponse(
    #   IN  16-octet              AuthenticatorChallenge,
    #   IN  16-octet              PeerChallenge,
    #   IN  0-to-256-char         UserName,
    #   IN  0-to-256-unicode-char Password,
    #   OUT 24-octet              Response )
    #   {
    #      8-octet  Challenge
    #      16-octet PasswordHash
    #
    #      ChallengeHash( PeerChallenge, AuthenticatorChallenge, UserName,
    #                     giving Challenge)
    #
    #      NtPasswordHash( Password, giving PasswordHash )
    #      ChallengeResponse(Challenge, PasswordHash, giving Response )
    #   }
    set Challenge [ChallengeHash $PeerChallenge $AuthenticatorChallenge $UserName]
        set PasswordHash [NtPasswordHash $Password]
        #return Response
        set Response [ChallengeResponse $Challenge $PasswordHash]
        return $Response
}
proc ChallengeHash {PeerChallenge AuthenticatorChallenge UserName}  {
     #sha algorithm
        #   IN 16-octet               PeerChallenge,
        #   IN 16-octet               AuthenticatorChallenge,
        #   IN  0-to-256-char         UserName,
        #   OUT 8-octet               Challenge
        set tok [sha1::SHA1Init]
        sha1::SHA1Update $tok [binary format H* $PeerChallenge]
        sha1::SHA1Update $tok [binary format H* $AuthenticatorChallenge]
        sha1::SHA1Update $tok $UserName
        set shaResult [sha1::Hex [sha1::SHA1Final $tok]]
        #OUT first 8-octet challenge
        set Challenge [string range $shaResult 0 15]
        return $Challenge
}
proc utfize {string} { 
     set rc ""; foreach char [split $string ""] { 
         scan $char %c chr
              append rc [format %02x $chr]
                          append rc 00
     } 
     return $rc
        }
proc NtPasswordHash {Password} {
    # md4, !!!Attention,password need transform to unicode
        #0-to-256-unicode-char Password,
        return [md4::md4 -hex [binary format H* [utfize $Password]]]
}
proc HashNtPasswordHash {PasswordHash} {
    # md4
        return PasswordHashHash
}
proc ChallengeResponse {Challenge PasswordHash} {
    #ChallengeResponse(
    #   IN  8-octet  Challenge,
    #   IN  16-octet PasswordHash,
    #   OUT 24-octet Response )
    #   {
    #      Set ZPasswordHash to PasswordHash zero-padded to 21 octets
    #
    #      DesEncrypt( Challenge,
    #                  1st 7-octets of ZPasswordHash,
    #                  giving 1st 8-octets of Response )
    #
    #      DesEncrypt( Challenge,
    #                  2nd 7-octets of ZPasswordHash,
    #                  giving 2nd 8-octets of Response )
    #
    #      DesEncrypt( Challenge,
    #                  3rd 7-octets of ZPasswordHash,
    #                  giving 3rd 8-octets of Response )
    #   }
        set padding [string repeat 00 5]
        append ZPasswordHash $PasswordHash
        append ZPasswordHash $padding
        append Response [DesEncrypt $Challenge [string range $ZPasswordHash 0 13]]
        append Response [DesEncrypt $Challenge [string range $ZPasswordHash 14 27]]
        append Response [DesEncrypt $Challenge [string range $ZPasswordHash 28 41]]
        return $Response
}
proc DesEncrypt {Clear Key} {
    #   DesEncrypt(
    #   IN  8-octet Clear,
    #   IN  7-octet Key,
    #   OUT 8-octet Cypher )
    #   {
    #      /*
    #       * Use the DES encryption algorithm [4] in ECB mode [10]
    #       * to encrypt Clear into Cypher such that Cypher can
    #       * only be decrypted back to Clear by providing Key.
    #       * Note that the DES algorithm takes as input a 64-bit
    #       * stream where the 8th, 16th, 24th, etc.  bits are
    #       * parity bits ignored by the encrypting algorithm.
    #       * Unless you write your own DES to accept 56-bit input
    #       * without parity, you will need to insert the parity bits
    #       * yourself.
    #       */
    #   }
    #set iv [string repeat \0 8]
    #set Key [DES::Init ecb [binary format H* [addParitybit $Key]] $iv]
    #set Cypher [sha1::Hex [DES::Encrypt $Key [binary format H* $Clear]]]
    #DES::Reset $Key $iv
    #DES::Final $Key
    set Cypher [DES::des -mode ecb -dir encrypt -hex -key [binary format H* [addParitybit $Key]] [binary format H* $Clear]]
    return $Cypher
}
proc DesDecrypt {Cypher Key} {
    #   DesEncrypt(
    #   IN  8-octet Clear,
    #   IN  7-octet Key,
    #   OUT 8-octet Cypher )
    #   {
    #      /*
    #       * Use the DES encryption algorithm [4] in ECB mode [10]
    #       * to encrypt Clear into Cypher such that Cypher can
    #       * only be decrypted back to Clear by providing Key.
    #       * Note that the DES algorithm takes as input a 64-bit
    #       * stream where the 8th, 16th, 24th, etc.  bits are
    #       * parity bits ignored by the encrypting algorithm.
    #       * Unless you write your own DES to accept 56-bit input
    #       * without parity, you will need to insert the parity bits
    #       * yourself.
    #       */
    #   }
    set Clear [DES::des -mode ecb -dir decrypt -hex -key [binary format H* [addParitybit $Key]] [binary format H* $Cypher]]
    return $Clear
}