Bryan O'Sullivan avatar Bryan O'Sullivan committed 99b867a

Add much more extensive message-level debugging.

Comments (0)

Files changed (4)

src/Network/Riak/Connection/Internal.hs

-{-# LANGUAGE OverloadedStrings, RecordWildCards, ScopedTypeVariables #-}
+{-# LANGUAGE CPP, OverloadedStrings, RecordWildCards, ScopedTypeVariables #-}
 
 module Network.Riak.Connection.Internal
     (
 import Data.Binary.Put (Put, putWord32be, runPut)
 import Data.IORef (modifyIORef, newIORef, readIORef, writeIORef)
 import Data.Int (Int64)
-import Network.Riak.Debug (debug)
+import Network.Riak.Debug as Debug
 import Network.Riak.Protocol.ErrorResponse
 import Network.Riak.Protocol.SetClientIDRequest
 import Network.Riak.Tag (getTag, putTag)
 
 exchange :: Exchange req resp => Connection -> req -> IO resp
 exchange conn@Connection{..} req = do
-  let tag = show (messageTag req)
-  debug "exchange" $ "sending " ++ tag
-  onIOException ("exchange " ++ tag) $ do
+  debug "exchange" $ "sending " ++ showM req
+  onIOException ("exchange " ++ show (messageTag req)) $ do
     sendRequest conn req
     recvResponse conn
 
 exchangeMaybe :: Exchange req resp => Connection -> req -> IO (Maybe resp)
 exchangeMaybe conn@Connection{..} req = do
-  let tag = show (messageTag req)
-  debug "exchangeMaybe" $ "sending " ++ tag
-  onIOException ("exchangeMaybe " ++ tag) $ do
+  debug "exchangeMaybe" $ "sending " ++ showM req
+  onIOException ("exchangeMaybe " ++ show (messageTag req)) $ do
     sendRequest conn req
     recvMaybeResponse conn
 
 exchange_ :: Request req => Connection -> req -> IO ()
 exchange_ conn req = do
-  let tag = show (messageTag req)
-  debug "exchange_" $ "sending " ++ tag
-  onIOException ("exchange_ " ++ tag) $ do
+  debug "exchange_" $ "sending " ++ showM req
+  onIOException ("exchange_ " ++ show (messageTag req)) $ do
     sendRequest conn req
     recvResponse_ conn (expectedResponse req)
 
 sendRequest Connection{..} = L.sendAll connSock . runPut . putRequest
 
 recvResponse :: (Response a) => Connection -> IO a
-recvResponse conn = go undefined where
+recvResponse conn = debugRecv showM $ go undefined where
   go :: Response b => b -> IO b
   go dummy = do
     len <- fromIntegral `fmap` recvGet conn getWord32be
     recvGetN conn len (getResponse (messageTag dummy))
 
 recvResponse_ :: Connection -> T.MessageTag -> IO ()
-recvResponse_ conn expected = do
+recvResponse_ conn expected = debugRecv show $ do
   len <- fromIntegral `fmap` recvGet conn getWord32be
   tag <- recvGet conn getTag
   case undefined of
                    show expected ++ ", received " ++ show tag
 
 recvMaybeResponse :: (Response a) => Connection -> IO (Maybe a)
-recvMaybeResponse conn =  go undefined where
+recvMaybeResponse conn = debugRecv (maybe "Nothing" (("Just " ++) . showM)) $
+                         go undefined where
   go :: Response b => b -> IO (Maybe b)
   go dummy = do
     len <- fromIntegral `fmap` recvGet conn getWord32be
       then return Nothing
       else Just `fmap` recvGetN conn len (getResponse (messageTag dummy))
 
-pipe :: (Request req) => (Connection -> IO resp) -> Connection -> [req]
+debugRecv :: (a -> String) -> IO a -> IO a
+#ifdef DEBUG
+debugRecv f act = do
+  r <- act
+  debug "recv" $ "received " ++ f r
+  return r
+#else
+debugRecv _ act = act
+{-# INLINE debugRecv #-}
+#endif
+
+pipe :: (Request req, Show resp) => (Connection -> IO resp) -> Connection -> [req]
      -> IO [resp]
 pipe receive conn@Connection{..} reqs = do
   ch <- newChan
   let numReqs = length reqs
   _ <- forkIO . replicateM_ numReqs $ writeChan ch =<< receive conn
   let tag = show (messageTag (head reqs))
-  debug "pipe" $ "sending " ++ show numReqs ++ " " ++ tag
+  if Debug.level > 1
+    then forM_ reqs $ \req -> debug "pipe" $ "sending " ++ showM req
+    else debug "pipe" $ "sending " ++ show numReqs ++ " " ++ tag
   onIOException ("pipe " ++ tag) .
     L.sendAll connSock . runPut . mapM_ putRequest $ reqs
   replicateM numReqs $ readChan ch
   _ <- forkIO $ do
          forM_ reqs (recvResponse_ conn . expectedResponse)
          putMVar done ()
+  if Debug.level > 1
+    then forM_ reqs $ \req -> debug "pipe" $ "sending " ++ showM req
+    else debug "pipe" $ "sending " ++ show (length reqs) ++ " " ++
+                        show (messageTag (head reqs))
   L.sendAll connSock . runPut . mapM_ putRequest $ reqs
   takeMVar done
 

src/Network/Riak/Debug.hs

 
 module Network.Riak.Debug
     (
-      enabled
+      level
     , debug
     , setHandle
+    , showM
     ) where
 
 import Control.Exception hiding (handle)
-import Data.IORef
-import System.Environment
-import System.IO
-import System.IO.Unsafe
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import Network.Riak.Types.Internal
+import System.Environment (getEnv)
+import System.IO (Handle, hPutStrLn, stderr)
+import System.IO.Unsafe (unsafePerformIO)
 
-enabled :: Bool
+level :: Int
 #ifdef DEBUG
-enabled = unsafePerformIO $ do
+level = unsafePerformIO $ do
           es <- try $ getEnv "RIAK_DEBUG"
           case es of
-            Left (_::SomeException) -> return False
-            Right s -> return (s == "1" || s == "on")
-{-# NOINLINE enabled #-}
+            Left (_::SomeException)   -> return 0
+            Right "on" -> return 1
+            Right s    -> case reads s of
+                            ((n,_):_) -> return n
+                            _         -> return 1
+{-# NOINLINE level #-}
 #else
-enabled = False
-{-# INLINE enabled #-}
+level = 0
+{-# INLINE level #-}
 #endif
 
 #ifdef DEBUG
 debug :: String -> String -> IO ()
 #ifdef DEBUG
 debug func str
-    | not enabled = return ()
-    | otherwise = do
+    | level == 0 = return ()
+    | otherwise  = do
   h <- readIORef handle
   hPutStrLn h $ func ++ ": " ++ str
 #else
 debug _ _ = return ()
-{-# INLINE debug
+{-# INLINE debug #-}
 #endif
+
+showM :: (Show a, Tagged a) => a -> String
+showM m | level > 1 = show m
+        | otherwise = show (messageTag m)

src/Network/Riak/Tag.hs

 
 import Data.Binary.Put (Put, putWord8)
 import Network.Riak.Protocol.DeleteRequest
+import Network.Riak.Protocol.ErrorResponse
 import Network.Riak.Protocol.GetBucketRequest
 import Network.Riak.Protocol.GetBucketResponse
 import Network.Riak.Protocol.GetClientIDRequest
 import Network.Riak.Types.Internal as Types
 import Text.ProtocolBuffers.Get (Get, getWord8)
 
+instance Tagged ErrorResponse where
+    messageTag _ = Types.ErrorResponse
+    {-# INLINE messageTag #-}
+
+instance Response ErrorResponse
+
 instance Tagged PingRequest where
     messageTag _ = Types.PingRequest
     {-# INLINE messageTag #-}

src/Network/Riak/Types/Internal.hs

     messageTag m = m
     {-# INLINE messageTag #-}
 
-class (Tagged msg, ReflectDescriptor msg, Wire msg) => Request msg where
+class (Tagged msg, ReflectDescriptor msg, Show msg, Wire msg) => Request msg where
     expectedResponse :: msg -> MessageTag
 
-class (Tagged msg, ReflectDescriptor msg, Wire msg) => Response msg
+class (Tagged msg, ReflectDescriptor msg, Show msg, Wire msg) => Response msg
 
 class (Request req, Response resp) => Exchange req resp
     | req -> resp, resp -> req
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.