1 files changed, 366 insertions, 0 deletions

diff --git a/src/Network/DatagramServer/Mainline.hs b/src/Network/DatagramServer/Mainline.hs
new file mode 100644
index 00000000..2177d076
--- /dev/null
+++ b/src/Network/DatagramServer/Mainline.hs
@@ -0,0 +1,366 @@
+-- |
+--   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.DatagramServer.Mainline
+       ( -- * 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