Deleted MonadKRPC.

1 files changed, 53 insertions, 83 deletions

diff --git a/src/Network/DatagramServer.hs b/src/Network/DatagramServer.hs
index eed2ced1..f212ffdf 100644
--- a/src/Network/DatagramServer.hs
+++ b/src/Network/DatagramServer.hs
@@ -76,13 +76,12 @@ module Network.DatagramServer
        , handler
 
          -- * Manager
-       , MonadKRPC (..)
        , Options (..)
        , def
        , Manager
        , newManager
        , closeManager
-       , withManager
+       -- , withManager
        , isActive
        , listen
        , Protocol(..)
@@ -144,6 +143,7 @@ data Options = Options
 
     -- | Maximum number of bytes to receive.
   , optMaxMsgSize      :: {-# UNPACK #-} !Int
+
   } deriving (Show, Eq)
 
 defaultSeedTransaction :: Int
@@ -197,29 +197,9 @@ data Manager h raw msg = Manager
   , transactionCounter :: {-# UNPACK #-} !TransactionCounter
   , pendingCalls       :: {-# UNPACK #-} !(PendingCalls msg raw)
   , handlers           :: [Handler h msg raw]
+  , logMsg             :: Char -> String -> T.Text -> IO ()
   }
 
--- | A monad which can perform or handle queries.
-class (MonadBaseControl IO m, MonadLogger m, MonadIO m)
-    => MonadKRPC h m raw msg | m -> h, m -> raw, m -> msg  where
-
-  -- | Ask for manager.
-  getManager :: m (Manager h raw msg)
-
-  default getManager :: MonadReader (Manager h raw msg) m => m (Manager h raw msg)
-  getManager = ask
-
-  -- | Can be used to add logging for instance.
-  liftHandler :: h a -> m a
-
-  default liftHandler :: m a -> m a
-  liftHandler = id
-
-instance (MonadBaseControl IO h, MonadLogger h, MonadIO h)
-      => MonadKRPC h (ReaderT (Manager h raw msg) h) raw msg where
-
-  liftHandler = lift
-
 sockAddrFamily :: SockAddr -> Family
 sockAddrFamily (SockAddrInet  _ _    ) = AF_INET
 sockAddrFamily (SockAddrInet6 _ _ _ _) = AF_INET6
@@ -229,16 +209,17 @@ sockAddrFamily (SockAddrCan _        ) = AF_CAN
 -- | Bind socket to the specified address. To enable query handling
 -- run 'listen'.
 newManager :: Options                       -- ^ various protocol options;
+           -> (Char -> String -> T.Text -> IO ()) -- ^ loging function
            -> SockAddr                      -- ^ address to listen on;
            -> [Handler h msg raw] -- ^ handlers to run on incoming queries.
            -> IO (Manager h raw msg)                -- ^ new rpc manager.
-newManager opts @ Options {..} servAddr handlers = do
+newManager opts @ Options {..} logmsg servAddr handlers = do
     validateOptions opts
     sock  <- bindServ
     tref  <- newEmptyMVar
     tran  <- newIORef optSeedTransaction
     calls <- newIORef M.empty
-    return $ Manager sock opts tref tran calls handlers
+    return $ Manager sock opts tref tran calls handlers logmsg
   where
     bindServ = do
       let family = sockAddrFamily servAddr
@@ -261,11 +242,13 @@ isActive :: Manager m raw msg -> IO Bool
 isActive Manager {..} = liftIO $ isBound sock
 {-# INLINE isActive #-}
 
+#if 0
 -- | Normally you should use Control.Monad.Trans.Resource.allocate
 -- function.
 withManager :: Options -> SockAddr -> [Handler h msg raw]
             -> (Manager h raw msg -> IO a) -> IO a
 withManager opts addr hs = bracket (newManager opts addr hs) closeManager
+#endif
 
 {-----------------------------------------------------------------------
 --  Logging
@@ -306,10 +289,9 @@ genTransactionId ref = do
   uniqueTransactionId cur
 
 -- | How many times 'query' call have been performed.
-getQueryCount :: MonadKRPC h m raw msg => m Int
-getQueryCount = do
-  Manager {..} <- getManager
-  curTrans <- liftIO $ readIORef transactionCounter
+getQueryCount :: Manager h raw msg -> IO Int
+getQueryCount mgr@Manager{..} = do
+  curTrans <- readIORef transactionCounter
   return $ curTrans - optSeedTransaction options
 
 registerQuery :: Ord (TransactionID msg) => CallId msg -> PendingCalls msg raw -> IO (CallRes msg raw)
@@ -338,27 +320,26 @@ sendQuery sock addr q = handle sockError $ sendMessage sock addr q
 --  This function should throw 'QueryFailure' exception if quered node
 --  respond with @error@ message or the query timeout expires.
 --
-query :: forall h m a b raw msg. (SerializableTo raw b, Show (QueryMethod msg), Ord (TransactionID msg), Serialize (TransactionID msg), SerializableTo raw a, MonadKRPC h m raw msg, WireFormat raw msg) => QueryMethod msg -> SockAddr -> a -> m b
-query meth addr params = queryK meth addr params (\_ x _ -> x)
+query :: forall h a b raw msg. (SerializableTo raw b, Show (QueryMethod msg), Ord (TransactionID msg), Serialize (TransactionID msg), SerializableTo raw a, WireFormat raw msg) => Manager h raw msg -> QueryMethod msg -> SockAddr -> a -> IO b
+query mgr meth addr params = queryK mgr meth addr params (\_ x _ -> x)
 
 -- | Like 'query' but possibly returns your externally routable IP address.
-query' :: forall h m a b raw msg. (SerializableTo raw b, Show (QueryMethod msg), Ord (TransactionID msg), Serialize (TransactionID msg), SerializableTo raw a, MonadKRPC h m raw msg, WireFormat raw msg) => QueryMethod msg -> SockAddr -> a -> m (b, Maybe ReflectedIP)
-query' meth addr params = queryK meth addr params (const (,))
+query' :: forall h a b raw msg. (SerializableTo raw b, Show (QueryMethod msg), Ord (TransactionID msg), Serialize (TransactionID msg), SerializableTo raw a, WireFormat raw msg) => Manager h raw msg -> QueryMethod msg -> SockAddr -> a -> IO (b, Maybe ReflectedIP)
+query' mgr meth addr params = queryK mgr meth addr params (const (,))
 
 -- | Enqueue a query, but give us the complete BEncoded content sent by the
 -- remote Node.  This is useful for handling extensions that this library does
 -- not otherwise support.
-queryRaw :: forall h m a b raw msg. (SerializableTo raw b, Show (QueryMethod msg), Ord (TransactionID msg), Serialize (TransactionID msg), SerializableTo raw a, MonadKRPC h m raw msg, WireFormat raw msg) => QueryMethod msg -> SockAddr -> a -> m (b, raw)
-queryRaw meth addr params = queryK meth addr params (\raw x _ -> (x,raw))
+queryRaw :: forall h a b raw msg. (SerializableTo raw b, Show (QueryMethod msg), Ord (TransactionID msg), Serialize (TransactionID msg), SerializableTo raw a, WireFormat raw msg) => Manager h raw msg -> QueryMethod msg -> SockAddr -> a -> IO (b, raw)
+queryRaw mgr meth addr params = queryK mgr meth addr params (\raw x _ -> (x,raw))
 
-queryK :: forall h m a b x raw msg. (SerializableTo raw b, Show (QueryMethod msg), Ord (TransactionID msg), Serialize (TransactionID msg), SerializableTo raw a, MonadKRPC h m raw msg, WireFormat raw msg) =>
-    QueryMethod msg -> SockAddr -> a -> (raw -> b -> Maybe ReflectedIP -> x) -> m x
-queryK meth addr params kont = do
-  Manager {..} <- getManager
+queryK :: forall h a b x raw msg. (SerializableTo raw b, Show (QueryMethod msg), Ord (TransactionID msg), Serialize (TransactionID msg), SerializableTo raw a, WireFormat raw msg) =>
+    Manager h raw msg -> QueryMethod msg -> SockAddr -> a -> (raw -> b -> Maybe ReflectedIP -> x) -> IO x
+queryK mgr@Manager{..} meth addr params kont = do
   tid <- liftIO $ genTransactionId transactionCounter
   -- let queryMethod = method :: Method a b
   let signature = querySignature meth tid addr
-  $(logDebugS) "query.sending" signature
+  logMsg 'D' "query.sending" signature
 
   mres <- liftIO $ do
     ares <- registerQuery (tid, addr) pendingCalls
@@ -384,12 +365,12 @@ queryK meth addr params kont = do
 
   case mres of
     Just res -> do
-      $(logDebugS) "query.responded" $ signature
+      logMsg 'D' "query.responded" $ signature
       return res
 
     Nothing -> do
       _ <- liftIO $ unregisterQuery (tid, addr) pendingCalls
-      $(logWarnS) "query.not_responding" $ signature <> " for " <>
+      logMsg 'W' "query.not_responding" $ signature <> " for " <>
              T.pack (show (optQueryTimeout options)) <> " seconds"
       throw $ TimeoutExpired
 
@@ -440,31 +421,30 @@ handler name body = (name, wrapper)
         Left  e -> pure $ Left e
         Right a -> Right . encodePayload . buildReply (error "self node-id") addr args <$> body addr (envelopePayload a)
 
-runHandler :: ( MonadKRPC h m raw msg
-              , Envelope msg
+runHandler :: ( Envelope msg
               , Show (QueryMethod msg)
               , Serialize (TransactionID msg))
-           => QueryMethod msg -> HandlerBody h msg raw -> SockAddr -> msg raw -> m (KResult msg raw)
-runHandler meth h addr m = Lifted.catches wrapper failbacks
+           => Manager IO raw msg -> QueryMethod msg -> HandlerBody IO msg raw -> SockAddr -> msg raw -> IO (KResult msg raw)
+runHandler mgr@Manager{..} meth h addr m = Lifted.catches wrapper failbacks
   where
     signature = querySignature meth (envelopeTransaction m) addr
 
     wrapper = do
-      $(logDebugS) "handler.quered" signature
-      result <- liftHandler (h addr m)
+      logMsg 'D' "handler.quered" signature
+      result <- h addr m
 
       case result of
         Left msg -> do
-          $(logDebugS) "handler.bad_query" $ signature <> " !" <> T.pack msg
+          logMsg 'D' "handler.bad_query" $ signature <> " !" <> T.pack msg
           return $ Left $ KError ProtocolError (BC.pack msg) (envelopeTransaction m)
 
         Right a -> do -- KQueryArgs
-          $(logDebugS) "handler.success" signature
+          logMsg 'D' "handler.success" signature
           return $ Right a
 
     failbacks =
       [ E.Handler $ \ (e :: HandlerFailure) -> do
-          $(logDebugS) "handler.failed" signature
+          logMsg 'D' "handler.failed" signature
           return $ Left $ KError ProtocolError (prettyHF e) (envelopeTransaction m)
 
 
@@ -478,17 +458,15 @@ runHandler meth h addr m = Lifted.catches wrapper failbacks
           return $ Left $ KError GenericError (BC.pack (show e)) (envelopeTransaction m)
       ]
 
-dispatchHandler :: ( MonadKRPC h m raw msg
-                   , Eq (QueryMethod msg)
+dispatchHandler :: ( Eq (QueryMethod msg)
                    , Show (QueryMethod msg)
                    , Serialize (TransactionID msg)
                    , Envelope msg
-                   ) => QueryMethod msg -> msg raw -> SockAddr -> m (KResult msg raw)
-dispatchHandler meth q addr = do
-  Manager {..} <- getManager
+                   ) => Manager IO raw msg -> QueryMethod msg -> msg raw -> SockAddr -> IO (KResult msg raw)
+dispatchHandler mgr@Manager{..} meth q addr = do
   case L.lookup meth handlers of
     Nothing -> return $ Left $ KError MethodUnknown ("Unknown method " <> BC.pack (show meth)) (envelopeTransaction q)
-    Just h  -> runHandler meth h addr q
+    Just h  -> runHandler mgr meth h addr q
 
 {-----------------------------------------------------------------------
 --  Listener
@@ -501,16 +479,14 @@ dispatchHandler meth q addr = do
 -- peer B fork too many threads
 -- ... space leak
 --
-handleQuery :: ( MonadKRPC h m raw msg
-               , WireFormat raw msg
+handleQuery :: ( WireFormat raw msg
                , Eq (QueryMethod msg)
                , Show (QueryMethod msg)
                , Serialize (TransactionID msg)
-               ) => QueryMethod msg -> raw -> msg raw -> SockAddr -> m ()
-handleQuery meth raw q addr = void $ fork $ do
+               ) => Manager IO raw msg -> QueryMethod msg -> raw -> msg raw -> SockAddr -> IO ()
+handleQuery mgr@Manager{..} meth raw q addr = void $ fork $ do
   myThreadId >>= liftIO . flip labelThread "KRPC.handleQuery"
-  Manager {..} <- getManager
-  res <- dispatchHandler meth q addr
+  res <- dispatchHandler mgr meth q addr
   let  res' = either buildError Just res
        ctx = error "TODO TOX ToxCipherContext 2 or () for Mainline"
        resbs = fmap (encodeHeaders ctx) res' :: Maybe BS.ByteString
@@ -523,12 +499,10 @@ handleQuery meth raw q addr = void $ fork $ do
   --   ]
   maybe (return ()) (sendMessage sock addr) resbs
 
-handleResponse :: ( MonadKRPC h m raw msg
-                  , Ord (TransactionID msg)
+handleResponse :: ( Ord (TransactionID msg)
                   , Envelope msg
-                  ) => raw -> KResult msg raw -> SockAddr -> m ()
-handleResponse raw result addr = do
-  Manager {..} <- getManager
+                  ) => Manager IO raw msg -> raw -> KResult msg raw -> SockAddr -> IO ()
+handleResponse mgr@Manager{..} raw result addr = do
   liftIO $ do
     let resultId = either errorId envelopeTransaction result
     mcall <- unregisterQuery (resultId, addr) pendingCalls
@@ -540,16 +514,14 @@ data Protocol raw (msg :: * -> *) = Protocol { rawProxy :: !(Proxy raw)
                                              , msgProxy :: !(Proxy msg)
                                              }
 
-listener :: forall h m raw msg.
-            ( MonadKRPC h m raw msg
-            , WireFormat raw msg
+listener :: forall raw msg.
+            ( WireFormat raw msg
             , Ord (TransactionID msg)
             , Eq (QueryMethod msg)
             , Show (QueryMethod msg)
             , Serialize (TransactionID msg)
-            ) => Protocol raw msg -> m ()
-listener p = do
-  Manager {..} <- getManager
+            ) => Manager IO raw msg -> Protocol raw msg -> IO ()
+listener mgr@Manager{..} p = do
   fix $ \again -> do
     let ctx = error "TODO TOX ToxCipherContext or () for Mainline"
     (bs, addr) <- liftIO $ do
@@ -560,9 +532,9 @@ listener p = do
                        return () -- Without transaction id, error message isn't very useful.
       Right (raw,m) ->
         case envelopeClass m of
-            Query meth  -> handleQuery meth (raw::raw) m         addr
-            Response _  -> handleResponse   raw        (Right m) addr
-            Error e     -> handleResponse   raw        (Left  e) addr
+            Query meth  -> handleQuery mgr meth (raw::raw) m         addr
+            Response _  -> handleResponse mgr   raw        (Right m) addr
+            Error e     -> handleResponse mgr   raw        (Left  e) addr
 
     again
   where
@@ -574,17 +546,15 @@ listener p = do
 
 -- | Should be run before any 'query', otherwise they will never
 -- succeed.
-listen :: ( MonadKRPC h m raw msg
-          , WireFormat raw msg
+listen :: ( WireFormat raw msg
           , Ord (TransactionID msg)
           , Eq (QueryMethod msg)
           , Show (QueryMethod msg)
           , Serialize (TransactionID msg)
-          ) => Protocol raw msg -> m ()
-listen p = do
-  Manager {..} <- getManager
+          ) => Manager IO raw msg -> Protocol raw msg -> IO ()
+listen mgr@Manager{..} p = do
   tid <- fork $ do
     myThreadId >>= liftIO . flip labelThread "KRPC.listen"
-    listener p `Lifted.finally`
+    listener mgr p `Lifted.finally`
       liftIO (takeMVar listenerThread)
   liftIO $ putMVar listenerThread tid