Browse Source

- Some event handling code like browser events, relies on mfSequence, that

must be ser properly by runCont. Half done(only for browser events)
- Transient.Move.Services  for remote calling between transient apps that have
  completely different code is in progress.
addedsingle
Alberto G. Corona 6 years ago
parent
commit
7796b4c778
  1. 18
      Dockerfile
  2. 185
      examples/Atm.hs
  3. 7
      examples/distributedApps.hs
  4. 0
      outfile
  5. 71
      src/Transient/Move.hs
  6. 221
      src/Transient/Move/Services.hs
  7. 11
      src/Transient/Move/Utils.hs
  8. 54
      tests/Test.hs
  9. 16
      tests/test5.hs
  10. 59
      tests/testService.hs
  11. 1
      transient

18
Dockerfile

@ -1,4 +1,4 @@
FROM heroku/cedar
FROM ubuntu
RUN apt-key adv --keyserver hkp://keyserver.ubuntu.com:80 --recv-keys 575159689BEFB442 \
&& echo 'deb http://download.fpcomplete.com/debian jessie main'| tee /etc/apt/sources.list.d/fpco.list \
@ -7,19 +7,17 @@ RUN stack setup --allow-different-user --compiler ghc-7.10.3
RUN apt-get install nodejs -y \
&& ln -s /usr/bin/nodejs /usr/bin/node
USER root
RUN echo "allow-different-user: true" > stack.yaml \
&& echo "compiler: ghcjs-0.2.0.20160414_ghc-7.10.3" >> stack.yaml \
&& echo "resolver: lts-6.0 " >> stack.yaml \
RUN echo "compiler: ghcjs-0.2.0.820160417_ghc-7.10.3" >> stack.yaml \
&& echo "resolver: nightly-2016-04-17 " >> stack.yaml \
&& echo "compiler-check: match-exact" >> stack.yaml \
&& echo "setup-info:" >> stack.yaml \
&& echo " ghcjs:" >> stack.yaml \
&& echo " source:" >> stack.yaml \
&& echo " ghcjs-0.2.0.20160414_ghc-7.10.3:" >> stack.yaml \
&& echo " url: https://s3.amazonaws.com/ghcjs/ghcjs-0.2.0.20160414_ghc-7.10.3.tar.gz" >> stack.yaml \
&& echo " sha1: 6d6f307503be9e94e0c96ef1308c7cf224d06be3" >> stack.yaml \
&& cat stack.yaml \
&& chnow -R root /root/.stack/* \
&& stack setup --allow-different-user --compiler ghcjs-0.2.0.20160414_ghc-7.10.3
&& echo " ghcjs-0.2.0.820160417_ghc-7.10.3:" >> stack.yaml \
&& echo " url: \"https://tolysz.org/ghcjs/nightly-2016-04-17-820160417.tar.gz\"" >> stack.yaml \
&& cat stack.yaml
RUN chown -R root /root
RUN stack setup --allow-different-user

185
examples/Atm.hs

@ -0,0 +1,185 @@
{-# LANGUAGE CPP #-}
module Main where
import Prelude hiding (div)
import Transient.Base
#ifdef ghcjs_HOST_OS
hiding ( option,runCloud')
#endif
import GHCJS.HPlay.View
#ifdef ghcjs_HOST_OS
hiding (map)
#else
hiding (map, option,runCloud')
#endif
import Transient.Move
import Transient.Move.Utils
import Control.Applicative
import Control.Monad
import Data.Typeable
import Data.IORef
import Control.Concurrent (threadDelay)
import Control.Monad.IO.Class
import Control.Concurrent.MVar
import System.Random
import System.IO.Unsafe
data Operation= Operation String
-- Follows http://www.math-cs.gordon.edu/courses/cs211/ATMExample/
-- to demostrate how it is possible to program at the user requiremente level
-- the program follows closely the specifications and be clear enough to be understood
-- by the client
main= keep $ initNode atm
atm= do
card <- waitCard
pin <- enterPIN
validateBank pin card
setData card
performTransactions <|> cancel
returnCard
performTransactions = do
clearScreen
operation <- withdrawal <|> deposit <|> transfer <|> balanceInquiry
printReceipt operation
return ()
withdrawal= do
local . render $ wlink () $ toElem "withdrawall"
local . render $ wprint "choose bank account"
account <- chooseAccount
wprint "Enter the quantity"
quantity <- getInt Nothing
if quantity `rem` 20 /= 0
then do
wprint "multiples of $20.00 please"
stop
else do
r <- approbalBank account quantity
case r of
False -> do
wprint "operation denied. sorry"
wprint "Another transaction?"
r <- wlink True (b "yes ") <|> wlink False << (b "No")
if not r then return ()
else performTransactions
True -> giveMoney r
deposit= do
wlink () $ b "Deposit "
wprint "choose bank account"
account <- chooseAccount
r <- approbalBankDeposit account
case r of
False -> do wprint "operation denied. sorry"
stop
True -> do
r <- waitDeposit <|> timeout
case r of
False -> do wprint "timeout, sorry"; stop
True -> return ()
transfer= do
wlink () $ b "Transfer "
wprint "From"
ac <- chooseAccount
wprint "amount"
amount <- inputDouble Nothing
wprint "To"
ac' <- chooseAccount
transferAccBank ac ac' amount
return()
balanceInquiry= do
wprint "From"
ac <- chooseAccount
r <- getBalanceBank ac
wprint $ "balance= "++ show r
validateBank pin card = atRemote $ validate' pin card (0 :: Int)
where
validate' pin card times= local $ do
r <- verifyPinBank pin card
if r then return () else do
if times ==2
then do
wprint ("three tries. card will be retained" :: String)
stop
else validate' pin card $ times + 1
rtotal= unsafePerformIO $ newEmptyMVar
ractive= unsafePerformIO $ newMVar False
switchOnOff= on <|> off
where
on= do
wbutton () "On"
wprint "enter total amount of money"
total <- getInt Nothing
liftIO $ do
tryTakeMVar rtotal
putMVar rtotal total
off= do
wbutton () "Off"
active <- liftIO $ readMVar ractive
if active then stop else wprint "ATM stopped"
type AccountNumber= String
newtype Card= Card [AccountNumber] deriving Typeable
waitCard = local $ render $ wbutton Card "enter card"
enterPIN= local $ do
wprint "Enter PIN"
render $ getInt Nothing `fire` OnChange
cancel= wbutton () "Cancel"
returnCard= wprint "Card returned"
clearScreen= wraw $ forElems "body" $ this >> clear
printReceipt= do
Operation str <- getSData <|> error "no operation"
wprint $ "receipt: Operation:"++ str
chooseAccount= do
Card accounts <- getSData <|> error "transfer: no card"
wprint "choose an account"
mconcat[wlink ac (fromStr $ ' ':show ac) | ac <- accounts]
approbalBank ac quantity= return True
giveMoney n= wprint $ "Your money : " ++ show n ++ " Thanks"
approbalBankDeposit ac= return True
transferAccBank ac ac' amount= wprint $ "transfer from "++show ac ++ " to "++show ac ++ " done"
getBalanceBank ac= liftIO $ do
r <- rand
return $ r * 1000
verifyPinBank _ _= liftIO $ do
liftIO $ print "verifyPinBank"
r <- rand
if r > 0.2 then return True else return False
waitDeposit = do
n <- liftIO rand
if n > 0.5 then return True else return False
rand:: IO Double
rand= randomRIO
timeout t= threadDelay $ t * 1000000

7
examples/distributedApps.hs

@ -1,4 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE CPP,NoMonomorphismRestriction #-}
module Main where
@ -47,8 +47,9 @@ mapReduce= onBrowser $ do
! atr "rows" (fs "4")
! atr "cols" (fs "80")
<++ br
<** inputSubmit "send" `fire` OnClick
<** inputSubmit "send" `fire` OnClick
<++ br
r <- atRemote $ do
@ -70,7 +71,7 @@ fs= fromString
chat= onBrowser $ do
let chatMessages= T.pack "chatMessages"
let chatMessages= fs "chatMessages"
local . render . rawHtml $ div ! id (fs "chatbox")
! style (fs "margin-top:1cm;overflow: auto;height: 200px;background-color: #FFCC99; max-height: 200px;")

0
outfile

71
src/Transient/Move.hs

@ -37,11 +37,12 @@ addNodes, shuffleNodes,
getWebServerNode, Node(..), nodeList, Connection(..), Service(),
isBrowserInstance, Prefix(..), addPrefix
,defConnection
) where
import Transient.Base
import Transient.Internals((!>),killChildren,getCont,runCont,EventF(..),LogElem(..),Log(..)
import Transient.Internals(killChildren,getCont,runCont,EventF(..),LogElem(..),Log(..)
,onNothing,RemoteStatus(..),getCont,StateIO,readsPrec')
import Transient.Logged
import Transient.EVars
@ -121,7 +122,7 @@ newtype PortID = PortNumber Int deriving (Read, Show, Eq, Typeable)
data Node= Node{ nodeHost :: HostName
, nodePort :: Int
, connection :: MVar Pool
, nodeServices :: MVar [Service]
, nodeServices :: [Service]
}
deriving (Typeable)
@ -277,6 +278,8 @@ msend (Connection _ (Just (Web2Node sconn)) _ _ blocked _ _) r= liftIO $
msend (Connection _ Nothing _ _ _ _ _ ) _= error "msend out of wormhole context"
mread :: Loggable a => Connection -> TransIO (StreamData a)
#ifdef ghcjs_HOST_OS
@ -350,10 +353,15 @@ foreign import javascript safe
"$1.onmessage =$2;"
js_onmessage :: WebSocket -> JSVal -> IO ()
getWebServerNode _=
createNode <$> ( fromJSValUnchecked js_hostname)
getWebServerNode :: TransIO Node
getWebServerNode = liftIO $
createNode <$> ( fromJSValUnchecked js_hostname)
<*> (fromIntegral <$> (fromJSValUnchecked js_port :: IO Int))
<*> (return [])
hsonmessage ::WebSocket -> (MessageEvent ->IO()) -> IO ()
hsonmessage ws hscb= do
@ -388,11 +396,12 @@ mread (Connection _(Just (Node2Node _ _)) _ _ blocked _ _ ) = parallelReadHandl
mread (Connection node (Just (Node2Web sconn )) bufSize events blocked _ _)=
parallel $ do
s <- WS.receiveData sconn
return . read' $ BS.unpack s -- !> ("WS MREAD RECEIVED ---->", s)
return . read' $ BS.unpack s
-- !> ("WS MREAD RECEIVED ---->", s)
-- `catch`(\(e ::SomeException) -> return $ SError e)
getWebServerNode port= return $ createNode "localhost" port
getWebServerNode = getMyNode
#endif
read' s= case readsPrec' 0 s of
@ -554,7 +563,7 @@ mconnect node@(Node _ _ _ _ )= do
return handle -- !> "REUSED!"
_ -> do
liftIO $ putStr "*****CONNECTING NODE: " >> print node
-- liftIO $ putStr "*****CONNECTING NODE: " >> print node
my <- getMyNode
-- liftIO $ putStr "OPENING CONNECTION WITH :" >> print port
Connection{comEvent= ev} <- getSData <|> error "connect: listen not set for this node"
@ -660,15 +669,15 @@ newMailbox name= do
return () -- !> "newMailBox"
Connection{comEvent= mv} <- getData `onNothing` errorMailBox
onFinish . const $ liftIO $ do
return () !> "NEWMAILBOX finish"
return () -- !> "NEWMAILBOX finish"
mailboxes <- readIORef mv
let me = M.lookup name mailboxes
case me of
Nothing -> empty !> "EMPTY"
Nothing -> empty -- !> "EMPTY"
Just (EVar id rn ref1) -> do
n <- atomically $ do
(n,n') <- readTVar rn
writeTVar rn (n-1,n'-1) !> ("decreased rn",n-1)
writeTVar rn (n-1,n'-1) -- !> ("decreased rn",n-1)
return $ n-1
when (n==0) $ atomicModifyIORef mv $ \mboxes -> (M.delete name mboxes,())
ev <- newEVar
@ -763,7 +772,7 @@ defConnection :: Int -> Connection
-- #ifndef ghcjs_HOST_OS
defConnection size=
Connection (createNode "program" 0) Nothing size
Connection (createNode "program" 0 []) Nothing size
(error "defConnection: accessing network events out of listen")
(unsafePerformIO $ newMVar ())
False (unsafePerformIO $ newMVar M.empty)
@ -828,7 +837,7 @@ listenNew port conn= do -- node bufSize events blocked port= do
initFinish
onFinish $ const $ do
return() !> "onFinish closures receivedd with LISTEN"
return() -- !> "onFinish closures receivedd with LISTEN"
let Connection{closures=closures}= conn -- !> "listenNew closures empty"
liftIO $ modifyMVar_ closures $ const $ return M.empty
@ -950,7 +959,7 @@ listen node = onAll $ do
type Pool= [Connection]
type Package= String
type Program= String
type Service= (Package, Program, Int)
type Service= (Package, Program)
-- * Level 2: connections node lists and operations with the node list
@ -960,13 +969,13 @@ type Service= (Package, Program, Int)
emptyPool :: MonadIO m => m (MVar Pool)
emptyPool= liftIO $ newMVar []
createNode :: HostName -> Integer -> Node
createNode h p= Node h ( fromInteger p) (unsafePerformIO emptyPool)
( unsafePerformIO $ newMVar [])
createNode :: HostName -> Integer -> [Service] -> Node
createNode h p svs= Node h ( fromInteger p) (unsafePerformIO emptyPool) svs
createWebNode :: Node
createWebNode= Node "webnode" ( fromInteger 0) (unsafePerformIO emptyPool)
( unsafePerformIO $ newMVar [("webnode","",0)])
[("webnode","")]
instance Eq Node where
@ -974,7 +983,7 @@ instance Eq Node where
instance Show Node where
show (Node h p _ servs )= show (h,p,unsafePerformIO $ readMVar servs)
show (Node h p _ servs )= show (h,p, servs)
instance Read Node where
@ -984,7 +993,7 @@ instance Read Node where
in case r of
[] -> []
[((h,p,ss),s')] -> [(Node h p empty
(unsafePerformIO $ newMVar ss),s')]
( ss),s')]
where
empty= unsafePerformIO emptyPool
@ -1109,30 +1118,23 @@ shuffleNodes= liftIO . atomically $ do
-- > where
-- > createLocalNode n= createNode "localhost" (PortNumber n)
clustered :: Loggable a => Cloud a -> Cloud a
clustered proc= loggedc $ do
nodes <- local getNodes
let nodes' = filter (not . isWebNode) nodes
foldr (<|>) empty $ map (\node -> runAt node proc) nodes' -- !> ("clustered",nodes')
where
isWebNode Node {nodeServices=srvs}
| ("webnode","",0) `elem` (unsafePerformIO $ readMVar srvs)= True
| otherwise = False
clustered proc= callNodes (<|>) empty proc
-- A variant of `clustered` that wait for all the responses and `mappend` them
mclustered :: (Monoid a, Loggable a) => Cloud a -> Cloud a
mclustered proc= loggedc $ do
mclustered proc= callNodes (<>) mempty proc
callNodes op init proc= loggedc $ do
nodes <- local getNodes
let nodes' = filter (not . isWebNode) nodes
foldr (<>) mempty $ map (\node -> runAt node proc) nodes' -- !> ("mclustered",nodes')
foldr op init $ map (\node -> runAt node proc) nodes' -- !> ("mclustered",nodes')
where
isWebNode Node {nodeServices=srvs}
| ("webnode","",0) `elem` (unsafePerformIO $ readMVar srvs)= True
| ("webnode","") `elem` srvs = True
| otherwise = False
-- | set the rest of the computation as a new node (first parameter) and connect it
-- to an existing node (second parameter). then it uses `connect`` to synchronize the list of nodes
connect :: Node -> Node -> Cloud ()
@ -1211,7 +1213,8 @@ httpMode (method,uri, headers) conn = do
file= if BC.null uri' then "index.html" else uri'
content <- liftIO $ BL.readFile ( "./static/out.jsexe/"++ BC.unpack file)
`catch` (\(e:: SomeException) -> return "Not found file: Index.html")
`catch` (\(e:: SomeException) ->
return "Not found file: Index.html<br/> please compile with ghcjs<br/> ghcjs program.hs -o static/out")
n <- liftIO $ SBS.sendMany conn $ ["HTTP/1.0 200 OK\nContent-Type: text/html\nConnection: close\nContent-Length: " <> BC.pack (show $ BL.length content) <>"\n\n"] ++
(BL.toChunks content )

221
src/Transient/Move/Services.hs

@ -11,20 +11,23 @@
-- |
--
-----------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
module Transient.Move.Services where
import Transient.Base
import Transient.Move
import Transient.Logged
import Transient.Logged(Loggable(..))
--import Transient.Internals((!>))
import Transient.Move.Utils
import Transient.Internals(Log(..))
import Transient.EVars
import Transient.Indeterminism
import Control.Monad.IO.Class
import System.Process
import System.IO.Unsafe
import Control.Concurrent.MVar
import Control.Applicative
import Network (PortID(..))
import GHC.Conc
import System.Directory
import Control.Monad
import Data.List
@ -34,61 +37,47 @@ import Data.Maybe
-- for the example
import System.Environment
startServices :: Cloud ()
startServices= local $ do
node <- getMyNode
liftIO $ print node
servs <- liftIO $ readMVar $ nodeServices node
mapM_ start servs
where
start (package,program,port)= liftIO $ do
let prog= pathExe (name package) program port
liftIO $ print prog
createProcess $ shell prog
--startServices :: Cloud ()
--startServices= local $ do
-- node <- getMyNode
-- liftIO $ print node
-- let servs = nodeServices node
-- mapM_ start servs
-- where
-- start (package,program)= liftIO $ do
-- let prog= pathExe (name package) program port
-- liftIO $ print prog
-- createProcess $ shell prog
pathExe package program port= package++"/dist/build/"++package++"/"++program
++ " " ++ show port
++ " -p start/" ++ show port
install :: String -> String -> Int -> Cloud ()
install package program port = do
let packagename = name package
exist <- local $ liftIO $ doesDirectoryExist packagename
when (null packagename) $ error $ "source for \""++package ++ "\" not found"
exist <- local $ liftIO $ doesDirectoryExist packagename
when (not exist) $ local $ liftIO $ do
callProcess "git" ["clone",package]
liftIO $ print "GIT DONE"
setCurrentDirectory packagename
callProcess "cabal" ["install"]
callProcess "cabal" ["install","--force-reinstalls"]
setCurrentDirectory ".."
return()
let prog= pathExe packagename program port
let prog = pathExe packagename program port
lliftIO $ print prog
local $ liftIO $ do
createProcess $ shell program
return ()
let service= (package, program, port)
Connection{myNode=Node{nodeServices=rservs}} <- onAll getSData <|> error "Mynode not set: use setMyNode"
lliftIO $ modifyMVar_ rservs $ \servs -> return$ service:servs
node <- onAll getMyNode
notifyService node service
return()
name url= do
let git= "http://github.com/"
if not $ isPrefixOf git url
then error "install: only github repos are admitted, sorry"
else
let segments = split '/' $ drop (length git) url
segs'= reverse segments
in head segs'
where
split c []= []
split c xs=
let (h,t)= span (/= c) xs
in if null t then [h] else h : split c (tail t)
name url= slash . slash . slash $ slash url
where
slash= tail1 . dropWhile (/='/')
tail1 []=[]
tail1 x= tail x
rfreePort :: MVar Int
rfreePort = unsafePerformIO $ newMVar 3000
@ -96,55 +85,117 @@ rfreePort = unsafePerformIO $ newMVar 3000
freePort :: MonadIO m => m Int
freePort= liftIO $ modifyMVar rfreePort $ \ n -> return (n+1,n)
initService node package program= loggedc $ do
services <- onAll $ liftIO $ readMVar $ nodeServices node
case find (\(package', program',_) -> package==package' && program== program') $ services of
Just (_,_,port) -> return port
initService ident service@(package, program)= loggedc $ do
nodes <- local getNodes
case find (\node -> service `elem` nodeServices node) nodes of
Just node -> return node
Nothing -> do
beamTo node
port <- onAll freePort
install package program port
empty
<|> do
Connection{comEvent=ev} <- onAll getSData
(node', (package', program',port)) <- local $ getMailbox "services"
if node'== node && package' == package && program'== program
then return port
else empty
notifyService :: Node -> Service -> Cloud ()
notifyService node service= clustered $ do
onAll . liftIO $ do
nodes <- atomically $ readTVar nodeList
let nod = fromMaybe (error $ "node not found :" ++ show node) $ find (== node) nodes :: Node
modifyMVar_ (nodeServices nod) $ \servs -> return $ service:servs
return ()
local $ putMailbox "services" (node,service)
return ()
{-
main= do
-- keep $ install "http://github.com/agocorona/transient" "MainStreamFiles" 3000
let node1= createNode "localhost" 2000
let node2= createNode "localhost" 2001
args <-getArgs
let [localNode,remoteNode]= if null args then [node1,node2] else [node2,node1]
runCloudIO $ do
onAll $ addNodes [localNode, remoteNode]
onAll $ setMyNode localNode
listen localNode <|> return ()
local $ option "start" "start"
startServices
port <-initService remoteNode "http://github.com/agocorona/transient" "MainStreamFiles"
onAll . liftIO $ putStrLn $ "installed at" ++ show port
-}
nodes <- callOne $ do
yn<- requestService ident service
if yn then do
port <- onAll freePort
install package program port
nodeService port
else empty
local $ addNodes nodes
return $ head nodes
where
nodeService port= local $ do
Node h _ _ _ <- getMyNode
return $ Node h port (unsafePerformIO $ newMVar []) [service] :: TransIO Node
callOne mx= local . collect 1 . runCloud $ clustered mx
rfriends = unsafePerformIO $ newMVar []
rservices = unsafePerformIO $ newMVar []
ridentsBanned = unsafePerformIO $ newMVar []
rServicesBanned = unsafePerformIO $ newMVar []
requestService ident service= local $ do
friends <- liftIO $ readMVar rfriends
services <- liftIO $ readMVar rservices
identsBanned <- liftIO $ readMVar ridentsBanned
servicesBanned <- liftIO $ readMVar rServicesBanned
return $ if (null friends || ident `elem` friends)
&& (null services || service `elem` services)
&& (null identsBanned || ident `notElem` identsBanned)
&& (null servicesBanned || service `notElem` servicesBanned)
then True else False
where
notElem a b= not $ elem a b
callService
:: (Loggable a, Loggable witness)
=> String -> Service -> a -> witness -> Cloud witness
callService ident service params witness= do
node <- initService ident service
log <- onAll $ do
log <- getSData <|> return emptyLog
setData emptyLog
return log
r <- wormhole node $ loggedc $ do
local $ return params
teleport
local empty
-- return () !> ("r=",r)
restoreLog log
-- local $ do
-- Log _ _ log <- getSData <|> return emptyLog
-- return() !> ("log after",log)
return (r `asTypeOf` witness)
where
restoreLog (Log _ _ logw)= onAll $ do
Log _ _ logw' <- getSData <|> return emptyLog
let newlog= reverse logw' ++ logw
-- return () !> ("newlog", logw,logw')
setData $ Log False newlog newlog
emptyLog= Log False [] []
{-
servicios
autoinstall service
servicio de instalaci¢n de servicios
procedurers call services, services install themselves in nodes.
clustered oriented call invoke the nodes that shares the same service.
if the service variable state is set. if not, invoke all the nodes.
some service accessing data may move to the machine where the data is if support the service.
servicio en browser necesita algo que en el server no existe y no pude dar:
forward the request to other nodes
return the result to the browser.
forward service requests:
cuando un nodo no puede servir un servicio, puede hacer forward.
otros nodos puede instalarlo o hacer forward a su vez
clusterizaci¢n de servicios
nodo con database saturado puede hacer automatic sharding
siquientes requests retornan los nuevos nodos
la resupuesta de un servicio puede incluir una nueva direcci¢n, del nodo donde se ha movido o donde ha delegado.
servicio wrarpper que ejecuta una libreria no transient
cat logo de servicios
ghcjsi service for notebooks
web site de compilaci¢n que compile en su propio ordenador
opcion descargar el programa de instalacion y hace stack build
ventaja: conectar todos los nodos que ejecutan un servicio determinado
necesario un deposito de nombres de servicios:: github
friend ident.... request you to install... in your computer. Do you agree?
if ident is the same, this is automatic.
-}

11
src/Transient/Move/Utils.hs

@ -12,7 +12,8 @@
--
-----------------------------------------------------------------------------
module Transient.Move.Utils (initNode,inputNodes, simpleWebApp, initWebApp, onServer, onBrowser, runNodes)
module Transient.Move.Utils (initNode,inputNodes, simpleWebApp, initWebApp
, onServer, onBrowser, runNodes)
where
import Transient.Base
@ -73,7 +74,7 @@ inputNodes= do
port <- local $ input (const True) "port?"
connectit <- local $ input (\x -> x=="y" || x== "n") "connect to get his list of nodes?"
let nnode= createNode host port
let nnode= createNode host port []
if connectit== "y" then connect' nnode
else local $ addNodes [nnode]
empty
@ -103,7 +104,9 @@ simpleWebApp port app = keep $ initWebApp port app
-- initialization of the web server. Otherwise, the behaviour is the same.
initWebApp :: Integer -> Cloud () -> TransIO ()
initWebApp port app= do
serverNode <- liftIO $ getWebServerNode port
let conn= defConnection 8192
setData $ conn{myNode= createNode "localhost" port []}
serverNode <- getWebServerNode :: TransIO Node
let mynode = if isBrowserInstance
then createWebNode
@ -130,7 +133,7 @@ onServer x= do
-- | run N nodes (N ports to listen) in the same program. For testing purposes.
-- It add them to the list of known nodes, so it is possible to perform `clustered` operations with them.
runNodes ports= do
let nodes= map (createNode "localhost") ports
let nodes= map (\p -> createNode "localhost" p []) ports
onAll $ addNodes nodes
foldl (<|>) empty (map listen nodes) <|> return()

54
tests/Test.hs

@ -1,20 +1,10 @@
{-# LANGUAGE CPP #-}
module Main where
import Prelude hiding (div)
import Transient.Base
#ifdef ghcjs_HOST_OS
hiding ( option,runCloud')
#endif
import GHCJS.HPlay.View
#ifdef ghcjs_HOST_OS
hiding (map)
#else
hiding (map, option,runCloud')
#endif
import Transient.Move hiding(teleport)
import Transient.Move
import Transient.Move.Utils
import Transient.Move.Services
import Control.Applicative
import Control.Monad
import Data.Typeable
@ -22,44 +12,14 @@ import Data.IORef
import Control.Concurrent (threadDelay)
import Control.Monad.IO.Class
main = do
let serverAddr= "localhost"
serverPort = 2020
serverNode = createNode serverAddr serverPort
mynode = if isBrowserInstance
then createWebNode
else serverNode
runCloud' $ do
listen mynode
local $
render $ do
rawHtml $ p "hello"
render $ rawHtml $ p "world"
counters server= wormhole server $ counter <|> counter
counter = do
op <- local $ render $ (inputSubmit "start" `fire` OnClick)
<|> (inputSubmit "cancel" `fire` OnClick) <++ br
teleport -- translates the computation to the server
r <- local $ case op of
"start" -> stream
"cancel" -> killChilds >> empty
main= do
teleport -- back to the browser again
initNode $ do
local $ option "start" "start"
client ("hello","world")
local $ render $ rawHtml $ h1 r
-- generates a sequence of numbers
stream= do
counter <- liftIO $ newIORef (0 :: Int)
waitEvents $ do
n <- atomicModifyIORef counter $ \r -> (r +1,r)
threadDelay 1000000
putStr "generating: " >> print n
return n

16
tests/test5.hs

@ -2,6 +2,7 @@ module Main where
import Transient.Move
import Transient.Move.Utils
import GHCJS.HPlay.View
import Transient.Logged
import Transient.Base
import Transient.Indeterminism
@ -27,15 +28,16 @@ import Data.List((\\))
-- to be executed with two or more nodes
main = keep $ initNode $ inputNodes <|> test
main = keep $ initNode $ test
test= do
local $ option "exec" "exec"
nodes <- local getNodes
when (length nodes >1)$ do
runAt (nodes !! 1) $ lliftIO $ print "hello"
lliftIO $ print "world"
test= onBrowser $ do
local . render $ wlink () $ p "Product Categories"
r <- local . render $
(,) <$> inputString Nothing `fire` OnChange
<*> inputInt Nothing `fire` OnChange
lliftIO $ print r

59
tests/testService.hs

@ -0,0 +1,59 @@
{-# LANGUAGE CPP #-}
import Transient.Base
import Transient.Move
import Transient.Move.Utils
import Transient.Move.Services
import Control.Applicative
import Control.Monad
import Data.Typeable
import Data.IORef
import Control.Concurrent (threadDelay)
import Control.Monad.IO.Class
#ifndef Service
client params= do
r <- callService "" ("service","service") params ""
lliftIO $ print r
#else
main= keep $ do
initNode' [("service","service")] $ do
makeService service
addService s= do
nodes <- getNodes
con@Connection{myNode= mynode} <- getSData <|> error "connection not set. please initialize it"
mynode <- getMyNode
mynode'= mynode{services= services mynode++ s}
setNodes $ mynode': nodes\\[mynode]
setData con{myNode= mynode'}
makeService :: (a -> b) -> a -> TransIO ()
makeService serv params= wormhole notused $ loggedc $ do
(x,y) <- local $ return params
serv (x,y)
teleport
where
notused= error "makeService: node should not be used"
service :: (String,String) -> String
service (x,y)= do
lliftIO $ print x
return y
service' params= wormhole undefined $ loggedc $ do
(x,y) <- local $ return params
lliftIO $ print x
local $ return y
teleport
empty
#endif

1
transient

@ -0,0 +1 @@
Subproject commit 73305893636b7bbc201a37c2ff0dee30a2966bef
Loading…
Cancel
Save