1 files changed, 36 insertions, 6 deletions

diff --git a/src/Network/BitTorrent/DHT/Session.hs b/src/Network/BitTorrent/DHT/Session.hs
index 2d290a95..7e87df6c 100644
--- a/src/Network/BitTorrent/DHT/Session.hs
+++ b/src/Network/BitTorrent/DHT/Session.hs
@@ -86,6 +86,7 @@ import Control.Monad.Reader
 import Control.Monad.Trans.Control
 import Control.Monad.Trans.Resource
 import Data.Typeable
+import Data.String
 import Data.ByteString
 import Data.Conduit.Lazy
 import Data.Default
@@ -119,6 +120,7 @@ import qualified Network.BitTorrent.DHT.ContactInfo as P
 import Network.DHT.Mainline
 import Network.DHT.Routing as R
 import Network.BitTorrent.DHT.Token   as T
+import GHC.Stack as GHC
 
 {-----------------------------------------------------------------------
 -- Options
@@ -268,7 +270,7 @@ data Node ip = Node
 
   , resources     :: !InternalState
 #ifdef VERSION_bencoding
-  , manager       :: !(Manager (DHT ip) BValue KMessageOf) -- ^ RPC manager;
+  , manager       :: !(Manager IO BValue KMessageOf) -- ^ RPC manager;
   , routingInfo   :: !(TVar    (Maybe (R.Info KMessageOf ip ()))) -- ^ search table;
 #else
   , manager       :: !(Manager (DHT ip) ByteString Tox.Message) -- ^ RPC manager;
@@ -320,8 +322,10 @@ instance MonadResource (DHT ip) where
     s <- asks resources
     liftIO $ runInternalState m s
 
-instance MonadKRPC (DHT ip) (DHT ip) BValue KMessageOf where
-  getManager = asks manager
+-- instance MonadKRPC (DHT ip) (DHT ip) BValue KMessageOf where
+
+getManager :: DHT ip (Manager IO BValue KMessageOf)
+getManager = asks manager
 
 instance MonadLogger (DHT ip) where
   monadLoggerLog loc src lvl msg = do
@@ -329,11 +333,37 @@ instance MonadLogger (DHT ip) where
     liftIO $ logger loc src lvl (toLogStr msg)
 
 #ifdef VERSION_bencoding
-type NodeHandler ip = Handler (DHT ip) KMessageOf BValue
+type NodeHandler ip = Handler IO KMessageOf BValue
 #else
 type NodeHandler ip = Handler (DHT ip) Tox.Message ByteString
 #endif
 
+logt :: HasCallStack => LogFun -> Char -> String -> Text -> IO ()
+logt lf c  m txt = lf (locFromCS callStack) (fromString m) (lvl c) (fromString $ Text.unpack txt)
+ where
+    lvl 'D' = LevelDebug
+    lvl 'I' = LevelInfo
+    lvl 'W' = LevelWarn
+    lvl 'E' = LevelError
+    lvl ch  = LevelOther $ Text.cons ch Text.empty
+
+mkLoggerLoc :: GHC.SrcLoc -> Loc
+mkLoggerLoc loc =
+  Loc { loc_filename = GHC.srcLocFile loc
+      , loc_package  = GHC.srcLocPackage loc
+      , loc_module   = GHC.srcLocModule loc
+      , loc_start    = ( GHC.srcLocStartLine loc
+                       , GHC.srcLocStartCol loc)
+      , loc_end      = ( GHC.srcLocEndLine loc
+                       , GHC.srcLocEndCol loc)
+      }
+
+locFromCS :: GHC.CallStack -> Loc
+locFromCS cs = case getCallStack cs of
+                 ((_, loc):_) -> mkLoggerLoc loc
+                 _            -> Loc "<unknown>" "<unknown>" "<unknown>" (0,0) (0,0)
+
+
 -- | Run DHT session. You /must/ properly close session using
 -- 'closeNode' function, otherwise socket or other scarce resources may
 -- leak.
@@ -357,7 +387,7 @@ newNode hs opts naddr logger mbid = do
     nodeAddr = toSockAddr naddr
     initNode = do
       s      <- getInternalState
-      (_, m) <- allocate (newManager rpcOpts nodeAddr hs) closeManager
+      (_, m) <- allocate (newManager rpcOpts (logt logger) nodeAddr hs) closeManager
       liftIO $ do
         myId   <- maybe genNodeId return mbid
         node   <- Node opts myId s m
@@ -366,7 +396,7 @@ newNode hs opts naddr logger mbid = do
                 <*> newTVarIO S.empty
                 <*> (newTVarIO =<< nullSessionTokens)
                 <*> pure logger
-        runReaderT (unDHT $ KRPC.listen (KRPC.Protocol Proxy Proxy)) node
+        KRPC.listen m (KRPC.Protocol Proxy Proxy)
         return node
 
 -- | Some resources like listener thread may live for