haskell - Scotty サーバーで新しいスレッドをフォークする

Question

Scotty で 2 つの API を使用して Web サーバーのプロトタイプを作成しています。

• /add/:id指定された ID で非同期タスクを開始します。
• /cancel/:id指定された ID のタスクを強制終了します。

基本的に、クライアントはいくつかの Id を提供することで非同期タスクを開始し、ID によって現在のタスクを強制終了することもできます。

Control.Concurrent.forkIOスレッドを開始するために使用し、 Map: である Scotty グローバル状態に保存した をforkIO返します。ThreadIdtype 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