# data.tcl --
#
#       This file is a part of the Off-the-Record messaging protocol
#       implementation. It contains the decoding/encoding procedures.
#
# Copyright (c) 2014 Sergei Golovan <sgolovan@nes.ru>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAMER OF ALL WARRANTIES.
#
# $Id$

package require base64

package provide otr::data 0.1

##############################################################################

namespace eval ::otr::data {
    set WSHeader " \t  \t\t\t\t \t \t \t  "
    set WSv1 " \t \t  \t "
    set WSv2 "  \t\t  \t "
    set WSv3 "  \t\t  \t\t"
}

# ::otr::data::Bin2Int --
#
#       Convert binary into an unsigned integer treating binary as a big
#       endian byte array.
#
# Arguments:
#       data        Binary to convert.
#
# Result:
#       Arbitrary length integer which corresponds to the given binary.
#
# Side effects:
#       None.

proc ::otr::data::Bin2Int {data} {
    binary scan $data cu* clist
    set int [lindex $clist 0]
    foreach c [lrange $clist 1 end] {
        set int [expr {$int*256 + $c}]
    }
    set int
}

# ::otr::data::encodeMessage --
#
#       Encode binary message using BASE64 and add ?OTR: prefix and . suffix.
#
# Arguments:
#       data        Binary OTR message.
#
# Result:
#       BASE64 encoded message ready for transmission.
#
# Side effects:
#       None.

proc ::otr::data::encodeMessage {data} {
    return ?OTR:[::base64::encode -maxlen 0 $data].
}

# ::otr::data::binaryMessage --
#
#       Decode BASE64 message with ?OTR prefix and parse out the protocol
#       version, the packet type and for version 3 packets the sender and
#       receiver's instances.
#
# Arguments:
#       data        Received or assembled from the fragments OTR BASE64
#                   encoded message.
#
# Result:
#       Tuple {version type binary ?sinstance rinstance?} where version is
#       the OTR version, type is the packet type, sinstance is a sender's
#       instance, rinstance is a receiver's instance, and binary is the
#       rest of the binary message.
#
# Side effects:
#       Error is raised if the message doesn't start with ?OTR: or if the
#       BASE64 decoded message is too short to contain the protocol version,
#       message type and sender and recipient instance tags (for version 3).

proc ::otr::data::binaryMessage {data} {
    if {![scan $data {?OTR:%[^.].} message] == 1} {
        return -code error "Message doesn't contain OTR marker"
    }
    set binary [::base64::decode $message]
    lassign [decode SHORT $binary] version binary
    lassign [decode BYTE $binary] type binary
    if {$version >= 3} {
        lassign [decode INT $binary] sinstance binary
        lassign [decode INT $binary] rinstance binary
        return [list $version $type $binary $sinstance $rinstance]
    } else {
        return [list $version $type $binary]
    }
}

# ::otr::data::binaryMessageFragment --
#
#       Decode the OTR message fragment and return its piece number, the total
#       number of pieces, the message fragment and the sender and receiver's
#       instance tags for version 3 packages.
#
# Arguments:
#       data        Received OTR message fragment.
#
# Result:
#       Tuple {version part numpatrs message ?sinstance rinstance?} where
#       version is the protocol version, part is a piece number, numparts is a
#       total number of parts, message is an OTR message fragment, sinstance
#       is a sender's sinstance tag, rinstance is a receiver's instance tag.
#
# Side effects:
#       Error is raised if this data is not an OTR message fragment.

proc ::otr::data::binaryMessageFragment {data} {
    if {[scan $data {?OTR|%x|%x,%u,%u,%[^,],} \
                    sinstance rinstance part numparts message] == 5} {
        return [list 3 $part $numparts $message $sinstance $rinstance]
    } elseif {[scan $data {?OTR,%u,%u,%[^,],} part numparts message] == 3} {
        return [list 2 $part $numparts $message]
    } else {
        return -code error "Message doesn't contain OTR part marker"
    }
}

# ::otr::data::queryMessage --
#
#       Return the OTR query message.
#
# Arguments:
#       policy      The correspondent policy list.
#
# Result:
#       The OTR query message which requests an OTR conversation with
#       protocol versions including 2 if ALLOW_V2 belongs to the policy
#       and 3 id ALLOW_V3 belongs to the policy.
#
# Side effects:
#       Error is raised if the policy contains ALLOW_V1.

proc ::otr::data::queryMessage {policy} {
    set res ?OTR
    if {"ALLOW_V1" in $policy} {
        return -code error "OTR version 1 is not supported"
    }
    append res v
    if {"ALLOW_V2" in $policy} {
        append res 2
    }
    if {"ALLOW_V3" in $policy} {
        append res 3
    }
    return $res?
}

# ::otr::data::findQueryMessage --
#
#       Parse the OTR query message if it is given.
#
# Arguments:
#       message     Message to parse.
#
# Result:
#       OTR versions list from the message if it is the OTR query message,
#       or error if it is not.
#
# Side effects:
#       Error is raised if the message is not an OTR query message.

