Один технологический канал, 2 источника ИО того же типа

В моем приложении GHC Haskell, использующем stm, network-conduit и conduit, у меня есть прядь для каждого сокета, который автоматически разветвляется с помощью runTCPServer. Стренды могут обмениваться информацией с другими каналами с помощью трансляционного TChan.

Это демонстрирует, как я хотел бы настроить цепочку каналов:

enter image description here

Итак, у нас есть два источника (каждая связана с вспомогательными каналами, которые), которые создают объект 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)

Аналогично, функция преобразования Чан в раковину;

-- | 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 threads (которые я действительно не хочу делать, но что это за черт), которые могут помещать свои новые предметы в один список, который я затем создаю источником;

-- | 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

В то время как я был успешным в выполнении этих функций typecheck, мне не удалось получить какое-либо использование этих функций для typecheck;

-- | 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, пока Я не жду на одном, а у другого есть объекты, готовые к употреблению.

ПФС. Я прошу прощения за использование (и, следовательно, требование знания) объектива в примере кода.

Ответ 1

Я не знаю, если это поможет, но я попытался реализовать предложение Iain и сделал вариант 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
    

    Возможно, это немного поможет при использовании mergeSources' в serverApp.

  • Просто косметическая проблема, я нашел

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

    очень трудно читать из-за использования liftA2 в монаде (->) r. Я бы сказал,

    do
        c <- liftSTM newTMChan
        fsrc sx c
        retn c
    

    будет длиннее, но гораздо легче читать.

Не могли бы вы создать автономный проект, где можно было бы играть с serverApp?