path: root/ToxAddress.hs

{-# LANGUAGE ApplicativeDo              #-}
{-# 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
    ( NodeInfo(..)
    , NodeId
    , nodeInfo
    , nodeAddr
    , zeroID
    , key2id
    , id2key
    , getIP
    , xorNodeId
    , testNodeIdBit
    , sampleNodeId) where

import Control.Applicative
import Control.Monad
import Crypto.Error.Types                     (CryptoFailable (..),
                                               throwCryptoError)
import Crypto.PubKey.Curve25519
import qualified Data.Aeson                   as JSON
         ;import Data.Aeson                   (FromJSON, ToJSON, (.=))
import Data.Bits.ByteString                   ()
import qualified Data.ByteArray               as BA
         ;import Data.ByteArray               as BA (ByteArrayAccess)
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 Foreign.Storable
import GHC.TypeLits
import Network.Address                        hiding (nodePort)
import System.IO.Unsafe                       (unsafeDupablePerformIO)
import qualified Text.ParserCombinators.ReadP as RP
import Text.Read
import Data.Bits
import Crypto.Tox
import Foreign.Ptr
import Data.Function
import System.Endian

-- | 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 :: ByteArrayAccess bs => bs -> [Word64]
unpackPublicKey bs = loop 0
  where loop i
            | i == (BA.length bs `div` 8) = []
            | otherwise =
                let !v = unsafeDoIO $ BA.withByteArray bs (\p -> fromBE64 <$> peekElemOff p i)
                 in v : loop (i+1)

packPublicKey :: BA.ByteArray bs => [Word64] -> bs
packPublicKey ws = BA.allocAndFreeze (8 * length ws) $
    flip fix ws $ \loop ys ptr -> case ys of
        [] -> return ()
        x:xs -> do poke ptr (toBE64 x)
                   loop xs (plusPtr ptr 8)

newtype NodeId = NodeId [Word64]
 deriving (Eq,Ord) -- ByteArrayAccess) -- (Eq,Ord,ByteArrayAccess, Bits, Hashable)


key2id :: PublicKey -> NodeId
key2id = NodeId . unpackPublicKey

bs2id :: ByteString -> NodeId
bs2id bs = NodeId . unpackPublicKey $ throwCryptoError . publicKey $ bs

id2key :: NodeId -> PublicKey
id2key (NodeId key) = throwCryptoError . publicKey $ (packPublicKey key :: BA.Bytes)


{-
id2key :: NodeId -> PublicKey
id2key recipient = case publicKey recipient of
    CryptoPassed key -> key
    -- This should never happen because a NodeId is 32 bytes.
    CryptoFailed e   -> error ("Unexpected pattern fail: "++show e)

key2id :: PublicKey -> NodeId
key2id pk = case S.decode (BA.convert pk) of
                Left _ -> error "key2id"
                Right nid -> nid

-}

{-
instance Ord NodeId where
    compare (NodeId a) (NodeId b) = compare (unpackPublicKey a) (unpackPublicKey b)
-}

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

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

instance Show NodeId where
    show nid = C8.unpack $ Base16.encode $ BA.convert $ id2key nid

instance S.Serialize NodeId where
    get = key2id <$> getPublicKey
    put nid = putPublicKey $ id2key nid

instance Hashable NodeId where
    hashWithSalt salt (NodeId key) = salt `xor` fromIntegral (byteSwap64 $ head key)

-- instance FiniteBits NodeId where finiteBitSize _ = 256

testNodeIdBit :: NodeId -> Word -> Bool
testNodeIdBit (NodeId ws) i
  | fromIntegral i < 256 -- 256 bits
  , (q, r) <- quotRem (fromIntegral i) 64
  = testBit (ws !! q) (63 - r)
  |     otherwise      = False

xorNodeId :: NodeId -> NodeId -> NodeId
xorNodeId (NodeId xs) (NodeId ys) = NodeId $ zipWith xor xs ys

sampleNodeId :: Applicative m => (Int -> m ByteString) -> NodeId -> (Int,Word8,Word8) -> m NodeId
sampleNodeId gen (NodeId self) (q,m,b)
    | q <= 0    = bs2id <$> gen 32
    | q >= 32   = pure (NodeId self)
    | let (qw,r) = (q+7) `divMod` 8 -- How many Word64 to prepend?
          bw = shiftL (fromIntegral b) (8*(7-r))
          mw = bw - 1 :: Word64
          (hd, t0 : _) = splitAt (qw-1) self
          h = xor bw (complement mw .&. t0)
    = flip fmap (gen $ 8 * (4 - (qw-1)) ) $ \bs ->
        let (w:ws) = unpackPublicKey bs
        in NodeId $ hd ++ (h .|. (w .&. mw)) : ws

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 (bs2id 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 Sized NodeInfo where
    size = VarSize $ \(NodeInfo nid ip port) ->
            case ip of
                IPv4 _ -> 39 -- 35 +  4 = 1 + 4 + 2 + 32
                IPv6 _ -> 51 -- 35 + 16 = 1 + 16 + 2 + 32

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 (bs2id 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 . (']' :)

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

-}

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


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
-}