haskell - 在 Scotty 服务器中 fork 新线程

Question

我正在使用两个 API 在 Scotty 中构建 Web 服务器原型(prototype):

• /add/:id使用给定 ID 启动异步任务。
• /cancel/:id终止给定 ID 的任务。

基本上，客户端通过提供一些 Id 来启动异步任务，也可以通过 Id 终止当前任务。

我使用Control.Concurrent.forkIO启动线程，forkIO返回 ThreadId我存储在 Scotty 全局状态中，这是一个 map :type AppState = Map TaskId ThreadId .

/add/:id不会立即返回，而是等待任务完成并将结果返回给客户端。

我的问题是混合 forkIO与 MonadIO m => ActionT Text m () 。我需要能够调用 text :: Text -> ActionT Text m ()完成后IO ()我通过的行动forkIO .

这需要从MonadIO m开始至IO这显然是一个错误，但我无法解决它并找到任何解决方案。

这是完整的示例:

import qualified Control.Concurrent as C
import qualified Control.Concurrent.STM as STM
import Control.Monad.Trans.Reader (ReaderT(..), runReaderT)
import Control.Monad.Trans (MonadIO)
import Control.Monad.Reader (MonadReader, lift, liftIO, ask)
import qualified Data.Map as M
import Data.Text.Lazy (Text, pack, unpack)
import Web.Scotty.Trans


type TaskId = String

type AppState = M.Map TaskId C.ThreadId

newtype WebM a = WebM { runWebM :: ReaderT (STM.TVar AppState) IO a }
  deriving (Applicative, Functor, Monad, MonadIO, MonadReader (STM.TVar AppState))

app :: ScottyT Text WebM ()
app = do
  get "/add/:id" $ do
    taskId <- fmap unpack (param "id")
    let task = return "Hello World" -- just a dummy IO
    tid <- liftIO $ C.forkIO $ do
      result <- task
      -- Couldn't match type ‘ActionT Text m’ with ‘IO’
      lift $ modify' $ M.delete taskId -- remove the completed task from the state
      text result -- return the result to the client
      return () -- forkIO :: IO () -> IO ThreadId
    lift $ modify' $ M.insert taskId tid -- immedialtey add the new task to the state

  get "/cancel/:id" $ do
    taskId <- fmap unpack (param "id")
    dic <- lift $ gets id
    maybe
      (text $ pack (taskId ++ " Not Found"))
      (
        \ tid -> do
          liftIO $ C.killThread tid
          lift $ modify' $ M.delete taskId -- remove the cancelled task from the state
          text $ pack (taskId ++ " Cancelled")
      )
      (M.lookup taskId dic)

gets :: (AppState -> b) -> WebM b
gets f = fmap f (ask >>= liftIO . STM.readTVarIO)

modify' :: (AppState -> AppState) -> WebM ()
modify' f = ask >>= liftIO . STM.atomically . flip STM.modifyTVar' f

main :: IO ()
main = do
  dic <- STM.newTVarIO M.empty
  let runActionToIO m = runReaderT (runWebM m) dic
  scottyT 3000 runActionToIO app

Answer 1

我认为您需要将对 text result 的调用移出 fork 线程，并在结果准备就绪时使用 MVar 进行通信。所以类似

get "/add/:id" $ do
    taskId <- fmap unpack (param "id")
    let task = return "Hello World"
    m <- newEmptyMVar
    tid <- liftIO $ C.forkIO $ do
        result <- task
        putMVar result
        ...
    r <- takeMVar m
    text r

takeMVar 将阻塞，直到 MVar 包含一个值。