一个处理管道，2个相同类型的IO源

Question

在我使用stm，network-conduit和conduit的GHC Haskell应用程序中，每个socket都有一个strand，它使用runTCPServer自动分叉。 Strands可以通过使用广播TChan与其他线路进行通信。

这展示了我想如何建立管道“链”：

所以，我们这里有两个源（每个绑定到辅助管道），它们产生一个Packet对象， encoder将接受并转换为ByteString ，然后发送出套接字。 对于两个输入的有效（性能是一个问题），我遇到了很大的困难。

如果有人能指出我正确的方向，我将不胜感激。

---

既然我没有尝试就发布这个问题是不礼貌的，我会把我以前在这里尝试过的东西放进去;

我已经编写/编写了一个函数，它（阻塞）从TMChan（可关闭的通道）生成一个源;

-- | Takes a generic type of STM chan and, given read and close functionality,
--   returns a conduit 'Source' which consumes the elements of the channel.
chanSource 
    :: (MonadIO m, MonadSTM m)
    => a                    -- ^ The channel
    -> (a -> STM (Maybe b)) -- ^ The read function
    -> (a -> STM ())        -- ^ The close/finalizer function
    -> Source m b
chanSource ch readCh closeCh = ConduitM pull
    where close     = liftSTM $ closeCh ch
          pull      = PipeM $ liftSTM $ readCh ch >>= translate
          translate = return . maybe (Done ()) (HaveOutput pull close)

同样，将Chan转换为接收器的功能;

-- | Takes a stream and, given write and close functionality, returns a sink
--   which wil consume elements and broadcast them into the channel 
chanSink
    :: (MonadIO m, MonadSTM m)
    => a                 -- ^ The channel
    -> (a -> b -> STM()) -- ^ The write function
    -> (a -> STM())      -- ^ The close/finalizer function
    -> Sink b m ()
chanSink ch writeCh closeCh = ConduitM sink
    where close  = const . liftSTM $ closeCh ch
          sink   = NeedInput push close
          write  = liftSTM . writeCh ch
          push x = PipeM $ write x >> return sink

那么mergeSources很简单; fork 2个线程（我真的不想这么做，但是到底是什么）可以将他们的新项目放入一个列表中，然后我生成一个源代码;

-- | Merges a list of 'Source' objects, sinking them into a 'TMChan' and returns
--   a source which consumes the elements of the channel.
mergeSources
    :: (MonadIO m, MonadBaseControl IO m, MonadSTM m)
    => [Source (ResourceT m) a]             -- ^ The list of sources
    -> ResourceT m (Source (ResourceT m) a)
mergeSources sx = liftSTM newTMChan >>= liftA2 (>>) (fsrc sx) retn
    where push c s = s $$ chanSink c writeTMChan closeTMChan
          fsrc x c = mapM_ (\s -> resourceForkIO $ push c s) x
          retn c   = return $ chanSource c readTMChan closeTMChan

虽然我成功地完成了这些功能的类型检查，但是我没有成功地将这些功能用于类型检查。

-- | Helper which represents a conduit chain for each client connection
serverApp :: Application SessionIO
serverApp appdata = do
    use ssBroadcast >>= liftIO . atomically . dupTMChan >>= assign ssBroadcast
    -- appSource appdata $$ decoder $= protocol =$= encoder =$ appSink appdata
    mergsrc $$ protocol $= encoder =$ appSink appdata
    where chansrc = chanSource (use ssBroadcast) readTMChan closeTMChan
          mergsrc = mergeSources [appSource appdata $= decoder, chansrc]

-- | Structure which holds mutable information for clients
data SessionState = SessionState
    { _ssBroadcast     :: TMChan Packet -- ^ Outbound packet broadcast channel
    }

makeLenses ''SessionState

-- | A transformer encompassing both SessionReader and SessionState
type Session m = ReaderT SessionReader (StateT SessionState m)

-- | Macro providing Session applied to an IO monad
type SessionIO = Session IO

我认为这种方法无论如何都有缺陷 - 有许多中间列表和转换。 这对性能不利。 寻求指导。

---

PS。 据我所知，这不是重复的; 融合导管有多个输入 ，因为在我的情况下，两个源都产生相同的类型，我不关心Packet对象产生的源，只要我不等待一个，而另一个有对象准备被消耗。

PPS。 我为示例代码中的Lens的使用（以及因此需要知识）道歉。

Answer 1

我不知道它是否有任何帮助，但我试图实现Iain的建议并制作了一个mergeSources'的变体， mergeSources'在任何一个频道停止时立即停止：

mergeSources' :: (MonadIO m, MonadBaseControl IO m)
              => [Source (ResourceT m) a] -- ^ The sources to merge.
              -> Int -- ^ The bound of the intermediate channel.
              -> ResourceT m (Source (ResourceT m) a)
mergeSources' sx bound = do
    c <- liftSTM $ newTBMChan bound
    mapM_ (\s -> resourceForkIO $
                    s $$ chanSink c writeTBMChan closeTBMChan) sx
    return $ sourceTBMChan c

（这个简单的加法，请点击这里 ）。

对你的mergeSources版本的一些评论（带上一粒盐，它可能是我不明白的东西）：

• 使用...TMChan代替...TBMChan似乎很危险。 如果编写者比读者快，那么你的堆就会崩溃。 如果你的TCP对等体没有足够快地读取数据，那么看看你的图表似乎很容易发生这种情况。 所以我肯定会使用...TBMChan可能很大但有限。

• 您不需要MonadSTM m约束。 所有STM内容都包含在IO中

   liftSTM = liftIO . atomically 

  在serverApp使用mergeSources'时，这可能会对您有所帮助。

• 我找到了一个化妆品问题

   liftSTM newTMChan >>= liftA2 (>>) (fsrc sx) retn 

  由于在(->) r monad上使用了liftA2 ，所以很难阅读。 我会说

   do c <- liftSTM newTMChan fsrc sx c retn c 

  会更长，但更容易阅读。

您是否可以创建一个可以与serverApp一起使用的自包含项目？