Browse Source

version change, services improved

addedsingle
Alberto G. Corona 5 years ago
parent
commit
53bff2f5bb
  1. 4
      DockerHaskell
  2. 27
      Dockerfile
  3. 2
      examples/distributedApps.hs
  4. 6
      examples/webapp.hs
  5. 33
      src/Transient/Move.hs
  6. 25
      src/Transient/Move/Services.hs
  7. 3
      tests/Test.hs
  8. 131
      tests/Test2.hs
  9. 9
      tests/test5.hs
  10. 37
      tests/testService.hs

4
DockerHaskell

@ -1 +1,3 @@
from haskell
FROM haskell
RUN cabal install http://ghcjs.luite.com/ghc-8.0.tar.gz
RUN ghcjs-boot

27
Dockerfile

@ -1,23 +1,4 @@
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 \
&& apt-get update && apt-get install stack -y
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 "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.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
FROM haskell
RUN cabal update
RUN cabal install http://ghcjs.luite.com/ghc-8.0.tar.gz
RUN ghcjs-boot

2
examples/distributedApps.hs

@ -20,7 +20,7 @@ import GHCJS.HPlay.View
import Transient.Move
import Transient.EVars
import Transient.Indeterminism
import Transient.Internals((!>))
import Control.Applicative
import qualified Data.Vector as V
import qualified Data.Map as M

6
examples/webapp.hs

@ -37,8 +37,10 @@ demo= do
rawHtml $ do
hr
p "this snippet captures the essence of this demonstration"
p $ span "it's a blend of server and browser code in a "
>> (span $ b "composable") >> span " piece"
p $ do
span "it's a blend of server and browser code in a "
span $ b "composable"
span " piece"
div ! id (fs "fibs") $ i "Fibonacci numbers should appear here"

33
src/Transient/Move.hs

@ -15,7 +15,7 @@
,GeneralizedNewtypeDeriving #-}
module Transient.Move(
Cloud(..),runCloudIO, runCloudIO',local,onAll,lazy, loggedc, lliftIO,
Cloud(..),runCloudIO, runCloudIO',local,onAll,lazy, loggedc, lliftIO,localIO,
listen, Transient.Move.connect, connect', fullStop,
wormhole, teleport, copyData,
@ -194,11 +194,17 @@ lazy mx= onAll $ getCont >>= \st -> Transient $
-- log the result a cloud computation. like `loogged`, This eliminated all the log produced by computations
-- inside and substitute it for that single result when the computation is completed.
loggedc :: Loggable a => Cloud a -> Cloud a
loggedc (Cloud mx)= Cloud $ logged mx
-- | the `Cloud` monad has no `MonadIO` instance. `lliftIO= local . liftIO`
lliftIO :: Loggable a => IO a -> Cloud a
lliftIO= local . liftIO
-- | locally perform IO. `localIO = lliftIO`
localIO :: Loggable a => IO a -> Cloud a
localIO= lliftIO
--remote :: Loggable a => TransIO a -> Cloud a
--remote x= Cloud $ step' x $ \full x -> Transient $ do
-- let add= Wormhole: full
@ -772,7 +778,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)
@ -789,12 +795,6 @@ setBuffSize size= Transient $ do
getBuffSize=
(do getSData >>= return . bufferSize) <|> return 8192
--readHandler h= do
-- line <- hGetLine h
---- return () !> ("socket read",line) !> "------<---------------<----------<"
-- let [(v,left)] = readsPrec' 0 line
-- return v
---- `catch` (\(e::SomeException) -> return $ SError e)
@ -1058,28 +1058,13 @@ getNodes = liftIO $ atomically $ readTVar nodeList
-- | add nodes to the list of nodes
addNodes :: (MonadIO m, MonadState EventF m) => [Node] -> m ()
addNodes nodes= do
-- #ifndef ghcjs_HOST_OS
-- mapM_ verifyNode nodes -- if the node is a web one, add his connection
-- #endif
liftIO . atomically $ do
prevnodes <- readTVar nodeList
writeTVar nodeList $ nub $ prevnodes ++ nodes
writeTVar nodeList $ nub $ nodes ++ prevnodes
-- | set the list of nodes
setNodes nodes= liftIO $ atomically $ writeTVar nodeList $ nodes
-- #ifndef ghcjs_HOST_OS
--verifyNode (WebNode pool)= do
-- r <- getData `onNothing` error "adding web node without connection set"
-- case r of
-- conn@(Connection{connData= Just( Node2Web ws)}) ->
-- liftIO $ writeIORef pool [conn]
-- other -> return ()
--
--verifyNode n= return ()
-- #endif
shuffleNodes :: MonadIO m => m [Node]
shuffleNodes= liftIO . atomically $ do

