Forking new Threads in Scotty Server

I am prototyping a Web server in Scotty with two APIs:

/add/:id starts an asyc task with the given Id.
/cancel/:id kills the task for the given Id.

Basically clients start async tasks by providing some Ids and can also kill their current tasks by their Ids.

I use Control.Concurrent.forkIO to start a thread, forkIO returns a ThreadId that I store in the Scotty global state which is a Map: type AppState = Map TaskId ThreadId.

/add/:id does not return immediately but it waits for the task to complete and returns the result to the client.

My problem is mixing forkIO with MonadIO m => ActionT Text m (). I need to be able to call text :: Text -> ActionT Text m () after the completion of the IO () action that I passed forkIO.

This requires going from MonadIO m to IO that is obviously an error, but I cannot get my head around it and find any solution.

This is the full example:

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

Solution

I think you need to move the call to text result out of the forked thread and use an MVar to communicate when the result is ready. So something like

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 will block until the MVar contains a value.