~ Allow passing raw dictionaries.

We need this in Kademlia DHT -- there are method which return
dictionaries with different keys depending on DHT server state.

5 files changed, 30 insertions, 4 deletions

diff --git a/krpc.cabal b/krpc.cabal
index 059f6348..779d7abc 100644
--- a/krpc.cabal
+++ b/krpc.cabal
@@ -57,6 +57,7 @@ test-suite test-client
   other-modules:       Shared
   build-depends:       base        == 4.*
                      , bytestring
+                     , containers
                      , process
                      , filepath
 
diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs
index e1ad0853..1b4ae4b6 100644
--- a/src/Remote/KRPC.hs
+++ b/src/Remote/KRPC.hs
@@ -175,7 +175,9 @@ extractArgs :: BEncodable arg
             => [ParamName] -> Map ParamName BEncode -> Result arg
 extractArgs as d = fromBEncode =<<
   case as of
-    []  -> Right (BList [])
+    []  -> if M.null d
+           then Right (BList [])
+           else Right (BDict d)
     [x] -> f x
     xs  -> BList <$> mapM f xs
   where
@@ -184,12 +186,22 @@ extractArgs as d = fromBEncode =<<
 {-# INLINE extractArgs #-}
 
 injectVals :: BEncodable arg => [ParamName] -> arg -> [(ParamName, BEncode)]
-injectVals []  (toBEncode -> BList []) = []
+injectVals []  (toBEncode -> be)
+  = case be of
+     BList []   -> []
+     BDict d    -> M.toList d
+     _          -> invalidParamList [] be
+
 injectVals [p] (toBEncode -> arg)      = [(p, arg)]
 injectVals ps  (toBEncode -> BList as) = L.zip ps as
-injectVals _   _                       = error "KRPC.injectVals: impossible"
+injectVals pl  a                       = invalidParamList pl (toBEncode a)
 {-# INLINE injectVals #-}
 
+invalidParamList :: [ParamName] -> BEncode -> a
+invalidParamList pl be
+  = error $ "KRPC invalid parameter list: " ++ show pl ++ "\n" ++
+            "while procedure args are: "    ++ show be
+
 -- | Alias to Socket, through might change in future.
 type Remote = Socket
 
diff --git a/tests/Client.hs b/tests/Client.hs
index 1b9ef8d2..313cd56e 100644
--- a/tests/Client.hs
+++ b/tests/Client.hs
@@ -5,6 +5,7 @@ import Control.Concurrent
 import Control.Exception
 import qualified Data.ByteString as B
 import Data.BEncode
+import Data.Map
 import System.Environment
 import System.Process
 import System.FilePath
@@ -69,4 +70,11 @@ tests =
 
   , testCase "raw method" $
       BInteger 10 ==? call addr rawM (BInteger 10)
+
+  , testCase "raw dict" $
+      let dict = BDict $ fromList
+                 [ ("some_int", BInteger 100)
+                 , ("some_list", BList [BInteger 10])
+                 ]
+      in dict ==? call addr rawDictM dict
   ]
diff --git a/tests/Server.hs b/tests/Server.hs
index 7cd6a5d6..aaf6d9f2 100644
--- a/tests/Server.hs
+++ b/tests/Server.hs
@@ -15,4 +15,5 @@ main = server 6000
   , reverseM ==> return . reverse
   , shiftR ==> \(a, b, c) -> return (c, a, b)
   , rawM      ==> return
+  , rawDictM  ==> return
   ]
diff --git a/tests/Shared.hs b/tests/Shared.hs
index a04b6093..f64112da 100644
--- a/tests/Shared.hs
+++ b/tests/Shared.hs
@@ -7,6 +7,7 @@ module Shared
        , reverseM
        , shiftR
        , rawM
+       , rawDictM
        ) where
 
 import Data.ByteString (ByteString)
@@ -32,4 +33,7 @@ shiftR :: Method ((), Int, [Int]) ([Int], (), Int)
 shiftR = method "shiftR" ["x", "y", "z"] ["a", "b", "c"]
 
 rawM :: Method BEncode BEncode
-rawM = method "rawM" [""] [""]
\ No newline at end of file
+rawM = method "rawM" [""] [""]
+
+rawDictM :: Method BEncode BEncode
+rawDictM = method "m" [] []
\ No newline at end of file