Im folgenden Beispiel wurden alle vorgestellten Konzepte aufgegriffen und in einer Anwendung implementiert, welche aber im Rahmen dieser Ausarbeitung nicht näher betrachtet werden. Es handelt sich um eine Anwendung, die ein einfaches raumorientiertes Chatten im lokalen Netzwerk ermöglicht.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 | ...
newtype MonitorRefTypeable = MonitorRefTypeable MonitorRef deriving (Generic, Typeable, Show)
type ChatServerSearchReply = Maybe ProcessId
data JoinChatMessage = JoinChat { clientName :: String,
clientPid :: ProcessId }
deriving (Generic, Typeable, Show)
data ChatMessage = ChatMessage { from :: ProcessId,
message :: String }
deriving (Generic, Typeable, Show)
$( derive makeBinary ''JoinChatMessage )
$( derive makeBinary ''ChatMessage )
$( derive makeBinary ''MonitorRefTypeable)
type ChatServerClient = (String, MonitorRefTypeable)
type ChatMessageHistory = [String]
type ChatServerClientMap = Map ProcessId ChatServerClient
mkChatServerClient :: String -> MonitorRef -> ChatServerClient
mkChatServerClient name monitorRef = (name, MonitorRefTypeable monitorRef)
mkJoinChatMessage :: ProcessId -> String -> JoinChatMessage
mkJoinChatMessage pid msg = JoinChat {clientPid = pid, clientName = msg}
mkChatMessage :: ProcessId -> String -> ChatMessage
mkChatMessage pid msg = ChatMessage {from = pid, message = msg}
chatClientName :: ChatServerClient -> String
chatClientName (name, _) = name
searchChatServer :: Backend -> String -> Process ChatServerSearchReply
searchChatServer backend chatRoom =
searchChatServer' =<< liftIO (findPeers backend 2000)
where
searchChatServer' :: [NodeId] -> Process ChatServerSearchReply
searchChatServer' (peer : xs) = do
flip send "Message while searching for a chat server..." =<< getSelfPid
whereisRemoteAsync peer chatRoom
WhereIsReply _name remoteWhereIs <- expect
case remoteWhereIs of
Just chatServerPid -> return (Just chatServerPid)
_ -> searchChatServer' xs
searchChatServer' [] = return Nothing
initChatServer :: Backend -> String -> Process ProcessId
initChatServer backend chatRoom =
reply =<< searchChatServer backend chatRoom
where
reply :: ChatServerSearchReply -> Process ProcessId
reply Nothing = do
chatServerPid <- getSelfPid
register chatRoom chatServerPid
return chatServerPid
reply (Just chatServerPid) = return chatServerPid
startChatServer :: Backend -> String -> Process ()
startChatServer backend chatRoom = do
foundChatServerPid <- initChatServer backend chatRoom
serve foundChatServerPid =<< getSelfPid
where
serve :: ProcessId -> ProcessId -> Process ()
serve pid self
| pid == self = say "Starting Chat Server..." >> serverLoop self Map.empty []
| otherwise = liftIO . putStrLn $ "Chat Server already started with the PID: " ++ show pid ++ "..."
serverLoop :: ProcessId -> ChatServerClientMap -> ChatMessageHistory -> Process()
serverLoop self clients msgHistory =
receiveWait
[
match (\(ChatMessage {from=pid, message=msg}) -> do
let sendMessage = ": " ++ msg
say $ show pid ++ sendMessage
broadcastMessage self pid sendMessage clients
serverLoop self clients (sendMessage : msgHistory)
),
match (\(JoinChat {clientName=name, clientPid=chatClientPid}) -> do
say $ name ++ " is joining the chat..."
clientMonitorRef <- monitor chatClientPid
let newClients = Map.insert chatClientPid (mkChatServerClient name clientMonitorRef) clients
broadcastMessage self chatClientPid " is joining the chat..." newClients
sendMsgHistoryToNewClient self chatClientPid $ reverse msgHistory
serverLoop self newClients msgHistory
),
match (\(ProcessMonitorNotification _monitorRef processId _) -> do
say $ show processId ++ " is leaving the chat..."
broadcastMessage self processId " is leaving the chat..." clients
serverLoop self (Map.delete processId clients) msgHistory
),
match (\(msg :: String) -> do
say $ "Unkown message recieved: " ++ msg
serverLoop self clients msgHistory
),
matchUnknown $ serverLoop self clients msgHistory
]
broadcastMessage :: ProcessId -> ProcessId -> String -> ChatServerClientMap -> Process ()
broadcastMessage serverPid fromPid msg clients = do
let client = clients Map.! fromPid
let groupMsg = chatClientName client ++ msg
mapM_ (\(cPid, _chatClient) -> send cPid $ mkChatMessage serverPid groupMsg) . filter (\(cPid, _) -> fromPid /= cPid) $ Map.toList clients
sendMsgHistoryToNewClient :: ProcessId -> ProcessId -> ChatMessageHistory -> Process ()
sendMsgHistoryToNewClient _serverPid _ [] = return ()
sendMsgHistoryToNewClient serverPid cPid (msg : xs) = send cPid (mkChatMessage serverPid msg) >> sendMsgHistoryToNewClient serverPid cPid xs
startChatClient :: Backend -> String -> String -> Process ()
startChatClient backend chatRoom name = do
chatClientPid <- getSelfPid
csReply <- searchChatServer backend chatRoom
case csReply of
Just chatServerPid -> do
link chatServerPid
liftIO . putStrLn $ "Chat Server found!..."
-- joining the chat
send chatServerPid $ mkJoinChatMessage chatClientPid name
-- spwan the terminal input process to watch for user input
consoleInputPid <- spawnLocal $ forever $ consoleInputProcess
link consoleInputPid
-- handle the user chat client logic
forever $ handleChatClient consoleInputPid chatServerPid
where
consoleInputProcess :: Process ()
consoleInputProcess = do
link chatClientPid
pid <- getSelfPid
liftIO . putStr $ "Message: "
liftIO $ hFlush stdout
msg <- liftIO getLine
if not $ null msg
then send chatClientPid $ mkChatMessage pid msg
else return ()
handleChatClient :: ProcessId -> ProcessId -> Process ()
handleChatClient consolePid serverPid = do
self <- getSelfPid
receiveWait [
matchIf (\(ChatMessage {from = pid, message = _msg}) -> consolePid == pid)
(\(ChatMessage {from = _pid, message = msg}) -> do
send serverPid $ mkChatMessage self msg),
matchIf (\(ChatMessage {from = pid, message = _msg}) -> pid == serverPid)
(\(ChatMessage {from = _pid, message = msg}) -> liftIO . putStrLn $ "
" ++ msg)
]
Nothing -> liftIO . putStrLn $ "No Chat Server found..."
...
main :: IO ()
main = do
let host = "localhost"
args <- getArgs
case args of
["chat_server", port, chatRoom] -> do
distributedContext <- configSimpleLocalnetBackend host port
node <- newLocalNode distributedContext
runProcess node (startChatServer distributedContext chatRoom)
["chat_client", name, port, chatRoom] -> do
distributedContext <- configSimpleLocalnetBackend host port
node <- newLocalNode distributedContext
runProcess node (startChatClient distributedContext chatRoom name)
other -> do
putStrLn $ "Unkown command: " ++ show other
|