Browse Source

added stack dependencies from transient.git

addedsingle
Alberto G. Corona 6 years ago
parent
commit
9f97f60791
  1. 1
      Dockerfile
  2. 8
      docker-compose.yml
  3. 9
      examples/distributedApps.hs
  4. 5
      examples/webMapReduce.hs
  5. 12
      examples/webapp.hs
  6. 50
      src/Transient/Move.hs
  7. 5
      stack.yaml
  8. 126
      tests/cell.hs

1
Dockerfile

@ -18,6 +18,7 @@ RUN echo "allow-different-user: true" > 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

8
docker-compose.yml

@ -1,7 +1,7 @@
web:
build: .
command: 'bash -c ''./webapp'''
working_dir: \app\user
command: 'bash -c ''./examples/webapp'''
working_dir: /app/user
environment:
PORT: 8080
ports:
@ -9,10 +9,10 @@ web:
shell:
build: .
command: bash
working_dir: \app\user
working_dir: /app/user
environment:
PORT: 8080
ports:
- '8080:8080'
volumes:
- '.:\app\user'
- '.:/app/user'

9
examples/distributedApps.hs

@ -3,7 +3,6 @@
module Main where
import Prelude hiding (div,id)
import Transient.Internals ((!>))
import Transient.Base
#ifdef ghcjs_HOST_OS
@ -20,15 +19,11 @@ import GHCJS.HPlay.View
import Transient.Move
import Transient.Indeterminism
import Transient.EVars
import Control.Applicative
import Control.Monad
import Data.Typeable
import qualified Data.Vector as V
import qualified Data.Map as M
import Transient.MapReduce
import Control.Monad.IO.Class
import System.IO
import Data.String
import qualified Data.Text as T
#ifdef ghcjs_HOST_OS
@ -52,7 +47,7 @@ mapReduce= onBrowser $ do
! atr "cols" (fs "80")
<++ br
<*** inputSubmit "send" `fire` OnClick
<** inputSubmit "send" `fire` OnClick
<++ br
r <- atRemote $ do
@ -85,7 +80,7 @@ chat= onBrowser $ do
sendMessages chatMessages = do
let entry= boxCell (fs "msg") ! atr "size" (fs "90")
text <- local . render $ (mk entry Nothing ) `fire` OnChange
<*** inputSubmit "send"
<** inputSubmit "send"
<++ br
local $ entry .= ""

5
examples/webMapReduce.hs

@ -44,16 +44,13 @@ main = simpleWebApp 8080 app
app= do
server <- onAll $ getSData
wormhole server $ do
content <- local . render $
textArea (fs "") ! atr "placeholder" (fs "enter the content")
! atr "rows" (fs "4")
! atr "cols" (fs "80")
`fire` OnChange
<++ br
<*** inputSubmit "send" -- `fire` OnClick
<** inputSubmit "send" -- `fire` OnClick
r <- atRemote $ do
lliftIO $ print content

12
examples/webapp.hs

@ -28,7 +28,7 @@ import Control.Monad.IO.Class
-- with three examples composed together, each one is a widget that execute
-- code in the browser AND the server.
main = simpleWebApp 2020 $ demo <|> demo2 <|> counters
main = simpleWebApp 8080 $ demo <|> demo2 <|> counters
@ -44,9 +44,9 @@ demo= do
local . render $ wlink () (p " stream fibonacci numbers")
-- stream fibonancci
-- stream fibonacci
r <- atServer $ do
r <- atRemote $ do
let fibs= 0 : 1 : zipWith (+) fibs (tail fibs) :: [Int] -- fibonacci numb. definition
r <- local . threads 1 . choose $ take 10 fibs
@ -70,7 +70,7 @@ demo2= do
inputString Nothing ! atr "placeholder" (fs "enter your name") `fire` OnKeyUp
<++ br -- new line
r <- atServer $ lliftIO $ print (name ++ " calling") >> return ("Hi " ++ name)
r <- atRemote $ lliftIO $ print (name ++ " calling") >> return ("Hi " ++ name)
local . render . rawHtml $ do
p " returned"
@ -86,7 +86,7 @@ fs= toJSString
counters= do
local . render . rawHtml $ do
hr
p "To demonstrate wormhole, teleport, widgets, interactive streaming"
p "To demonstrate the use of teleport, widgets, interactive streaming"
p "and composability in a web application."
br
p "This is one of the most complicated interactions: how to control a stream in the server"
@ -99,7 +99,7 @@ counters= do
counter server <|> counter server
where
counter server = wormhole server $ do
counter server = do
op <- startOrCancel
teleport -- translates the computation to the server
r <- local $ case op of

50
src/Transient/Move.hs

