path: root/src/Network/KRPC/Message.hs

-- |
--   Copyright   :  (c) Sam Truzjan 2013, 2014
--   License     :  BSD3
--   Maintainer  :  pxqr.sta@gmail.com
--   Stability   :  experimental
--   Portability :  portable
--
--   KRPC messages types used in communication. All messages are
--   encoded as bencode dictionary.
--
--   Normally, you don't need to import this module.
--
--   See <http://www.bittorrent.org/beps/bep_0005.html#krpc-protocol>
--
{-# LANGUAGE CPP                    #-}
{-# LANGUAGE DefaultSignatures      #-}
{-# LANGUAGE DeriveDataTypeable     #-}
{-# LANGUAGE DeriveFunctor          #-}
{-# LANGUAGE DeriveTraversable      #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE OverloadedStrings      #-}
{-# LANGUAGE TypeSynonymInstances   #-}
module Network.KRPC.Message
       ( -- * Transaction
         TransactionId

         -- * Error
       , ErrorCode (..)
       , KError(..)
       , decodeError
       , unknownMessage

         -- * Query
#ifdef VERSION_bencoding
       , KQueryOf(..)
#endif
       , KQuery
#ifndef VERSION_bencoding
       , queryArgs
       , queryMethod
       , queryId
#endif
       , MethodName

         -- * Response
#ifdef VERSION_bencoding
       , KResponseOf(..)
#endif
       , KResponse
       , ReflectedIP(..)

         -- * Message
       , KMessageOf (..)
       , KMessage
       , KQueryArgs

       ) where

import Control.Applicative
import Control.Arrow
import Control.Exception.Lifted as Lifted
#ifdef VERSION_bencoding
import Data.BEncode as BE
#else
import qualified Data.Tox as Tox
#endif
import Data.ByteString as B
import Data.ByteString.Char8 as BC
import qualified Data.Serialize as S
import Data.Word
import Data.Typeable
import Network.Socket (SockAddr (..),PortNumber,HostAddress)


#ifdef VERSION_bencoding
-- | This transaction ID is generated by the querying node and is
-- echoed in the response, so responses may be correlated with
-- multiple queries to the same node. The transaction ID should be
-- encoded as a short string of binary numbers, typically 2 characters
-- are enough as they cover 2^16 outstanding queries.
type TransactionId = ByteString
#else
type TransactionId = Tox.Nonce24 -- msgNonce
#endif

unknownTransaction :: TransactionId
#ifdef VERSION_bencoding
unknownTransaction = ""
#else
unknownTransaction = 0
#endif

{-----------------------------------------------------------------------
-- Error messages
-----------------------------------------------------------------------}

-- | Types of RPC errors.
data ErrorCode
    -- | Some error doesn't fit in any other category.
  = GenericError

    -- | Occur when server fail to process procedure call.
  | ServerError

    -- | Malformed packet, invalid arguments or bad token.
  | ProtocolError

    -- | Occur when client trying to call method server don't know.
  | MethodUnknown
    deriving (Show, Read, Eq, Ord, Bounded, Typeable)

-- | According to the table:
-- <http://bittorrent.org/beps/bep_0005.html#errors>
instance Enum ErrorCode where
  fromEnum GenericError  = 201
  fromEnum ServerError   = 202
  fromEnum ProtocolError = 203
  fromEnum MethodUnknown = 204
  {-# INLINE fromEnum #-}

  toEnum 201 = GenericError
  toEnum 202 = ServerError
  toEnum 203 = ProtocolError
  toEnum 204 = MethodUnknown
  toEnum _   = GenericError
  {-# INLINE toEnum #-}

#ifdef VERSION_bencoding
instance BEncode ErrorCode where
  toBEncode = toBEncode . fromEnum
  {-# INLINE toBEncode #-}

  fromBEncode b = toEnum <$> fromBEncode b
  {-# INLINE fromBEncode #-}
#endif

#ifdef VERSION_bencoding
-- | Errors are sent when a query cannot be fulfilled. Error message
--   can be send only from server to client but not in the opposite
--   direction.
--
data KError = KError
  { errorCode    :: !ErrorCode     -- ^ the type of error;
  , errorMessage :: !ByteString    -- ^ human-readable text message;
  , errorId      :: !TransactionId -- ^ match to the corresponding 'queryId'.
  } deriving ( Show, Eq, Ord, Typeable, Read )
#else
type KError = Tox.Message ByteString -- TODO TOX unused
#endif

-- | Errors, or KRPC message dictionaries with a \"y\" value of \"e\",
--   contain one additional key \"e\". The value of \"e\" is a
--   list. The first element is an integer representing the error
--   code. The second element is a string containing the error
--   message.
--
--   Example Error Packet:
--
--   > { "t": "aa", "y":"e", "e":[201, "A Generic Error Ocurred"]}
--
--   or bencoded:
--
--   > d1:eli201e23:A Generic Error Ocurrede1:t2:aa1:y1:ee
--
#ifdef VERSION_bencoding
instance BEncode KError where
  toBEncode KError {..} = toDict $
       "e" .=! (errorCode, errorMessage)
    .: "t" .=! errorId
    .: "y" .=! ("e" :: ByteString)
    .: endDict
  {-# INLINE toBEncode #-}

  fromBEncode = fromDict $ do
    lookAhead $ match "y" (BString "e")
    (code, msg) <- field (req "e")
    KError code msg <$>! "t"
  {-# INLINE fromBEncode #-}
#endif

instance Exception KError

-- | Received 'queryArgs' or 'respVals' can not be decoded.
decodeError :: String -> TransactionId -> KError
#ifdef VERSION_bencoding
decodeError msg = KError ProtocolError (BC.pack msg)
#else
decodeError msg = error "TODO TOX Error packet"
#endif

-- | A remote node has send some 'KMessage' this node is unable to
-- decode.
unknownMessage :: String -> KError
#ifdef VERSION_bencoding
unknownMessage msg = KError ProtocolError (BC.pack msg) unknownTransaction
#else
unknownMessage msg = error "TODO TOX Protocol error"
#endif

{-----------------------------------------------------------------------
-- Query messages
-----------------------------------------------------------------------}

#ifdef VERSION_bencoding
type MethodName = ByteString
type KQueryArgs = BValue
#else
type MethodName = Tox.MessageType -- msgType
type KQueryArgs = ByteString      -- msgPayload
#endif

#ifdef VERSION_bencoding
-- | Query used to signal that caller want to make procedure call to
-- callee and pass arguments in. Therefore query may be only sent from
-- client to server but not in the opposite direction.
--
data KQueryOf a = KQuery
  { queryArgs   :: !a              -- ^ values to be passed to method;
  , queryMethod :: !MethodName     -- ^ method to call;
  , queryId     :: !TransactionId  -- ^ one-time query token.
  } deriving ( Show, Eq, Ord, Typeable, Read, Functor, Foldable, Traversable )

type KQuery = KQueryOf KQueryArgs

-- | Queries, or KRPC message dictionaries with a \"y\" value of
-- \"q\", contain two additional keys; \"q\" and \"a\". Key \"q\" has
-- a string value containing the method name of the query. Key \"a\"
-- has a dictionary value containing named arguments to the query.
--
--    Example Query packet:
--
--    > { "t" : "aa", "y" : "q", "q" : "ping", "a" : { "msg" : "hi!" } }
--
instance (Typeable a, BEncode a) => BEncode (KQueryOf a) where
  toBEncode KQuery {..} = toDict $
       "a" .=! queryArgs
    .: "q" .=! queryMethod
    .: "t" .=! queryId
    .: "y" .=! ("q" :: ByteString)
    .: endDict
  {-# INLINE toBEncode #-}

  fromBEncode = fromDict $ do
    lookAhead $ match "y" (BString "q")
    KQuery <$>! "a" <*>! "q" <*>! "t"
  {-# INLINE fromBEncode #-}

instance BEncode ReflectedIP where
  toBEncode (ReflectedIP addr) = BString (encodeAddr addr)
  fromBEncode (BString bs) = ReflectedIP <$> decodeAddr bs
  fromBEncode _            = Left "ReflectedIP should be a bencoded string"
#else
type KQuery = Tox.Message KQueryArgs
queryArgs   = Tox.msgPayload
queryMethod = Tox.msgType
queryId     = Tox.msgNonce
#endif

newtype ReflectedIP = ReflectedIP SockAddr
  deriving (Eq, Ord, Show)

port16 :: Word16 -> PortNumber
port16 = fromIntegral

decodeAddr :: ByteString -> Either String SockAddr
decodeAddr bs | B.length bs == 6
    = ( \(a,p) -> SockAddrInet <$> fmap port16 p <*> a )
      $ (S.runGet S.getWord32host *** S.decode )
      $ B.splitAt 4 bs
decodeAddr bs | B.length bs == 18
    = ( \(a,p) -> flip SockAddrInet6 0 <$> fmap port16 p <*> a <*> pure 0 )
      $ (S.decode *** S.decode )
      $ B.splitAt 16 bs
decodeAddr _ = Left "incorrectly sized address and port"

encodeAddr :: SockAddr -> ByteString
encodeAddr (SockAddrInet port addr)
    = S.runPut (S.putWord32host addr >> S.put (fromIntegral port :: Word16))
encodeAddr (SockAddrInet6 port _ addr _)
    = S.runPut (S.put addr >> S.put (fromIntegral port :: Word16))
encodeAddr _ = B.empty

{-----------------------------------------------------------------------
-- Response messages
-----------------------------------------------------------------------}

-- | Response messages are sent upon successful completion of a
-- query:
--
--   * KResponse used to signal that callee successufully process a
--   procedure call and to return values from procedure.
--
--   * KResponse should not be sent if error occurred during RPC,
--   'KError' should be sent instead.
--
--   * KResponse can be only sent from server to client.
--
#ifdef VERSION_bencoding
data KResponseOf a = KResponse
  { respVals :: a              -- ^ 'BDict' containing return values;
  , respId   :: TransactionId  -- ^ match to the corresponding 'queryId'.
  , respIP   :: Maybe ReflectedIP
  } deriving (Show, Eq, Ord, Typeable, Functor, Foldable, Traversable)

type KResponse = KResponseOf KQueryArgs

-- | Responses, or KRPC message dictionaries with a \"y\" value of
-- \"r\", contain one additional key \"r\". The value of \"r\" is a
-- dictionary containing named return values.
--
--   Example Response packet:
--
--   > { "t" : "aa", "y" : "r", "r" : { "msg" : "you've sent: hi!" } }
--
instance (Typeable a, BEncode a) => BEncode (KResponseOf a) where
  toBEncode KResponse {..} = toDict $
       "ip" .=? respIP
    .: "r" .=! respVals
    .: "t" .=! respId
    .: "y" .=! ("r" :: ByteString)
    .: endDict
  {-# INLINE toBEncode #-}

  fromBEncode = fromDict $ do
    lookAhead $ match "y" (BString "r")
    addr <- optional (field (req "ip"))
    (\r t -> KResponse r t addr) <$>! "r" <*>! "t"
  {-# INLINE fromBEncode #-}
#else
type KResponse = Tox.Message KQueryArgs
respVals       = Tox.msgPayload
respId         = Tox.msgNonce
respIP         = Nothing :: Maybe ReflectedIP
#endif

{-----------------------------------------------------------------------
-- Summed messages
-----------------------------------------------------------------------}

#ifdef VERSION_bencoding
-- | Generic KRPC message.
data KMessageOf a
  = Q (KQueryOf a)
  | R (KResponseOf a)
  | E KError
    deriving (Show, Eq, Functor, Foldable, Traversable)

type KMessage = KMessageOf KQueryArgs

instance BEncode KMessage where
  toBEncode (Q q) = toBEncode q
  toBEncode (R r) = toBEncode r
  toBEncode (E e) = toBEncode e

  fromBEncode b =
        Q <$> fromBEncode b
    <|> R <$> fromBEncode b
    <|> E <$> fromBEncode b
    <|> decodingError "KMessage: unknown message or message tag"
#else
type KMessageOf = Tox.Message
type KMessage = KMessageOf B.ByteString
#endif