25
src/Transient/Move/Services.hs

@ -17,7 +17,7 @@ module Transient.Move.Services where
import Transient.Base
import Transient.Move
import Transient.Logged(Loggable(..))
--import Transient.Internals((!>))
import Transient.Internals(RemoteStatus(..))
import Transient.Move.Utils
import Transient.Internals(Log(..))
import Transient.EVars
@ -131,9 +131,9 @@ requestService ident service= local $ do
callService
:: (Loggable a, Loggable witness)
=> String -> Service -> a -> witness -> Cloud witness
callService ident service params witness= do
:: (Loggable a, Loggable b)
=> String -> Service -> a -> Cloud b
callService ident service params = do
node <- initService ident service
log <- onAll $ do
log <- getSData <|> return emptyLog
@ -150,7 +150,7 @@ callService ident service params witness= do
-- local $ do
-- Log _ _ log <- getSData <|> return emptyLog
-- return() !> ("log after",log)
return (r `asTypeOf` witness)
return r -- (r `asTypeOf` witness)
where
restoreLog (Log _ _ logw)= onAll $ do
Log _ _ logw' <- getSData <|> return emptyLog
@ -162,6 +162,21 @@ callService ident service params witness= do
emptyLog= Log False [] []
runEmbeddedService :: (Loggable a, Loggable b) => Service -> (a -> Cloud b) -> Cloud b
runEmbeddedService servname serv = do
port <- lliftIO $ freePort
listen $ createNode "localhost" (fromIntegral port) [servname]
wormhole notused $ loggedc $ do
x <- local $ return notused
r <- onAll $ runCloud (serv x) <** setData WasRemote
local $ return r
teleport
return r
where
notused= error "runService: variable should not be used"
{-
servicios
autoinstall service

3
tests/Test.hs

@ -19,6 +19,9 @@ main= do
local $ option "start" "start"
client ("hello","world")
client params= do
r <- callService "" ("service","service") params ""
lliftIO $ print r

131
tests/Test2.hs

@ -1,72 +1,63 @@
module Main where
import Control.Monad
import Control.Monad.IO.Class
import Data.IORef
import GHC.Conc
import Control.Applicative
import Data.Monoid
import Transient.Base
import Transient.Indeterminism
import Transient.Logged
import Transient.Move
import Transient.Stream.Resource
import Transient.DDS
import Control.Concurrent
import System.IO.Unsafe
import Data.List
import Control.Exception.Base
import Control.Monad.State
import Unsafe.Coerce
import qualified Data.Map as M
main= do
let numNodes = 2
ports = [2000 .. 2000 + numNodes - 1]
createLocalNode = createNode "localhost"
nodes = map createLocalNode ports
node1= head nodes
node2= nodes !! 1
runCloud' $ do
-- local $ addNodes nodes
-- runNodes nodes
local $ (sync $ async( threadDelay 1000000 >> print "hello") >> stop ) <|> (liftIO $print "world")
-- (liftIO (print "world") >>stop) <|> (liftIO $ print "hello")
-- print r
sync :: TransIO a -> TransIO a
sync x= Transient $ do
EventF _ _ x' fs _ _ _ _ _ _ _ <- get
-- setContinuation x (\x -> liftIO (print "hi") >> return x) $ fs
r <- runTrans $ unsafeCoerce x'
-- setData WasRemote
-- restoreStack fs
return r
getEffects :: Loggable a => Cloud [(Node, a)]
getEffects=lliftIO $ readMVar effects
runNodes nodes= foldl (<|>) empty (map listen nodes) <|> return()
delEffects= lliftIO $ modifyMVar_ effects $ const $ return[]
effects= unsafePerformIO $ newMVar []
effect x= do
node <- getMyNode
lliftIO $ modifyMVar_ effects $ \ xs -> return $ (node,x): xs
return()
{-# LANGUAGE DeriveDataTypeable , ExistentialQuantification
,ScopedTypeVariables, StandaloneDeriving, RecordWildCards, FlexibleContexts, CPP
,GeneralizedNewtypeDeriving #-}
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 Control.Applicative
import Control.Monad
import Data.Typeable
import Data.IORef
import Control.Concurrent (threadDelay)
import Control.Monad.IO.Class
import Data.Monoid
import Data.String
main= simpleWebApp 8081 $ local $ buttons <|> linksample
where
linksample= do
r <- render $ br ++> wlink "Hi!" (toElem "This link say Hi!")`fire` OnClick
render $ rawHtml . b $ " returns "++ r
buttons= do
render . rawHtml $ p "Different input elements:"
radio **> br
++> checkButton
**> br ++> br
++> select
<++ br
checkButton=do
rs <- render $ -- getCheckBoxes(
((setCheckBox False "Red" <++ b "red") `fire` OnClick)
-- <> ((setCheckBox False "Green" <++ b "green") `fire` OnClick)
-- <> ((setCheckBox False "blue" <++ b "blue") `fire` OnClick) --)
render $ wraw $ fromString " returns: " <> b (show rs)
empty
radio= do
r <- render $ getRadio [fromString v ++> setRadioActive v | v <- ["red","green","blue"]]
render $ wraw $ fromString " returns: " <> b ( show r )
select= do
r <- render $ getSelect ( setOption "red" (fromString "red")
<|> setOption "green" (fromString "green")
<|> setOption "blue" (fromString "blue"))
`fire` OnClick
render $ wraw $ fromString " returns: " <> b ( show r )

9
tests/test5.hs

@ -31,13 +31,14 @@ import Data.List((\\))
main = keep $ initNode $ test
test= onBrowser $ do
local . render $ wlink () $ p "Product Categories"
r <- local . render $
test= onBrowser $ local $ do
r <- render $
(,) <$> inputString Nothing `fire` OnChange
<*> inputInt Nothing `fire` OnChange
<** inputSubmit "click" `fire` OnClick
lliftIO $ print r
liftIO $ print r

37
tests/testService.hs

@ -2,8 +2,10 @@
import Transient.Base
import Transient.Internals((!>))
import Transient.Move
import Transient.Move.Utils
import Transient.Logged
import Transient.Move.Services
import Control.Applicative
import Control.Monad
@ -12,41 +14,40 @@ import Data.IORef
import Control.Concurrent (threadDelay)
import Control.Monad.IO.Class
#ifndef Service
#ifdef Library
client params= do
r <- callService "" ("service","service") params ""
lliftIO $ print r
r <- callService "" ("service","service") params
lliftIO $ print (r :: String)
#else
main= keep $ do
main= keep $ runCloud $ do
runService ("service","service") service
empty
<|> do
runNodes [2001]
-- local $ option "start" "start"
client ("hello","world")
empty
initNode' [("service","service")] $ do
makeService service
addService s= do
nodes <- getNodes
con@Connection{myNode= mynode} <- getSData <|> error "connection not set. please initialize it"
con@Connection{myNode= mynode} <- getSData -- <|> error "connection not set. please initialize it"
mynode <- getMyNode
mynode'= mynode{services= services mynode++ s}
setNodes $ mynode': nodes\\[mynode]
let mynode'= mynode{nodeServices= s:nodeServices mynode}
addNodes [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 :: (String,String) -> Cloud String
service (x,y)= do
lliftIO $ print x
return y
service' params= wormhole undefined $ loggedc $ do
(x,y) <- local $ return params
lliftIO $ print x

Loading…
Cancel
Save