proc ::otr::data::findQueryMessage {message} {
    if {![regexp {^\?OTR(\??)(?:v([^?]*))?\?} $message -> v1 v2]} {
        # BUG: ?OTR? shows no support for version 1, though it doesn't
        #      matter because we don't support OTR version 1
        return -code error "Message is not an OTR query message"
    }
    set res {}
    if {$v1 eq "?"} {
        lappend res 1
    }
    set res [concat $res [split $v2 ""]]
    return [lsort -unique $res]
}

# ::otr::data::whitespaceTag --
#
#       Return the OTR whitespace tag corresponding to a given policy.
#
# Arguments:
#       policy      The correspondent policy list.
#
# Result:
#       The OTR whitespace tag which indicates the willing to start an OTR
#       conversation with protocol versions 2 if ALLOW_V2 belongs to the
#       policy and 3 if ALLOW_V3 belongs to the policy.
#
# Side effects:
#       Error is raised if ALLOW_V1 belongs to the policy.

proc ::otr::data::whitespaceTag {policy} {
    variable WSHeader
    variable WSv2
    variable WSv3

    set res $WSHeader
    if {"ALLOW_V1" in $policy} {
        return -code error "OTR version 1 is not supported"
    }
    if {"ALLOW_V2" in $policy} {
        append res $WSv2
    }
    if {"ALLOW_V3" in $policy} {
        append res $WSv3
    }
    set res
}

# ::otr::data::findWhitespaceTag --
#
#       Find the OTR whitespace tag in a plaintext message.
#
# Arguments:
#       message     Message to search.
#
# Result:
#       OTR versions list from the message if the whitespace tag is found,
#       or error if it is not.
#
# Side effects:
#       Error is raised if the message doesn't contain the whitespace tag.

proc ::otr::data::findWhitespaceTag {message} {
    variable WSHeader
    variable WSv1
    variable WSv2
    variable WSv3

    set idx [string first $WSHeader $message]
    if {$idx < 0} {
        return -code error "There's no whitespace tag in the message"
    }
    set res {}
    set str1 [string range $message [expr {$idx+16}] [expr {$idx+23}]]
    set str2 [string range $message [expr {$idx+24}] [expr {$idx+31}]]
    set str3 [string range $message [expr {$idx+32}] [expr {$idx+39}]]
    if {$str1 eq $WSv1 || $str2 eq $WSv1 || $str3 eq $WSv1} {
        lappend res 1
    }
    if {$str1 eq $WSv2 || $str2 eq $WSv2 || $str3 eq $WSv2} {
        lappend res 2
    }
    if {$str1 eq $WSv3 || $str2 eq $WSv3 || $str3 eq $WSv3} {
        lappend res 3
    }
    return $res
}

# ::otr::data::removeWhitespaceTag --
#
#       Remove the OTR whitespace tag from a plaintext message.
#
# Arguments:
#       message     Message to search.
#
# Result:
#       The given message without the OTR whitespace tag if was any.
#
# Side effects:
#       None.

proc ::otr::data::removeWhitespaceTag {message} {
    variable WSHeader
    variable WSv1
    variable WSv2
    variable WSv3

    string map [list $WSHeader "" $WSv1 "" $WSv2 "" $WSv3 ""] $message
}

# ::otr::data::errorMessage --
#
#       Create an OTR error message.
#
# Arguments:
#       error       The error text.
#
# Result:
#       The OTR error message.
#
# Side effects:
#       None.

proc ::otr::data::errorMessage {error} {
    return "?OTR Error: $error"
}

# ::otr::data::findErrorMessage --
#
#       Check if a given message is an OTR error message and return the error
#       text.
#
# Arguments:
#       message     Message to check.
#
# Result:
#       The error text or error if the message is not an OTR error message.
#
# Side effects:
#       Error is raised if the message is not an OTR error message.

proc ::otr::data::findErrorMessage {message} {
    if {[regexp {^\?OTR Error:\s*(.*)} $message -> error]} {
        return $error
    } else {
        return -code error "Message is not an OTR error message"
    }
}

# ::otr::data::encode --
#
#       Encode given data to the binary format suitable for inclusion into
#       an OTR binary message.
#
# Arguments:
#       type        Data type (BYTE, SHORT, INT, MPI, DATA, CTR, MAC, PUBKEY,
#                   SIG).
#       data        Data to encode (for BYTE, SHORT, INT, MPI, CTR it's a
#                   number, for DATA, MAC it's a binary string, for PUBKEY
#                   it's a list of 4 numbers {p q g y}, for SIG it's a list
#                   of 2 numbers {r s}).
#
# Result:
#       Binary string.
#
# Side effects:
#       None.

