get.hs

-- base
import Control.Applicative
import Control.Monad

import Data.Maybe
import Data.Word
import Data.Proxy

import GHC.TypeLits

-- bytestring
import Data.ByteString hiding ( empty )

-- binary
import Data.Binary
import Data.Binary.Get

type BYTE        = Word8
type SHORT       = Word16
type INT         = Word32
type MPI         = ByteString
type DATA        = ByteString
type CTR         = ByteString
type MAC         = ByteString
type InstanceTag = INT

data OtrMessage payload = OtrMessage
    { protovolVersion     :: !SHORT
    , senderInstanceTag   :: !InstanceTag
    , receiverInstanceTag :: !InstanceTag
    , messagePayloda      :: !payload }
    deriving (Eq, Show)

data DiffieHellmanCommit = MkDiffieHellmanCommit { encryptedGX :: !DATA, hashedGX :: !DATA }
    deriving (Eq, Show)

newtype DiffieHellmanKey = MkDiffieHellmanKey { gY :: MPI }
    deriving (Eq, Show)

data RevealSignature = MkRevealSignature
    { revealedKey :: !DATA, signature :: !Signature }
    deriving (Eq, Show)

data Signature = MkSignature
    { encryptedSignature :: !DATA, macSignature :: !MAC }
    deriving (Eq, Show)

data DataMessage = MkDataMessage
    { flags                  :: !BYTE
    , senderKeyID            :: !INT
    , recipientKeyID         :: !INT
    , dhY                    :: !MPI
    , topHalfOfCounterInit   :: !CTR
    , encryptedMessage       :: !DATA
    , authenticator          :: !MAC
    , oldMacKeysToBeRevealed :: !DATA }
    deriving (Eq, Show)

data AnyMessage
    = DiffieHellmanCommit DiffieHellmanCommit
    | DiffieHellmanKey DiffieHellmanKey
    | RevealSignature RevealSignature
    | Signature Signature
    | DataMessage DataMessage
    deriving (Eq, Show)

type family MessageTag t where
    MessageTag DataMessage         = 0x03
    MessageTag DiffieHellmanCommit = 0x02
    MessageTag DiffieHellmanKey    = 0x0a
    MessageTag RevealSignature     = 0x11
    MessageTag Signature           = 0x12

byte :: Get BYTE
byte = get

short :: Get SHORT
short = getWord16be

int :: Get INT
int = getWord32be

mpi :: Get MPI
mpi = getWord32be >>= getByteString . fromIntegral

data_ :: Get DATA
data_ = mpi

otrHeader :: Get (BYTE, payload -> OtrMessage payload)
otrHeader = do
    v <- short
    t <- byte
    s <- int
    r <- int
    return (t, OtrMessage v s r)

otrMesage :: Get (OtrMessage DiffieHellmanCommit)
otrMesage = do
    (tag, f) <- otrHeader
    guard (toInteger tag == natVal (undefined :: Proxy (MessageTag DiffieHellmanCommit)))
    f <$> get