{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE RecordWildCards, BangPatterns, ViewPatterns, DeriveDataTypeable #-}
module Network.Hermes.Protocol where

import Control.Applicative
import Control.Monad
import Control.Exception
import Data.Typeable
import Data.Data

import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8

import Network.Hermes.Misc

import Data.Serialize
import Data.Serialize.Put
import Data.Serialize.Get
import Codec.Digest.SHA
import Codec.Crypto.RSA
import Network.Socket(HostName)
import Data.Serialize

-- * Errors

-- | Most Hermes functions can throw one of these exceptions, which
-- | are mainly triggered when (re)negotiating connections.
data HermesException = HermesIDUnknown HermesID
                       -- ^ Hermes has no idea who you're talking about. How did you even get the HermesID?
                       -- HermesID information is never discarded, so this exception should be rather uncommon.
                     | AddressUnknown HermesID
                       -- ^ We don't know where this HermesID is; we never did, or old information proved to be false.
                     | DNSFailure Address
                       -- ^ Failed to resolve the address
                     | WrongProtocol
                       -- ^ The remote server is not speaking Hermes-speak.
                     | ProtocolVersionMismatch Word32 Word32
                       -- ^ A different protocol version is in use at the remote host. Check library version.
                     | AuthError String
                       -- ^ Something went wrong while authenticating. Have a reason.
                     | DeserializationError String
                       -- ^ Something went wrong while deserializing your data.
                     | ListenerAlreadyExists
                       -- ^ Attempted to create a listener on a port we're already listening to
                     | MessageError
                       -- ^ Message corrupted (connection broken)
                     | Timeout
                       -- ^ Some operation took longer than the user-configured timeout
                     | RecvCancelled
                       -- ^ Receive was explicitly cancelled by the user
                     deriving (Typeable,Show,Eq)

instance Exception HermesException

-- | Exceptions that are handled by simply closing the connection
data CloseException = EOF
                    deriving (Typeable,Show,Eq)

instance Exception CloseException

decode' :: Serialize a => B.ByteString -> a
decode' = either (throw . DeserializationError) id . decode

runGet' :: Get a -> B.ByteString -> a
runGet' g = either (throw . DeserializationError) id . runGet g


-- * And some types

data Address = IP HostName Int -- ^ Host name and port, IPv4, IPv6, or both
             | IPv4 HostName Int -- ^ IPv4 only
             | IPv6 HostName Int -- ^ IPv6 only
             | Unix FilePath -- ^ Unix domain socket, not available on Windows
             deriving(Show,Read,Eq,Ord,Typeable,Data)

instance Serialize Address where
  put (IP a b)   = putWord8 0 >> put a >> put b
  put (IPv4 a b) = putWord8 1 >> put a >> put b
  put (IPv6 a b) = putWord8 2 >> put a >> put b
  put (Unix a)   = putWord8 3 >> put a
  get = do
    tag <- getWord8
    case tag of
      0 -> IP <$> get <*> get
      1 -> IPv4 <$> get <*> get
      2 -> IPv6 <$> get <*> get
      3 -> Unix <$> get
      _ -> error "Corrupted binary data for Address"


-- * Cryptographic parameters

-- | AES session key size, in bits
aesKeySize :: Int
aesKeySize = 128

-- | Cipher to use for encrypting the session key
evpCipher :: String
evpCipher = "aes-128-cbc"

-- | Hash used all over the place
evpHash :: String
evpHash = "sha256"

-- | RSA key size, in bits; 512 <= size <= 1024
rsaKeySize :: Int
rsaKeySize = 1024

-- | DSA key size, for the signature authorities
dsaKeySize :: Int
dsaKeySize = 1024

-- * Line protocol

-- | Unchangeable bytes telling peers that this.. is... HERMES!
magicString :: B.ByteString
magicString = B8.pack "This.. is... HERMES!\n"

protocolVersion :: Word32 -- Do not change type
protocolVersion = 0

data KeyQuery = KeyOK | RequestKey
              deriving(Show)

-- | A hash computed from a public key
type HermesID = Integer

data KeyReply = KeyReply { keyReplyKey :: PublicKey
                          ,keyReplySig :: Maybe B.ByteString
                         } deriving(Show)

-- | If Indirect, require a signature from an authority.
--
-- If Direct, require an OK from the library client.
--
-- If None, no trust is required.
data TrustLevel = None | Indirect | Direct
                deriving(Eq,Ord,Show)

data SessionSetup = SessionSetup { 
  setupKey
  ,setupIV
  ,setupChallenge :: B.ByteString
  ,clientAddress :: Maybe Address
  }
                deriving(Show)

data AnyMessage = AKeyQuery KeyQuery
                | AKeyReply KeyReply
                | AChallenge B.ByteString
                | ASessionSetup B.ByteString
                | AHermesID HermesID
                deriving(Show)

-- | If a message (m :: t) is discarded, then a RejectedMessage is
-- sent in reply, with (showType t,encode (original tag)) as the tag. The message body
-- is discarded.
data RejectedMessage = RejectedMessage
                     deriving(Typeable)

instance Serialize RejectedMessage where
  put _ = return ()
  get   = return RejectedMessage


instance Serialize PublicKey where
  put PublicKey{..} = put public_size >> put public_n >> put public_e
  get = do
    public_size <- get
    public_n <- get
    public_e <- get
    return PublicKey{..}

instance Serialize PrivateKey where
  put PrivateKey{..} = put private_size >> put private_n >> put private_d
  get = do
    private_size <- get
    private_n <- get
    private_d <- get
    return PrivateKey{..}

-- GENERATED START

instance Serialize KeyQuery where
        put x
          = case x of
                KeyOK -> putWord8 0
                RequestKey -> putWord8 1
        get
          = do i <- getWord8
               case i of
                   0 -> return KeyOK
                   1 -> return RequestKey
                   _ -> error "Corrupted binary data for KeyQuery"

 
instance Serialize KeyReply where
        put (KeyReply x1 x2)
          = do put x1
               put x2
        get
          = do x1 <- get
               x2 <- get
               return (KeyReply x1 x2)

 
instance Serialize TrustLevel where
        put x
          = case x of
                None -> putWord8 0
                Indirect -> putWord8 1
                Direct -> putWord8 2
        get
          = do i <- getWord8
               case i of
                   0 -> return None
                   1 -> return Indirect
                   2 -> return Direct
                   _ -> error "Corrupted binary data for TrustLevel"

 
instance Serialize SessionSetup where
        put (SessionSetup x1 x2 x3 x4)
          = do put x1
               put x2
               put x3
               put x4
        get
          = do x1 <- get
               x2 <- get
               x3 <- get
               x4 <- get
               return (SessionSetup x1 x2 x3 x4)

 
instance Serialize AnyMessage where
        put x
          = case x of
                AKeyQuery x1 -> do putWord8 1
                                   put x1
                AKeyReply x1 -> do putWord8 2
                                   put x1
                AChallenge x1 -> do putWord8 3
                                    put x1
                ASessionSetup x1 -> do putWord8 4
                                       put x1
                AHermesID x1 -> do putWord8 5
                                   put x1
        get
          = do i <- getWord8
               case i of
                   1 -> do x1 <- get
                           return (AKeyQuery x1)
                   2 -> do x1 <- get
                           return (AKeyReply x1)
                   3 -> do x1 <- get
                           return (AChallenge x1)
                   4 -> do x1 <- get
                           return (ASessionSetup x1)
                   5 -> do x1 <- get
                           return (AHermesID x1)
                   _ -> error "Corrupted binary data for AnyMessage"
-- GENERATED STOP