improved distributed example
This commit is contained in:
Alberto G. Corona
parent
983065ce9e
commit
0935e92c37
1 changed files with 82 additions and 39 deletions
|
|
@ -1,9 +1,9 @@
|
|||
{-# LANGUAGE CPP,NoMonomorphismRestriction #-}
|
||||
{-# LANGUAGE CPP, NoMonomorphismRestriction, DeriveDataTypeable #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Prelude hiding (div,id)
|
||||
import Transient.Base
|
||||
import Transient.Internals
|
||||
|
||||
|
||||
|
||||
|
|
@ -27,86 +27,117 @@ import Transient.MapReduce
|
|||
import Control.Monad.IO.Class
|
||||
import Data.String
|
||||
import qualified Data.Text as T
|
||||
|
||||
#ifdef ghcjs_HOST_OS
|
||||
import qualified Data.JSString as JS hiding (span,empty,strip,words)
|
||||
#endif
|
||||
|
||||
import Data.Typeable
|
||||
|
||||
|
||||
main = keep $ initNode $ mapReduce <|> chat <|> inputNodes <|> mapReduceServer
|
||||
|
||||
|
||||
mapReduceServer= onServer $ do
|
||||
local $ option "text" "enter text to count the words"
|
||||
content <- local $ input (const True) "enter the content: "
|
||||
|
||||
r<- reduce (+) . mapKeyB (\w -> (w, 1 :: Int)) $ distribute $ V.fromList $ words content
|
||||
localIO $ putStr "result:" >> print (r :: M.Map String Int)
|
||||
data Options= MapReduce | Chat | MonitorNodes | AllThree deriving (Typeable, Read, Show)
|
||||
|
||||
main = keep' $ initNode $ inputNodes <|> do
|
||||
op <- local . render $
|
||||
wlink MapReduce (b "map-reduce") <++ fs " " <|>
|
||||
wlink Chat (b "chat") <++ fs " " <|>
|
||||
wlink MonitorNodes (b "monitor nodes") <++ fs " " <|>
|
||||
wlink AllThree (b "all widgets")
|
||||
|
||||
case op of
|
||||
AllThree -> allw
|
||||
MapReduce -> mapReduce
|
||||
Chat -> chat
|
||||
MonitorNodes -> monitorNodes
|
||||
|
||||
|
||||
allw= mapReduce <|> chat <|> monitorNodes
|
||||
|
||||
|
||||
|
||||
|
||||
-- A Web node launch a map-reduce computation in all the server nodes, getting data from a
|
||||
-- textbox and render the results returned
|
||||
|
||||
mapReduce= onBrowser $ do
|
||||
|
||||
content <- local . render $
|
||||
textArea (fs "") ! atr "placeholder" (fs "enter the content")
|
||||
! atr "rows" (fs "4")
|
||||
! atr "cols" (fs "80")
|
||||
|
||||
|
||||
<++ br
|
||||
<** inputSubmit "send" `fire` OnClick
|
||||
<++ br
|
||||
content <- local . render $
|
||||
h1 "Map-Reduce widget" ++>
|
||||
p "Return the frequencies of words from a text using all the server nodes connected" ++>
|
||||
textArea (fs "") ! atr "placeholder" (fs "enter the content")
|
||||
! atr "rows" (fs "4")
|
||||
! atr "cols" (fs "80")
|
||||
<++ br
|
||||
<** inputSubmit "send" `fire` OnClick
|
||||
<++ br
|
||||
|
||||
r <- atRemote $ do
|
||||
lliftIO $ print content
|
||||
r<- reduce (+) . mapKeyB (\w -> (w, 1 :: Int)) $ distribute $ V.fromList $ words content
|
||||
lliftIO $ putStr "result:" >> print r
|
||||
return (r :: M.Map String Int)
|
||||
lliftIO $ print content
|
||||
r<- reduce (+) . mapKeyB (\w -> (w, 1 :: Int)) $ distribute $ V.fromList $ words content
|
||||
lliftIO $ putStr "result:" >> print r
|
||||
return (r :: M.Map String Int)
|
||||
|
||||
|
||||
local . render $ rawHtml $ do
|
||||
h1 "Results"
|
||||
mconcat[i "word " >> b w >> i " appears " >> b n >> i " times" >> br
|
||||
| (w,n) <- M.assocs r]
|
||||
h1 "Results"
|
||||
mconcat[i "word " >> b w >> i " appears " >> b n >> i " times" >> br
|
||||
| (w,n) <- M.assocs r]
|
||||
|
||||
empty
|
||||
|
||||
fs= fromString
|
||||
|
||||
-- a chat widget that run in the browser and in a cloud of servers
|
||||
|
||||
chat= onBrowser $ do
|
||||
|
||||
|
||||
|
||||
|
||||
chat = do
|
||||
|
||||
let chatMessages= fs "chatMessages"
|
||||
|
||||
local . render . rawHtml $
|
||||
local . render . rawHtml $ do
|
||||
h1 "Federated chat server"
|
||||
div ! id (fs "chatbox")
|
||||
! style (fs $"margin-top:1cm;overflow: auto;height: 200px;"
|
||||
! style (fs $"overflow: auto;height: 200px;"
|
||||
++ "background-color: #FFCC99; max-height: 200px;")
|
||||
$ noHtml -- create the chat box
|
||||
|
||||
sendMessages chatMessages <|> waitMessages chatMessages
|
||||
sendMessages chatMessages <|> waitMessages chatMessages
|
||||
|
||||
where
|
||||
sendMessages chatMessages = do
|
||||
let entry= boxCell (fs "msg") ! atr "size" (fs "90")
|
||||
text <- local . render $ (mk entry Nothing ) `fire` OnChange
|
||||
<** inputSubmit "send"
|
||||
<++ br
|
||||
|
||||
|
||||
sendMessages chatMessages = do
|
||||
-- node <- atRemote $ local getMyNode
|
||||
let entry= boxCell (fs "msg") ! atr "size" (fs "60")
|
||||
(nick,text) <- local . render $ (,) <$> getString (Just "anonymous") ! size (fs "10")
|
||||
<*> mk entry Nothing `fire` OnChange
|
||||
<** inputSubmit "send"
|
||||
<++ br
|
||||
local $ entry .= ""
|
||||
|
||||
atRemote $ do
|
||||
node <- local getMyNode
|
||||
clustered $ local $ putMailbox chatMessages (showNode node ++ text :: String)
|
||||
return ()
|
||||
|
||||
showNode node= show node ++ ">"
|
||||
clustered $ local $ putMailbox chatMessages (showPrompt nick node ++ text ) >> empty :: Cloud ()
|
||||
empty
|
||||
|
||||
waitMessages chatMessages = do
|
||||
resp <- atRemote . local $ getMailbox chatMessages -- atRemote, in the server
|
||||
where
|
||||
fs= fromString
|
||||
size= atr (fs "size")
|
||||
showPrompt u (Node h p _ _)= u ++ "@" ++ h ++ ":" ++ show p ++ "> "
|
||||
|
||||
waitMessages chatMessages = do
|
||||
|
||||
resp <- atRemote . local $ single $ getMailbox chatMessages
|
||||
-- wait in the server for messages
|
||||
|
||||
local . render . at (fs "#chatbox") Append $ rawHtml $ do
|
||||
local . render . at (fs "#chatbox") Append $ rawHtml $ do
|
||||
p (resp :: String) -- display the response
|
||||
#ifdef ghcjs_HOST_OS
|
||||
liftIO $ scrollBottom $ fs "chatbox"
|
||||
|
|
@ -117,6 +148,18 @@ foreign import javascript unsafe
|
|||
scrollBottom :: JS.JSString -> IO()
|
||||
#endif
|
||||
|
||||
monitorNodes= do
|
||||
local . render $ rawHtml $ do
|
||||
h1 "Nodes connected"
|
||||
div ! atr (fs "id") (fs "nodes") $ noHtml
|
||||
|
||||
nodes <- atRemote . local $ single $ sample getNodes 1000000
|
||||
|
||||
local . render . at (fs "#nodes") Insert . rawHtml $
|
||||
table $ mconcat[tr $ td h >> td p >> td s | Node h p _ s <- nodes]
|
||||
empty
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue