https://imgur.com/DWqWK00

Room.hs

module Room
  ( roomProcess
  , roomService
  -- Client API
  , joinRoom
  , partRoom
  , sendRoom
  , listRoom
  -- Server API is private
  ) where

import Control.Distributed.Process                (Process, ProcessId,
                                                   getSelfPid, register, send,
                                                   spawnLocal)
import Control.Distributed.Process.Extras         (Recipient (..))
import Control.Distributed.Process.Extras.Time    (Delay (..))
import Control.Distributed.Process.ManagedProcess

import           Control.Monad
import qualified Data.ByteString.Lazy.Char8 as BSL
import qualified Data.HashMap.Strict        as HM
import           Data.Maybe

type RoomState = HM.HashMap ProcessId BSL.ByteString

type RoomCastHandler a = RoomState -> a -> Process (ProcessAction RoomState)
type RoomCallHandler i o = RoomState -> i -> Process (ProcessReply o RoomState)

roomProcess :: String -> Process ()
roomProcess name = do
    pid <- spawnLocal $ serve () initHandler roomService
    register name pid
  where
    initHandler () = pure $ InitOk mempty NoDelay

roomService :: ProcessDefinition RoomState
roomService = defaultProcess
  { apiHandlers =
    [ handleCast joinRoomHandler
    , handleCast partRoomHandler
    , handleCast sendRoomHandler
    , handleCall listRoomHandler
    ]
  , unhandledMessagePolicy = Log
  }

joinRoom :: String -> BSL.ByteString -> Process ()
joinRoom room nick = do
  pid <- getSelfPid
  cast (Registered room) (pid, nick)

joinRoomHandler :: RoomCastHandler (ProcessId, BSL.ByteString)
joinRoomHandler state (pid, name) = do
  -- TODO: monitor pid and kick automatically
  let newState = HM.insert pid name state
  continue newState

partRoom :: String -> Process ()
partRoom room = do
  pid <- getSelfPid
  cast (Registered room) pid

partRoomHandler :: RoomCastHandler ProcessId
partRoomHandler state pid = do
  let newState = HM.delete pid state
  continue newState

sendRoom :: String -> BSL.ByteString -> BSL.ByteString -> Process ()
sendRoom room nick msg =
  cast (Registered room) (nick, msg)

sendRoomHandler :: RoomCastHandler (BSL.ByteString, BSL.ByteString)
sendRoomHandler state (name, msg) = do
  -- TODO: put room name somewhere
  mapM_ (`send` (BSL.pack "#roomname", name, msg)) (HM.keys state)
  continue state

listRoom :: String -> Process [BSL.ByteString]
listRoom room = do
  nicks <- tryCall (Registered room) ()
  pure $ fromMaybe [] nicks

listRoomHandler :: RoomCallHandler () [BSL.ByteString]
listRoomHandler state () = reply (HM.elems state) state