{-# LANGUAGE CPP             #-}
{-# LANGUAGE DeriveFunctor   #-}
{-# LANGUAGE NamedFieldPuns  #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TupleSections   #-}
{-# LANGUAGE TypeOperators   #-}
module Network.Tox.Handshake where

import Control.Arrow
import Control.Concurrent.STM
import Control.Monad
import Crypto.Hash
import Crypto.Tox
import Data.Functor.Identity
import Data.Time.Clock.POSIX
import Network.Tox.Crypto.Transport
import Network.Tox.DHT.Handlers     (createCookieSTM)
import Network.Tox.DHT.Transport    (Cookie (..), CookieData (..))
import Network.Tox.NodeId
#ifdef THREAD_DEBUG
#else
import Control.Concurrent
import GHC.Conc           (labelThread)
#endif
import DPut
import DebugTag


anyRight :: Monad m => a -> [t] -> (t -> m (Either b b1)) -> m (Either a b1)
anyRight e []     f = return $ Left e
anyRight e (x:xs) f = f x >>= either (const $ anyRight e xs f) (return . Right)

decryptHandshake :: TransportCrypto -> Handshake Encrypted -> IO (Either String (SecretKey,Handshake Identity))
decryptHandshake crypto hshake@(Handshake (Cookie n24 ecookie) nonce24 encrypted) = do
    (ukeys,symkey) <- atomically $ (,) <$> userKeys crypto
                                       <*> transportSymmetric crypto
    let seckeys = map fst ukeys
    now <- getPOSIXTime
    -- dput XNetCrypto "decryptHandshake: trying the following keys:"
    -- forM_ seckeys $ \k -> dput XNetCrypto $ "  " ++ show (key2id . toPublic $ k)
    fmap join . sequence $ do -- Either Monad
            cd@(CookieData cookieTime remotePubkey remoteDhtkey) <- decodePlain =<< decryptSymmetric symkey n24 ecookie
            Right $ do -- IO Monad
            decrypted <- anyRight "missing key" seckeys $ \key -> do
                            -- dput XNetCrypto $ "(NetCrypto)handshakeH: remotePubkey =  " ++ show (key2id $ remotePubkey)
                            -- dput XNetCrypto $ "(NetCrypto)handshakeH: nonce24 =  " ++ show nonce24
                            secret <- lookupSharedSecret crypto key remotePubkey nonce24
                            let step1 = decrypt secret encrypted
                            case step1 of
                                Left s -> do
                                    -- dput XNetCrypto $ "(NetCrypto)handshakeH: (decrypt) " ++ s
                                    return (Left s)
                                Right pln -> do
                                    case decodePlain pln of
                                        Left s -> do
                                            -- dput XNetCrypto $ "(NetCrypto)handshakeH: (decodePlain) " ++ s
                                            return (Left s)
                                        Right x -> return (Right (key,x))
            return $ do -- Either Monad
            (key,hsdata@HandshakeData { baseNonce, sessionKey, cookieHash, otherCookie }) <- decrypted
            left (asTypeOf "cookie too old") $ guard (now - fromIntegral cookieTime < 15)
            let hinit = hashInit
                hctx = hashUpdate hinit n24
                hctx' = hashUpdate hctx ecookie
                digest = hashFinalize hctx'
            left (asTypeOf "cookie digest mismatch") $ guard (cookieHash == digest)
            return ( key
                   , hshake { handshakeCookie = Cookie n24 (pure cd)
                            , handshakeData   = pure hsdata
                            } )


data HandshakeParams
        = HParam
            { hpTheirBaseNonce        :: Maybe Nonce24 -- ignore and generate your own
            , hpOtherCookie           :: Cookie Encrypted
            , hpTheirSessionKeyPublic :: Maybe PublicKey
            , hpMySecretKey           :: SecretKey
            , hpCookieRemotePubkey    :: PublicKey
            , hpCookieRemoteDhtkey    :: PublicKey
            }

{-
newHandShakeData :: POSIXTime -> TransportCrypto -> Nonce24 -> HandshakeParams -> NodeInfo -> PublicKey -> STM HandshakeData
newHandShakeData timestamp crypto basenonce hp nodeinfo mySessionPublic = do
    let HParam {hpOtherCookie,hpMySecretKey,hpCookieRemotePubkey,hpCookieRemoteDhtkey} = hp
        hinit                = hashInit
        Cookie n24 encrypted = hpOtherCookie
        hctx                 = hashUpdate hinit n24
        hctx'                = hashUpdate hctx encrypted
        digest               = hashFinalize hctx'
    freshCookie <- createCookieSTM timestamp crypto nodeinfo hpCookieRemotePubkey
    return HandshakeData
                { baseNonce   = basenonce
                , sessionKey  = mySessionPublic
                , cookieHash  = digest
                , otherCookie = freshCookie
                }
-}

toHandshakeParams :: (SecretKey, Handshake Identity) -> HandshakeParams
toHandshakeParams (key,hs)
    = let hd = runIdentity $ handshakeData hs
          Cookie _ cd0 = handshakeCookie hs
          CookieData _ remotePublicKey remoteDhtPublicKey = runIdentity cd0
      in HParam { hpTheirBaseNonce        = Just $ baseNonce hd
                , hpOtherCookie           = otherCookie hd
                , hpTheirSessionKeyPublic = Just $ sessionKey hd
                , hpMySecretKey           = key
                , hpCookieRemotePubkey    = remotePublicKey
                , hpCookieRemoteDhtkey    = remoteDhtPublicKey
                }

encodeHandshake :: POSIXTime
                   -> TransportCrypto
                   -> SecretKey
                   -> PublicKey
                   -> Cookie Encrypted
                   -> HandshakeData
                   -> STM (Handshake Encrypted)
encodeHandshake timestamp crypto me them otherCookie myhandshakeData = do
    n24 <- transportNewNonce crypto
    state <- ($ n24) <$> lookupNonceFunctionSTM crypto me them
    return Handshake { handshakeCookie = otherCookie
                     , handshakeNonce  = n24
                     , handshakeData   = encrypt state $ encodePlain myhandshakeData
                     }