Commits

Bryan O'Sullivan committed ad14bef

Add simple debugging support.

Comments (0)

Files changed (3)

   README.md src/riakclient.proto
 cabal-version:       >=1.8
 
+flag debug
+  description: allow debug logging
+  default: True
+
 flag developer
   description: operate in developer mode
   default: False
     Network.Riak
     Network.Riak.Connection
     Network.Riak.Content
+    Network.Riak.Debug
     Network.Riak.Request
     Network.Riak.Response
     Network.Riak.Simple
     pureMD5,
     random
 
+  if flag(debug)
+    cpp-options: -DASSERTS -DDEBUG
+
   if flag(developer)
     ghc-options: -Werror
     cpp-options: -DASSERTS

src/Network/Riak/Connection/Internal.hs

 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.Protocol.SetClientIDRequest
 import Network.Riak.Tag (getTag, putTag)
 import Network.Riak.Types.Internal hiding (MessageTag(..))
                 addrFlags = [AI_ADDRCONFIG]
               , addrSocketType = Stream
               }
+  debug "connect" $ "server " ++ host ++ ":" ++ port ++ ", client ID " ++
+                    L.unpack clientID
   ais <- getAddrInfo (Just hints) (Just host) (Just port)
   let ai = case ais of
              (a:_) -> a
 
 disconnect :: Connection -> IO ()
 disconnect Connection{..} = onIOException "disconnect" $ do
+  debug "disconnect" $ "server " ++ host connClient ++ ":" ++ port connClient ++
+                       ", client ID " ++ L.unpack (clientID connClient)
   sClose connSock
   writeIORef connBuffer L.empty
 
                          show expected ++ ", received " ++ show tag
 
 exchange :: Exchange req resp => Connection -> req -> IO resp
-exchange conn@Connection{..} req =
-  onIOException ("exchange[" ++ show (messageTag req) ++ "]") $ do
+exchange conn@Connection{..} req = do
+  let tag = show (messageTag req)
+  debug "exchange" $ "sending " ++ tag
+  onIOException ("exchange " ++ tag) $ do
     sendRequest conn req
     recvResponse conn
 
 exchangeMaybe :: Exchange req resp => Connection -> req -> IO (Maybe resp)
-exchangeMaybe conn@Connection{..} req =
-  onIOException ("exchangeMaybe[" ++ show (messageTag req) ++ "]") $ do
+exchangeMaybe conn@Connection{..} req = do
+  let tag = show (messageTag req)
+  debug "exchangeMaybe" $ "sending " ++ tag
+  onIOException ("exchangeMaybe " ++ tag) $ do
     sendRequest conn req
     recvMaybeResponse conn
 
 exchange_ :: Request req => Connection -> req -> IO ()
-exchange_ conn req =
-  onIOException ("exchange_[" ++ show (messageTag req) ++ "]") $ do
+exchange_ conn req = do
+  let tag = show (messageTag req)
+  debug "exchange_" $ "sending " ++ tag
+  onIOException ("exchange_ " ++ tag) $ do
     sendRequest conn req
     recvResponse_ conn (expectedResponse req)
 
   ch <- newChan
   let numReqs = length reqs
   _ <- forkIO . replicateM_ numReqs $ writeChan ch =<< receive conn
-  onIOException ("pipe[" ++ show (messageTag (head reqs)) ++ "]") .
+  let tag = show (messageTag (head reqs))
+  debug "pipe" $ "sending " ++ show numReqs ++ " " ++ tag
+  onIOException ("pipe " ++ tag) .
     L.sendAll connSock . runPut . mapM_ putRequest $ reqs
   replicateM numReqs $ readChan ch
 
 
 onIOException :: String -> IO a -> IO a
 onIOException func act =
-    act `catch` \(e::IOException) -> moduleError func (show e)
+    act `catch` \(e::IOException) -> do
+      let s = show e
+      debug func $ "caught IO exception: " ++ s
+      moduleError func s
 
 moduleError :: String -> String -> a
 moduleError = riakError "Network.Riak.Connection.Internal"

src/Network/Riak/Debug.hs

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