path: root/ToxAddress.hs

{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveTraversable          #-}
{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE PatternSynonyms            #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE TypeApplications           #-}
module ToxAddress where

import Control.Applicative
import Control.Monad
import qualified Data.Aeson                   as JSON
         ;import Data.Aeson                   (FromJSON, ToJSON, (.=))
import Data.Bits
import Data.Bits.ByteString                   ()
import Data.ByteArray                         as BA (ByteArrayAccess, Bytes)
import qualified Data.ByteArray as BA
import qualified Data.ByteString              as B
         ;import Data.ByteString              (ByteString)
import qualified Data.ByteString.Base16       as Base16
import qualified Data.ByteString.Char8        as C8
import Data.Char
import Data.Data
import Data.Hashable
import Data.IP
import Data.Serialize                         as S
import Data.Word
import Network.Address                        hiding (nodePort)
import Network.Socket
import qualified Text.ParserCombinators.ReadP as RP
import Text.Read
import GHC.TypeLits
import Crypto.PubKey.Curve25519

data Address
 = DHTNode        NodeInfo                 -- A direct DHT exchange.
 | OnionFromOwner NodeInfo (ForwardPath 3) -- Your own created onion path.
 | OnionToOwner   NodeInfo (ReturnPath 3)  -- An onion path end point.

-- | perform io for hashes that do allocation and ffi.
-- unsafeDupablePerformIO is used when possible as the
-- computation is pure and the output is directly linked
-- to the input. we also do not modify anything after it has
-- been returned to the user.
unsafeDoIO :: IO a -> a
#if __GLASGOW_HASKELL__ > 704
unsafeDoIO = unsafeDupablePerformIO
#else
unsafeDoIO = unsafePerformIO
#endif

unpackPublicKey :: PublicKey -> [Word64]
unpackPublicKey bs = loop 0
  where loop i
            | i == 4    = []
            | otherwise =
                let !v = unsafeDoIO $ BA.withByteArray bs (\p -> peekElemOff p i)
                 in v : loop (i+1)

newtype NodeId = NodeId PublicKey
 deriving (Eq,ByteArrayAccess) -- (Eq,Ord,ByteArrayAccess, Bits, Hashable)

instance Ord NodeId where
    compare (NodeId a) (NodeId b) = compare (unpackPublicKey a) (unpackPublicKey b)

zeroID :: NodeId
zeroID = NodeId $ throwCryptoError $ publicKey $ B.replicate 32 0

{-
instance Read NodeId where
    readsPrec _ str
        | (bs, xs) <- Base16.decode $ C8.pack str
        , B.length bs == 32
                    = [ (NodeId bs, drop 64 str) ]
        | otherwise = []
-}

instance Show NodeId where
    show (NodeId bs) = C8.unpack $ Base16.encode $ BA.convert bs

instance S.Serialize NodeId where
    get = NodeId . throwCryptoError . publicKey <$> S.getBytes 32
    put (NodeId bs) = S.putByteString $ BA.convert bs

data NodeInfo = NodeInfo
  { nodeId   :: NodeId
  , nodeIP   :: IP
  , nodePort :: PortNumber
  }
 deriving (Eq,Ord)

nodeInfo :: NodeId -> SockAddr -> Either String NodeInfo
nodeInfo nid saddr
    | Just ip <- fromSockAddr saddr
    , Just port <- sockAddrPort saddr = Right $ NodeInfo nid ip port
    | otherwise                       = Left "Address family not supported."


instance ToJSON NodeInfo where
    toJSON (NodeInfo nid (IPv4 ip) port)
        = JSON.object [ "public_key" .= show nid
                      , "ipv4" .= show ip
                      , "port" .= (fromIntegral port :: Int)
                      ]
    toJSON (NodeInfo nid (IPv6 ip6) port)
        | Just ip <- un4map ip6
          = JSON.object [ "public_key" .= show nid
                        , "ipv4" .= show ip
                        , "port" .= (fromIntegral port :: Int)
                        ]
        | otherwise
          = JSON.object [ "public_key" .= show nid
                        , "ipv6" .= show ip6
                        , "port" .= (fromIntegral port :: Int)
                        ]
instance FromJSON NodeInfo where
    parseJSON (JSON.Object v) = do
        nidstr <- v JSON..: "public_key"
        ip6str <- v JSON..:? "ipv6"
        ip4str <- v JSON..:? "ipv4"
        portnum <- v JSON..: "port"
        ip <- maybe empty (return . IPv6) (ip6str >>= readMaybe)
              <|> maybe empty (return . IPv4) (ip4str >>= readMaybe)
        let (bs,_) = Base16.decode (C8.pack nidstr)
        guard (B.length bs == 32)
        return $ NodeInfo (NodeId $ throwCryptoError . publicKey $ bs) ip (fromIntegral (portnum :: Word16))

getIP :: Word8 -> S.Get IP
getIP 0x02 = IPv4 <$> S.get
getIP 0x0a = IPv6 <$> S.get
getIP 0x82 = IPv4 <$> S.get -- TODO: TCP
getIP 0x8a = IPv6 <$> S.get -- TODO: TCP
getIP x    = fail ("unsupported address family ("++show x++")")

instance S.Serialize NodeInfo where
    get = do
        addrfam <- S.get :: S.Get Word8
        ip <- getIP addrfam
        port <- S.get :: S.Get PortNumber
        nid <- S.get
        return $ NodeInfo nid ip port

    put (NodeInfo nid ip port) = do
        case ip of
            IPv4 ip4 -> S.put (2 :: Word8) >> S.put ip4
            IPv6 ip6 -> S.put (10 :: Word8) >> S.put ip6
        S.put port
        S.put nid

hexdigit :: Char -> Bool
hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F')

instance Read NodeInfo where
  readsPrec i = RP.readP_to_S $ do
    RP.skipSpaces
    let n = 64 -- characters in node id.
        parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')'))
                      RP.+++ RP.munch (not . isSpace)
        nodeidAt = do hexhash <- sequence $ replicate n (RP.satisfy hexdigit)
                      RP.char '@' RP.+++ RP.satisfy isSpace
                      addrstr <- parseAddr
                      nid <- case Base16.decode $ C8.pack hexhash of
                              (bs,_) | B.length bs==32 -> return (NodeId $ throwCryptoError . publicKey $ bs)
                              _                        -> fail "Bad node id."
                      return (nid,addrstr)
    (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) )
    let raddr = do
            ip <- RP.between (RP.char '[') (RP.char ']')
                         (IPv6 <$> RP.readS_to_P (readsPrec i))
                  RP.+++ (IPv4 <$> RP.readS_to_P (readsPrec i))
            _    <- RP.char ':'
            port <- toEnum <$> RP.readS_to_P (readsPrec i)
            return (ip, port)

    (ip,port) <- case RP.readP_to_S raddr addrstr of
                    [] -> fail "Bad address."
                    ((ip,port),_):_ -> return (ip,port)
    return $ NodeInfo nid ip port