proc ::otr::data::encode {type data} {
    switch -- $type {
        BYTE {
            return [binary format cu $data]
        }
        SHORT {
            return [binary format Su $data]
        }
        INT {
            return [binary format Iu $data]
        }
        MPI {
            if {$data == 0} {
                return [binary format Iucu 1 0]
            }
            set len 0
            set res ""
            while {$data > 0} {
                incr len
                set res [binary format cu [expr {$data % 256}]]$res
                set data [expr {$data / 256}]
            }
            return [binary format Iu $len]$res
        }
        DATA {
            return [binary format Iu [string length $data]]$data
        }
        CTR {
            return [binary format Wu $data]
        }
        MAC {
            return [string range $data 0 19]
        }
        PUBKEY {
            lassign $data p q g y
            set res [encode SHORT 0] ; # DSA key only
            append res [encode MPI $p]
            append res [encode MPI $q]
            append res [encode MPI $g]
            append res [encode MPI $y]
            return $res
        }
        SIG {
            lassign $data r s
            set res [binary format IuIuIuIuIu \
                            [expr {$r / (256**16)}] \
                            [expr {($r / (256**12)) % (256**4)}] \
                            [expr {($r / (256**8)) % (256**4)}] \
                            [expr {($r / (256**4)) % (256**4)}] \
                            [expr {$r % (256**4)}]]
            append res [binary format IuIuIuIuIu \
                               [expr {$s / (256**16)}] \
                               [expr {($s / (256**12)) % (256**4)}] \
                               [expr {($s / (256**8)) % (256**4)}] \
                               [expr {($s / (256**4)) % (256**4)}] \
                               [expr {$s % (256**4)}]]
            return $res
        }
    }
}

# ::otr::data::decode --
#
#       Decode a portion of given binary string and return the decoded
#       value and the rest of the string.
#
# Arguments:
#       type        Type of the decoded chunk.
#       data        Binary string to decode.
#
# Result:
#       List of two items: the decoded data chunk (the same as is given to
#       ::otr::data::encode proc) and the rest of the input data.
#
# Side effects:
#       None.

proc ::otr::data::decode {type data} {
    switch -- $type {
        BYTE {
            if {[binary scan $data cu num]} {
                set res $num
                set data [string range $data 1 end]
            } else {
                return -code error "Invalid BYTE"
            }
        }
        SHORT {
            if {[binary scan $data Su num]} {
                set res $num
                set data [string range $data 2 end]
            } else {
                return -code error "Invalid SHORT"
            }
        }
        INT {
            if {[binary scan $data Iu num]} {
                set res $num
                set data [string range $data 4 end]
            } else {
                return -code error "Invalid INT"
            }
        }
        MPI {
            if {[binary scan $data Iu len]} {
                set res [Bin2Int [string range $data 4 [expr {$len+3}]]]
                set data [string range $data [expr {$len+4}] end]
            } else {
                return -code error "Invalid MPI"
            }
        }
        DATA {
            if {[binary scan $data Iu len]} {
                set res [string range $data 4 [expr {$len+3}]]
                set data [string range $data [expr {$len+4}] end]
            } else {
                return -code error "Invalid DATA"
            }
        }
        CTR {
            if {[binary scan $data Wu num]} {
                set res $num
                set data [string range $data 8 end]
            } else {
                return -code error "Invalid CTR"
            }
        }
        MAC {
            set res [string range $data 0 19]
            set data [string range $data 20 end]
        }
        PUBKEY {
            lassign [decode SHORT $data] keytype data
            if {$keytype != 0} {
                return -code error "Only DSA keys are supported"
            }
            lassign [decode MPI $data] p data
            lassign [decode MPI $data] q data
            lassign [decode MPI $data] g data
            lassign [decode MPI $data] y data
            set res [list $p $q $g $y]
        }
        SIG {
            set r [Bin2Int [string range $data 0 19]]
            set s [Bin2Int [string range $data 20 39]]
            set res [list $r $s]
            set data [string range $data 40 end]
        }
    }
    list $res $data
}

# ::otr::data::encodeTLV --
#
#       Encode a TLV record for an OTR data message.
#
# Arguments:
#       type            TLV type (non-negative integer).
#       data            TLV payload (binary string).
#
# Result:
#       Binary string with encoded TLV.
#
# Side effects:
#       None.

proc ::otr::data::encodeTLV {type data} {
    return [encode SHORT $type][encode SHORT [string length $data]]$data
}

# ::otr::data::decodeTLV --
#
#       Decode a TLV record from an OTR data message.
#
# Arguments:
#       data            Binary string with encoded TLV in it.
#
# Result:
#       Tuple {type, payload, rest} where type is a TLV type, payload is a
#       TLV payload, and rest is the rest of the given data.
#
# Side effects:
#       Error is raised if decoding fails.

proc ::otr::data::decodeTLV {data} {
    lassign [decode SHORT $data] type data
    lassign [decode SHORT $data] length data
    list $type [string range $data 0 [expr {$length-1}]] \
               [string range $data $length end]
}

# ::otr::data::Bin2Hex --
#
#       Convert binary string to hex representation. Useful for debugging.
#
# Arguments:
#       data            Binary data to print.
#
# Result:
#       Hexadecimal string.
#
# Side effects:
#       None.

proc ::otr::data::Bin2Hex {data} {
    binary scan $data H* hex
    set hex
}

# vim:ts=8:sw=4:sts=4:et
