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 OverloadedStrings      #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE TypeSynonymInstances   #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE DefaultSignatures      #-}
{-# LANGUAGE DeriveDataTypeable     #-}
module Network.KRPC.Message
       ( -- * Transaction
         TransactionId

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

         -- * Query
       , KQuery(..)
       , MethodName

         -- * Response
       , KResponse(..)
       , ReflectedIP(..)

         -- * Message
       , KMessage (..)
       ) where

import Control.Applicative
import Control.Arrow
import Control.Exception.Lifted as Lifted
import Data.BEncode as BE
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)


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

unknownTransaction :: TransactionId
unknownTransaction = ""

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

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

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

-- | 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, Read, Eq, Ord, Typeable)

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

instance Exception KError

-- | Received 'queryArgs' or 'respVals' can not be decoded.
decodeError :: String -> TransactionId -> KError
decodeError msg = KError ProtocolError (BC.pack msg)

-- | A remote node has send some 'KMessage' this node is unable to
-- decode.
unknownMessage :: String -> KError
unknownMessage msg = KError ProtocolError (BC.pack msg) unknownTransaction

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

type MethodName = ByteString

-- | 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 KQuery = KQuery
  { queryArgs   :: !BValue         -- ^ values to be passed to method;
  , queryMethod :: !MethodName     -- ^ method to call;
  , queryId     :: !TransactionId  -- ^ one-time query token.
  } deriving (Show, Read, Eq, Ord, Typeable)

-- | 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 BEncode KQuery 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 #-}

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

instance BEncode ReflectedIP where
  toBEncode (ReflectedIP addr) = BString (encodeAddr addr)
  fromBEncode (BString bs) = ReflectedIP <$> decodeAddr bs
  fromBEncode _            = Left "ReflectedIP should be a bencoded string"

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.
--
data KResponse = KResponse
  { respVals :: BValue         -- ^ 'BDict' containing return values;
  , respId   :: TransactionId  -- ^ match to the corresponding 'queryId'.
  , respIP   :: Maybe ReflectedIP
  } deriving (Show, Eq, Ord, Typeable)

-- | 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 BEncode KResponse 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 #-}

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

-- | Generic KRPC message.
data KMessage
  = Q KQuery
  | R KResponse
  | E KError
    deriving (Show, Eq)

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"