-- The Hashable instance depends only on the IP address and port number.
instance Hashable NodeInfo where
  hashWithSalt s ni = hashWithSalt s (nodeIP ni , nodePort ni)
  {-# INLINE hashWithSalt #-}


instance Show NodeInfo where
    showsPrec _ (NodeInfo nid ip port) =
        shows nid . ('@' :) . showsip . (':' :) . shows port
     where
        showsip
            | IPv4 ip4 <- ip                          = shows ip4
            | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = shows ip4
            | otherwise                               = ('[' :) . shows ip . (']' :)




{-
type NodeId = PubKey

pattern NodeId bs = PubKey bs

-- TODO: This should probably be represented by Curve25519.PublicKey, but
-- ByteString has more instances...
newtype PubKey = PubKey ByteString
 deriving (Eq,Ord,Data, ByteArrayAccess, Bits, Hashable)

instance Serialize PubKey where
    get = PubKey <$> getBytes 32
    put (PubKey bs) = putByteString bs

instance Show PubKey where
    show (PubKey bs) = C8.unpack $ Base16.encode bs

instance FiniteBits PubKey where
    finiteBitSize _ = 256

instance Read PubKey where
    readsPrec _ str
        | (bs, xs) <- Base16.decode $ C8.pack str
        , B.length bs == 32
                    = [ (PubKey bs, drop 64 str) ]
        | otherwise = []




data NodeInfo = NodeInfo
  { nodeId   :: NodeId
  , nodeIP   :: IP
  , nodePort :: PortNumber
  }
 deriving (Eq,Ord,Data)

instance Data PortNumber where
    dataTypeOf _ = mkNoRepType "PortNumber"
    toConstr _     = error "PortNumber.toConstr"
    gunfold _ _    = error "PortNumber.gunfold"

instance ToJSON NodeInfo where
    toJSON (NodeInfo nid (IPv4 ip) port)
        = JSON.object [ "public_key" .= show nid
                      , "ipv4" .= show ip
                      , "port" .= (fromIntegral port :: Int)
                      ]
    toJSON (NodeInfo nid (IPv6 ip6) port)
        | Just ip <- un4map ip6
          = JSON.object [ "public_key" .= show nid
                        , "ipv4" .= show ip
                        , "port" .= (fromIntegral port :: Int)
                        ]
        | otherwise
          = JSON.object [ "public_key" .= show nid
                        , "ipv6" .= show ip6
                        , "port" .= (fromIntegral port :: Int)
                        ]
instance FromJSON NodeInfo where
    parseJSON (JSON.Object v) = do
        nidstr <- v JSON..: "public_key"
        ip6str <- v JSON..:? "ipv6"
        ip4str <- v JSON..:? "ipv4"
        portnum <- v JSON..: "port"
        ip <- maybe empty (return . IPv6) (ip6str >>= readMaybe)
              <|> maybe empty (return . IPv4) (ip4str >>= readMaybe)
        let (bs,_) = Base16.decode (C8.pack nidstr)
        guard (B.length bs == 32)
        return $ NodeInfo (NodeId bs) ip (fromIntegral (portnum :: Word16))

getIP :: Word8 -> S.Get IP
getIP 0x02 = IPv4 <$> S.get
getIP 0x0a = IPv6 <$> S.get
getIP 0x82 = IPv4 <$> S.get -- TODO: TCP
getIP 0x8a = IPv6 <$> S.get -- TODO: TCP
getIP x    = fail ("unsupported address family ("++show x++")")

instance S.Serialize NodeInfo where
    get = do
        addrfam <- S.get :: S.Get Word8
        ip <- getIP addrfam
        port <- S.get :: S.Get PortNumber
        nid <- S.get
        return $ NodeInfo nid ip port

    put (NodeInfo nid ip port) = do
        case ip of
            IPv4 ip4 -> S.put (2 :: Word8) >> S.put ip4
            IPv6 ip6 -> S.put (10 :: Word8) >> S.put ip6
        S.put port
        S.put nid

-- node format:
-- [uint8_t family (2 == IPv4, 10 == IPv6, 130 == TCP IPv4, 138 == TCP IPv6)]
-- [ip (in network byte order), length=4 bytes if ipv4, 16 bytes if ipv6]
-- [port (in network byte order), length=2 bytes]
-- [char array (node_id), length=32 bytes]
--


hexdigit :: Char -> Bool
hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F')

instance Read NodeInfo where
  readsPrec i = RP.readP_to_S $ do
    RP.skipSpaces
    let n = 64 -- characters in node id.
        parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')'))
                      RP.+++ RP.munch (not . isSpace)
        nodeidAt = do hexhash <- sequence $ replicate n (RP.satisfy hexdigit)
                      RP.char '@' RP.+++ RP.satisfy isSpace
                      addrstr <- parseAddr
                      nid <- case Base16.decode $ C8.pack hexhash of
                              (bs,_) | B.length bs==32 -> return (PubKey bs)
                              _                        -> fail "Bad node id."
                      return (nid,addrstr)
    (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) )
    let raddr = do
            ip <- RP.between (RP.char '[') (RP.char ']')
                         (IPv6 <$> RP.readS_to_P (readsPrec i))
                  RP.+++ (IPv4 <$> RP.readS_to_P (readsPrec i))
            _    <- RP.char ':'
            port <- toEnum <$> RP.readS_to_P (readsPrec i)
            return (ip, port)

    (ip,port) <- case RP.readP_to_S raddr addrstr of
                    [] -> fail "Bad address."
                    ((ip,port),_):_ -> return (ip,port)
    return $ NodeInfo nid ip port