@ -36,7 +36,7 @@ addNodes, shuffleNodes,
-- * low level
getWebServerNode, Node(..), nodeList, Connection(..), Service(),
isBrowserInstance, IdLine(..), Repeat(..), Prefix(..), addPrefix
isBrowserInstance, Prefix(..), addPrefix
) where
@ -228,17 +228,15 @@ callTo :: Loggable a => Node -> Cloud a -> Cloud a
callTo node remoteProc=
wormhole node $ atRemote remoteProc
-- | withing an open connection to other node open by `wormhole`, it run the computation in the other node and return
-- | Within an open connection to other node opened by `wormhole`, it run the computation in the remote node and return
-- the result back to the original node.
atRemote proc= loggedc $ do
teleport -- !> "teleport 1111"
r <- local $ runCloud proc <*** setData WasRemote
teleport -- !> "teleport 2222"
r <- Cloud $ runCloud proc <** setData WasRemote
teleport -- !> "teleport 2222"
return r
-- | synonymous of `callTo`
-- all the previous actions from `listen` to this statement must have been logged
runAt :: Loggable a => Node -> Cloud a -> Cloud a
runAt= callTo
@ -286,7 +284,7 @@ wsRead :: Loggable a => WebSocket -> TransIO a
wsRead ws= do
dat <- react (hsonmessage ws) (return ())
case JM.getData dat of
JM.StringData str -> return (read' $ JS.unpack str) -- !> str !> "<------<----<----<------"
JM.StringData str -> return (read' $ JS.unpack str) -- !> ("webSocket read", str) !> "<------<----<----<------"
JM.BlobData blob -> error " blob"
JM.ArrayBufferData arrBuffer -> error "arrBuffer"
@ -395,9 +393,7 @@ read' s= case readsPrec' 0 s of
_ -> error $ "reading " ++ s
-- | A wormhole opens a connection with another node anywhere in a computation.
--wormhole :: Loggable a => Node -> Cloud a -> Cloud a
-- `teleport` uses this connection to translate the computation back and forth between the two nodes
wormhole :: Loggable a => Node -> Cloud a -> Cloud a
wormhole node (Cloud comp) = local $ Transient $ do
@ -407,7 +403,7 @@ wormhole node (Cloud comp) = local $ Transient $ do
logdata@(Log rec log fulLog) <- getData `onNothing` return (Log False [][])
mynode <- runTrans getMyNode -- debug
if not rec -- !> ("recovery", rec)
if not rec -- !> ("wormhole recovery", rec)
then runTrans $ (do
conn <- mconnect node -- !> (mynode,"connecting node ", node)
@ -416,10 +412,10 @@ wormhole node (Cloud comp) = local $ Transient $ do
addPrefix -- for the DOM identifiers
#endif
comp )
<** do when (isJust moldconn) . setData $ fromJust moldconn
when (isJust mclosure). setData $ fromJust mclosure
<*** do when (isJust moldconn) . setData $ fromJust moldconn
when (isJust mclosure). setData $ fromJust mclosure
-- <*** is not enough
-- <** is not enough
else do
let conn = fromMaybe (error "wormhole: no connection in remote node") moldconn
-- conn <- getData `onNothing` error "wormhole: no connection in remote node"
@ -427,7 +423,7 @@ wormhole node (Cloud comp) = local $ Transient $ do
setData $ conn{calling= False}
runTrans $ comp
<** do
<*** do
-- when (null log) $ setData WasRemote !> "NULLLOG"
when (isJust mclosure) . setData $ fromJust mclosure
@ -437,19 +433,18 @@ wormhole node (Cloud comp) = local $ Transient $ do
#ifndef ghcjs_HOST_OS
type JSString= String
pack= id
#endif
newtype Prefix= Prefix JSString deriving(Read,Show)
newtype IdLine= IdLine JSString deriving(Read,Show)
data Repeat= Repeat | RepH JSString deriving (Eq, Read, Show)
#endif
newtype Prefix= Prefix JSString deriving(Read,Show)
addPrefix= Transient $ do
r <- liftIO $ replicateM 5 (randomRIO ('a','z'))
setData $ Prefix $ pack r
return $ Just ()
-- | translates computations back and forth
-- reusing a connection opened by `wormhole`
teleport :: Cloud ()
@ -460,7 +455,7 @@ teleport = do
-- send log with closure at head
Log rec log fulLog <- getData `onNothing` return (Log False [][])
if not rec -- !> ("rec,loc fulLog=",rec,log,fulLog)
if not rec -- !> ("teleport rec,loc fulLog=",rec,log,fulLog)
-- if is not recovering in the remote node then it is active
then do
conn@Connection{closures= closures,calling= calling} <- getData
@ -479,8 +474,8 @@ teleport = do
let tosend= reverse $ if closRemote==0 then fulLog else log -- drop offset $ reverse fulLog !> ("fulLog", fulLog)
runTrans $ msend conn $ SMore (closRemote,closLocal, tosend )
-- !> ("teleport sending",(closRemote,closLocal,offset, tosend ))
-- !> "--------->------>---------->"
-- !> ("teleport sending", tosend )
-- !> "--------->------>---------->"
setData $ if (not calling) then WasRemote else WasParallel
@ -567,7 +562,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"
@ -841,7 +836,7 @@ getBuffSize=
readHandler h= do
line <- hGetLine h
return () -- !> line !> "------<---------------<----------<"
-- return () !> ("socket read",line) !> "------<---------------<----------<"
let [(v,left)] = readsPrec' 0 line
return v
`catch` (\(e::SomeException) -> return $ SError e)
@ -885,7 +880,6 @@ listenNew port conn= do -- node bufSize events blocked port= do
h <- liftIO $ NS.socketToHandle sock ReadWriteMode -- !!> "NEW SOCKET CONNECTION"
onFinish $ const $ do
liftIO $ print "removing closures new"
let Connection{closures=closures}= conn
liftIO $ modifyMVar_ closures $ const $ return M.empty
@ -909,7 +903,8 @@ listenNew port conn= do -- node bufSize events blocked port= do
parallel $ do
msg <- WS.receiveData sconn -- WebSockets
return . read $ BC.unpack msg -- !> msg !> "<-------<---------<--------------"
return . read $ BC.unpack msg
-- !> ("new msg",msg) !> "<-------<---------<--------------"
@ -938,7 +933,7 @@ listenResponses= do
nodes <- getNodes
setNodes $ nodes \\ [node]
liftIO $ print "removing closures responses"
let Connection{closures=closures}= conn
liftIO $ modifyMVar_ closures $ const $ return M.empty
@ -1165,7 +1160,6 @@ clustered proc= loggedc $ do
nodes <- local getNodes
let nodes' = filter (not . isWebNode) nodes
lliftIO $ print nodes'
foldr (<|>) empty $ map (\node -> runAt node proc) nodes' -- !> ("clustered",nodes')
where
isWebNode Node {nodeServices=srvs}

5
stack.yaml

@ -3,7 +3,10 @@ flags: {}
packages:
- '.'
- ../transient
- location:
git: https://github.com/agocorona/transient.git
commit: 517792fbcbece9577b6b3ad91895edfa92b18049
extra-deps: [transient-0.2]

126
tests/cell.hs

@ -0,0 +1,126 @@
{-# LANGUAGE OverloadedStrings #-}
import Transient.Base
import Transient.Move
import Transient.Internals((!>))
import GHCJS.HPlay.Cell
import qualified GHCJS.Perch as P (input)
import GHCJS.HPlay.View hiding (option, input)
import Control.Monad.IO.Class
import Data.String
import System.Random
import Data.List
import Data.IORef
import System.IO.Unsafe
import Control.Concurrent(threadDelay)
main= keep $ do
port <- getPort
initWebApp port $ onBrowser $ local $ render $ do
mk cellA (Just 1) <|> mk cellB (Just 2)
calc
where
cellA = scell "cella" $ runCloud $ do
lliftIO $ print "local"
atRemote $ do
lliftIO $ print "running cella at server"
return 2
cellB = scell "cellb" $ runCloud $ do
lliftIO $ print "local2"
atRemote $ do
lliftIO $ print "running cellb at server"
return 4
main2= keep $ do
port <- getPort
initWebApp port $ onBrowser $ do
local $ render $ rawHtml $ h1 ("laps" :: String)
lap <- atRemote laps <|> return 0
lap' <- local $ render $ inputInt (Just lap) `fire` OnKeyUp <|> return lap
carPositions lap'
where
carPositions l = do
pos <- atRemote $ carPosition l
local $ render $ rawHtml $ p pos
carPosition lap= local $ do
positions <- liftIO $ readIORef rposList !> ("carpositions", lap)
if lap >= length positions !> ("length", length positions)
then empty
else return $ positions !! lap
-- distance= mkscell "distance" (Just 0) (gcell "lap" * 15) ! size "5"
rposList= unsafePerformIO $ newIORef [] :: IORef [[String]]
laps= local $ do
r<- parallel $ do
threadDelay 10000000
newpos <- carPos
positions <- readIORef rposList !> newpos
writeIORef rposList $ positions ++ [newpos]
let l= length positions
return $ if l == totalLaps
then SLast $ fromIntegral l
else SMore $ fromIntegral l
case r of
SLast lap -> empty
SMore lap -> return lap
where
carPos= do
pos <- randomRIO (0,2)
let carpos= cars !! pos
return $ carpos : (cars \\ [carpos])
totalLaps= 42
cars =["car1", "car2", "car3"]
size= atr "size"
fs= fromString
-- rawHtml $ h1 $ ("calculate space, time and speed " :: String)
--
-- wprint ("Can change one of the cell and the other two will be recalculated"::String)
--
-- (pre <<< ("a car runs for" ++> space
-- **> " Kms during" ++> time **> " Hours;\n"
-- ++> "His mean speed was" ++> speed <++ "Km/h\n"))
--
-- **> (P.input ! atr "type" "submit" ! atr "value" "calc" `pass` OnClick)
--
-- liftIO $ alert "calc"
--
-- calc
--
-- where
-- space= mkscell "space" (Just 1) (gcell "speed" * gcell "time") ! size "5"
-- time = mkscell "time" (Just 1) (gcell "space" / gcell "speed") ! size "5"
-- speed= mkscell "speed" (Just 1) (gcell "space" / gcell "time") ! size "5"
getPort :: TransIO Integer
getPort =
if isBrowserInstance then return 0 else do
oneThread $ option "start" "re/start" :: TransIO String
port <- input (const True) "port to listen? "
liftIO $ putStrLn "node started"
return port
Loading…
Cancel
Save