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