-- The Hashable instance depends only on the IP address and port number.
instance Hashable NodeInfo where
  hashWithSalt s ni = hashWithSalt s (nodeIP ni , nodePort ni)
  {-# INLINE hashWithSalt #-}


instance Show NodeInfo where
    showsPrec _ (NodeInfo nid ip port) =
        shows nid . ('@' :) . showsip . (':' :) . shows port
     where
        showsip
            | IPv4 ip4 <- ip                          = shows ip4
            | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = shows ip4
            | otherwise                               = ('[' :) . shows ip . (']' :)

nodeAddr :: NodeInfo -> SockAddr
nodeAddr (NodeInfo _ ip port) = setPort port $ toSockAddr ip

nodeInfo :: NodeId -> SockAddr -> Either String NodeInfo
nodeInfo nid saddr
    | Just ip <- fromSockAddr saddr
    , Just port <- sockAddrPort saddr = Right $ NodeInfo nid ip port
    | otherwise                       = Left "Address family not supported."

zeroID :: NodeId
zeroID = PubKey $ B.replicate 32 0

-}

newtype ReturnPath (n::Nat) = ReturnPath ByteString
 deriving (Eq, Ord,Data)

instance KnownNat n => Serialize (ReturnPath n) where
    -- Size: 59 = 1(family) + 16(ip) + 2(port) +16(mac) + 24(nonce)
    get = ReturnPath <$> getBytes ( 59 * (fromIntegral $ natVal $ Proxy @n) )
    put (ReturnPath bs) = putByteString bs

newtype ForwardPath (n::Nat) = ForwardPath ByteString
 deriving (Eq, Ord,Data)

{-
class KnownNat n => OnionPacket n where
    mkOnion :: ReturnPath n -> Packet -> Packet
instance OnionPacket 0 where mkOnion _ = id
instance OnionPacket 3 where mkOnion = OnionResponse3
-}