distributedApps.hs

#!/usr/bin/env ./execthirdline.sh
-- compile it with ghcjs and  execute it with runghc
-- set -e && port=`echo ${3} | awk -F/ '{print $(3)}'` && docker run -it -p ${port}:${port} -v $(pwd):/work agocorona/transient:05-02-2017  bash -c "mkdir -p static && ghcjs /work/${1} -o static/out && runghc /work/${1} ${2} ${3}"


-- set -e &&  port=`echo ${3} | awk -F/ '{print $(3)}'` && docker run -it -p ${port}:${port} -v /c/Users/magocoal/OneDrive/Haskell/devel:/devel agocorona/transient:05-02-2017  bash -c "mkdir -p static && ghcjs  -j2 -isrc -i/devel/transient/src -i/devel/transient-universe/src -i/devel/ghcjs-hplay/src -i/devel/ghcjs-perch/src /devel/transient-universe/examples/$1 -o static/out && runghc  -j2 -isrc -i/devel/transient/src -i/devel/transient-universe/src -i/devel/ghcjs-hplay/src -i/devel/ghcjs-perch/src /devel/transient-universe/examples/$1 $2 $3 $4"

-- usage: ./distributedApps.hs -p start/<docker ip>/<port>

{-# LANGUAGE   CPP, NoMonomorphismRestriction, DeriveDataTypeable  #-}

module Main where

import Prelude hiding (div,id)
import Transient.Internals

import GHCJS.HPlay.Cell
import GHCJS.HPlay.View hiding (map, input,option,parent)

import Transient.Move
import Transient.EVars
import Transient.Indeterminism

import Control.Applicative
import qualified Data.Vector as V
import qualified Data.Map as M
import Transient.MapReduce
import Control.Monad.IO.Class
import Control.Monad
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
import Data.Monoid

import qualified Data.ByteString.Lazy.Char8 as BS
import Transient.Logged


import Transient.Internals
import Control.Concurrent.MVar
import System.IO.Unsafe
import Control.Concurrent
import Control.Monad.State
import Control.Concurrent.STM

data Options= MapReduce | Chat | MonitorNodes | AllThree deriving (Typeable, Read, Show)


main = keep $  initNode  $ inputNodes <|> menuApp  <|> thelink




thelink=   do
     local . render $ rawHtml $ do
         br;br
         a ! href (fs "https://github.com/agocorona/transient-universe/blob/master/examples/distributedApps.hs") $ "source code"
     empty

menuApp= do
     local . render . rawHtml $ do
        h1 "Transient Demo"
        br; br
     op <- local .  render $
               tlink MapReduce (b "map-reduce") <++ fs "   " <|>
               tlink Chat (b "chat")  <++ fs "   " <|>
               tlink MonitorNodes (b "monitor nodes") <++ fs "   "  <|>
               tlink AllThree  (b "all widgets")

     case op of
               AllThree -> allw
               MapReduce -> mapReduce                        -- !> " option 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 $
            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
--    return () !> ("content",content)

    guard (content /= "")
    msg <-   local genNewId
    let entry= boxCell msg ! size  (fs "60")

    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)
    
    
        local . render $ rawHtml $ do
                 h1 "Results"
                 mconcat[i "word " >> b w >> i " appears " >> b n >> i " times" >> br
                        | (w,n) <- M.assocs r]
    
        empty
    
    fs= fromString
    size= atr (fs "size")
    -- a chat widget that run in the browser and in a cloud of servers
    
    
    chat = onBrowser $ do
        let chatbox= fs "chatbox" -- <- local  genNewId
        local . render . rawHtml $ do   -- Perch monads
                h1 "Federated chat server"
    
                div ! id chatbox
                    ! style (fs $"overflow: auto;height: 200px;"
                             ++  "background-color: #FFCC99; max-height: 200px;")
                    $ noHtml  -- create the chat box
    
        sendMessages   <|>  waitMessages chatbox
    
      where
    
      sendMessages   = do
    
          let msg = fs "messages" -- <-   local genNewId
          let entry= boxCell msg ! size  (fs "60")
          (nick,text) <- local . render $  (,) <$> getString (Just "anonymous") ! size (fs "10")
                                               <*> mk entry Nothing  `fire` OnChange
                                               <** inputSubmit "send"
                                               <++ br
          local $ entry .= ""
          guard (not $ null text)
    
          atRemote $ do
              node <- local getMyNode
              clustered $ local $ putMailbox  (showPrompt nick node ++ text )  >> empty :: Cloud ()
              empty
    
          where
          fs= fromString
    
          showPrompt u (Node h p _ _)= u ++ "@" ++ h ++ ":" ++ show p ++ "> "
    
      waitMessages chatbox = do
    
          resp <-  atRemote . local $ do
               labelState $ "getMailbox"
               r <-  single getMailbox
               return r
                                                               -- wait in the server for messages
    
          local . render . at (fs "#" <> chatbox) Append $ rawHtml $ do
                                              p (resp :: String)    -- display the response
    #ifdef ghcjs_HOST_OS
                                              liftIO $ scrollBottom $ fs "chatbox"
    
    
    foreign import javascript unsafe
      "var el= document.getElementById($1);el.scrollTop=  el.scrollHeight"
      scrollBottom  :: JS.JSString -> IO()
    #endif
    
    monitorNodes= onBrowser $ 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