Как закрыть `runTCPServer`?

Я пишу сервер сокетов с runTCPServer из conduit-extra (ранее известного как сетевой-канал). Моя цель - взаимодействовать с моим редактором с помощью этого сервера --- активировать сервер из редактора (скорее всего, просто вызвав внешнюю команду), использовать его и завершить работу сервера, когда работа будет выполнена.

Для простоты я начну с простого эхо-сервера, и, скажем, я хотел бы завершить весь процесс, когда соединение закрыто.

Итак, я попытался:

{-# LANGUAGE OverloadedStrings #-}
module Main where
import Data.Conduit
import Data.Conduit.Network
import Data.ByteString (ByteString)
import Control.Monad.IO.Class (liftIO)
import System.Exit (exitSuccess)
import Control.Exception

defaultPort :: Int
defaultPort = 4567
main :: IO ()
main = runTCPServer (serverSettings defaultPort "*") $ \ appData ->
        appSource appData $$ conduit =$= appSink appData

conduit :: ConduitM ByteString ByteString IO ()
conduit = do
    msg <- await
    case msg of
         Nothing -> liftIO $ do
             putStrLn "Nothing left"
             exitSuccess
             -- I'd like the server to shut down here
         (Just s) -> do
             yield s
             conduit

Но это не работает — программа продолжает принимать новые подключения. Если я не ошибаюсь, это потому, что поток, слушающий соединение, с которым мы имеем дело, завершается с exitSuccess, а весь процесс — нет. Так что это совершенно понятно, но я не смог найти способ выйти из всего процесса.

Как закрыть сервер под управлением runTCPServer? runTCPServer должно служить вечно?


haskell network-conduit
person Yosh    schedule 19.06.2016    source источник
comment
exit должен вызываться из основного потока (не знаю почему, но это требование). Вы всегда можете запустить runTCPServer в отдельном потоке forkIOd, и заставить основной поток ждать некоторого MVar, который устанавливает рабочий поток, когда приходит сообщение о завершении.   -  person n. 1.8e9-where's-my-share m.    schedule 19.06.2016
comment
И да, runTCPServer предназначен для вечной работы, см. источник.   -  person n. 1.8e9-where's-my-share m.    schedule 19.06.2016
comment
@н.м. Кажется, это точный ответ (особенно часть forkIO и MVar), который я искал. Не могли бы вы добавить простой пример (если не возражаете) и опубликовать его как ответ?   -  person Yosh    schedule 19.06.2016
comment
Вы пробовали только return () вместо exitSuccess?   -  person NovaDenizen    schedule 19.06.2016
comment
@NovaDenizen Да, и результат тот же. К return () поток завершается, но основной процесс продолжает ожидать другого соединения.   -  person Yosh    schedule 19.06.2016

Ответы (1)


arrow_upward
2
arrow_downward

Вот простая реализация идеи, описанной в комментариях:

main = do
     mv <- newEmptyMVar
     tid <- forkTCPServer (serverSettings defaultPort "*") $ \ appData ->
        appSource appData $$ conduit mv =$= appSink appData
     () <- takeMVar mv -- < -- wait for done signal
     return ()

conduit :: MVar () -> ConduitM ByteString ByteString IO ()
conduit mv = do
    msg <- await
    case msg of
         Nothing -> liftIO $ do
             putStrLn "Nothing left"
             putMVar mv () -- < -- signal that we're done
         (Just s) -> do
             yield s
             conduit mv
person n. 1.8e9-where's-my-share m.    schedule 19.06.2016