fromBEncode for (Message BValue).

1 files changed, 63 insertions, 8 deletions

diff --git a/Mainline.hs b/Mainline.hs
index fdb77b4d..29f1df80 100644
--- a/Mainline.hs
+++ b/Mainline.hs
@@ -19,6 +19,7 @@ import Crypto.Random
 import Data.BEncode                       as BE
 import qualified Data.BEncode.BDict       as BE
          ;import Data.BEncode.BDict       (BKey)
+import Data.BEncode.Types                 (BDict)
 import Data.Bits
 import Data.Bits.ByteString
 import Data.Bool
@@ -64,6 +65,9 @@ instance S.Serialize NodeId where
 instance FiniteBits NodeId where
     finiteBitSize _ = 160
 
+zeroID :: NodeId
+zeroID = NodeId $ B.replicate 20 0
+
 data NodeInfo = NodeInfo
   { nodeId   :: NodeId
   , nodeIP   :: IP
@@ -183,17 +187,52 @@ data Message a = Q { msgOrigin   :: NodeId
                    , rspReflectedIP :: Maybe SockAddr }
 
 instance BE.BEncode (Message BValue) where
-    toBEncode = encodeMessage
-    fromBEncode = error "TODO: fromBEncode (Mainline Message)"
-
+    toBEncode   = encodeMessage
+    fromBEncode = decodeMessage
+
+decodeMessage :: BValue -> Either String (Message BValue)
+decodeMessage = fromDict $ do
+    key <- lookAhead (field (req "y"))
+    let _ = key :: BKey
+    f <- case key of
+        "q" -> do a <- field (req "a")
+                  g <- either fail return $ flip fromDict a $ do
+                    who <- field (req "id")
+                    ro  <- fromMaybe False <$> optional (field (req "ro"))
+                    return $ \meth tid -> Q who tid a meth ro
+                  meth <- field (req "q")
+                  return $ g meth
+        "r" -> do ip <- do
+                        ipstr <- optional (field (req "ip"))
+                        mapM (either fail return . decodeAddr) ipstr
+                  vals <- field (req "r")
+                  either fail return $ flip fromDict vals $ do
+                    who <- field (req "id")
+                    return $ \tid -> R who tid (Right vals) ip
+        "e" -> do (ecode,emsg) <- field (req "e")
+                  ip <- do
+                        ipstr <- optional (field (req "ip"))
+                        mapM (either fail return . decodeAddr) ipstr
+                  -- FIXME:Spec does not give us the NodeId of the sender.
+                  --       Using 'zeroID' as place holder.
+                  --       We should ignore the msgOrigin for errors in 'updateRouting'.
+                  --       We should consider making msgOrigin a Maybe value.
+                  return $ \tid -> R zeroID tid (Left (Error ecode emsg)) ip
+        _   -> fail $ "Mainline message is not a query, response, or an error: "
+                        ++ show key
+    tid <- field (req "t")
+    return $ f (tid :: TransactionId)
+
+
+encodeMessage :: Message BValue -> BValue
 encodeMessage (Q origin tid a meth ro)
     = case a of
         BDict args -> encodeQuery tid meth (BDict $ genericArgs origin ro `BE.union` args)
         _          -> encodeQuery tid meth a -- XXX: Not really a valid query.
 encodeMessage (R origin tid v ip)
     = case v of
-        Right vals -> encodeResponse tid vals (BString . encodeAddr <$> ip)
-        Left  err  -> encodeError tid err
+        Right (BDict vals) -> encodeResponse tid (BDict $ genericArgs origin False `BE.union` vals) ip
+        Left  err          -> encodeError tid err
 
 encodeAddr :: SockAddr -> ByteString
 encodeAddr (SockAddrInet port addr)
@@ -202,17 +241,31 @@ encodeAddr (SockAddrInet6 port _ addr _)
     = S.runPut (S.put addr >> S.put (fromIntegral port :: Word16))
 encodeAddr _ = B.empty
 
+decodeAddr :: ByteString -> Either String SockAddr
+decodeAddr = S.runGet $ do
+    error "decodeAddr"
+
+genericArgs :: BEncode a => a -> Bool -> BDict
 genericArgs nodeid ro =
        "id" .=! nodeid
     .: "ro" .=? bool Nothing (Just (1 :: Int)) ro
     .: endDict
 
-encodeError     tid (Error ecode emsg)       = encodeAny tid "e" (ecode,emsg) id
+encodeError :: BEncode a => a -> Error -> BValue
+encodeError tid (Error ecode emsg) = encodeAny tid "e" (ecode,emsg) id
 
-encodeResponse  tid rvals              rip   = encodeAny tid "r" rvals        ("ip" .=? rip   .:)
+encodeResponse :: (BEncode tid, BEncode vals) =>
+                  tid -> vals -> Maybe SockAddr -> BValue
+encodeResponse tid rvals rip =
+    encodeAny tid "r" rvals ("ip" .=? (BString . encodeAddr <$> rip) .:)
 
-encodeQuery     tid qmeth              qargs = encodeAny tid "q" qmeth        ("a"  .=! qargs .:)
+encodeQuery :: (BEncode args, BEncode tid, BEncode method) =>
+               tid -> method -> args -> BValue
+encodeQuery tid qmeth qargs = encodeAny tid "q" qmeth ("a" .=! qargs .:)
 
+encodeAny ::
+    (BEncode tid, BEncode a) =>
+    tid -> BKey -> a -> (BDict -> BDict) -> BValue
 encodeAny tid key val aux = toDict $
     aux $  key .=! val
         .: "t" .=! tid
@@ -221,6 +274,8 @@ encodeAny tid key val aux = toDict $
 
 parsePacket :: ByteString -> SockAddr -> Either String (Message BValue, NodeInfo)
 parsePacket bs addr = do pkt <- BE.decode bs
+                         -- TODO: Error packets do not inclucde a valid msgOrigin.
+                         --       The BE.decode method is using 'zeroID' as a placeholder.
                          ni <- nodeInfo (msgOrigin pkt) addr
                          return (pkt, ni)