├── .gitignore ├── .travis.yml ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── app ├── client │ └── Transient │ │ └── Move │ │ └── Services │ │ └── void.hs └── server │ └── Transient │ └── Move │ └── Services │ ├── MonitorService.hs │ ├── controlServices.hs │ └── executor.hs ├── buildrun.sh ├── circle.yml ├── examples ├── distributedApps.hs └── runweb2.sh ├── execthirdlinedocker.sh ├── hasrocket.prof ├── loop.sh ├── src └── Transient │ ├── MapReduce.hs │ ├── Move.hs │ └── Move │ ├── Internals.hs │ ├── Internals.loggedmodified.hs │ ├── Services.hs │ ├── Services │ └── Executor.hs │ └── Utils.hs ├── stack-ghcjs.yaml ├── stack.yaml ├── tests ├── Dockerfile ├── Parameters.hs ├── Stream.hs ├── Test.hs ├── Test3.hs ├── TestSuite ├── TestSuite.hs ├── TestSuite1 ├── TestSuite1.hs ├── Testspark.hs ├── api.hs ├── build.sh ├── buildrun.sh ├── cell.hs ├── certificate.csr ├── certificate.pem ├── chen.hs ├── distributedApps.hs ├── dockerclean.sh ├── execcluster.sh ├── execthirdline.sh ├── ghcjs-websockets.hs ├── hasrocket ├── hasrocket.hs ├── iterate.sh ├── key.pem ├── nikita.hs ├── raft.hs ├── rundevel.sh ├── snippet ├── streamMonad.hs ├── test5.hs ├── testIRC.hs ├── testRestService.hs ├── testService.hs ├── teststream.hs ├── teststreamsocket.hs └── testtls.hs ├── transient-universe.cabal └── universe.png /.gitignore: -------------------------------------------------------------------------------- 1 | Demos/old-trash 2 | Demos/db 3 | Test 4 | errlog 5 | .tcachedata 6 | .cabal-sandbox 7 | cabal.sandbox* 8 | favicon 9 | IDE.session 10 | MFlow.lkshf 11 | notes.txt 12 | notes.lhs 13 | dist 14 | *.js* 15 | *.o 16 | *.hi 17 | *.exe 18 | *.lk* 19 | .cabal-sandbox 20 | cabal.sanbox.config 21 | .stack* 22 | # emacs stuff 23 | *~ 24 | \#*\# 25 | /.emacs.desktop 26 | /.emacs.desktop.lock 27 | *.elc 28 | auto-save-list 29 | tramp 30 | .\#* 31 | 32 | # Org-mode 33 | .org-id-locations 34 | *_archive 35 | 36 | # flymake-mode 37 | *_flymake.* 38 | 39 | # eshell files 40 | /eshell/history 41 | /eshell/lastdir 42 | 43 | # elpa packages 44 | /elpa/ 45 | 46 | # vim stuff 47 | *.swp 48 | *.swo 49 | 50 | *.key 51 | _darcs 52 | darcs* 53 | /src/style.css 54 | *.back 55 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Use new container infrastructure to enable caching 2 | sudo: false 3 | 4 | # Choose a lightweight base image; we provide our own build tools. 5 | language: c 6 | 7 | # Caching so the next build will be fast too. 8 | cache: 9 | directories: 10 | - $HOME/.ghc 11 | - $HOME/.cabal 12 | - $HOME/.stack 13 | - $HOME/.ghcjs 14 | 15 | # The different configurations we want to test. We have BUILD=cabal which uses 16 | # cabal-install, and BUILD=stack which uses Stack. More documentation on each 17 | # of those below. 18 | # 19 | # We set the compiler values here to tell Travis to use a different 20 | # cache file per set of arguments. 21 | # 22 | # If you need to have different apt packages for each combination in the 23 | # matrix, you can use a line such as: 24 | # addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}} 25 | matrix: 26 | include: 27 | # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See: 28 | # https://github.com/hvr/multi-ghc-travis 29 | - env: BUILD=cabal GHCVER=7.10.2 CABALVER=1.22 30 | compiler: ": #GHC 7.10.2" 31 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2], sources: [hvr-ghc]}} 32 | - env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 33 | compiler: ": #GHC 7.10.3" 34 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}} 35 | - env: BUILD=cabal GHCVER=8.0.1 CABALVER=1.24 36 | compiler: ": #GHC 8.0.1" 37 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}} 38 | 39 | # Build with the newest GHC and cabal-install. This is an accepted failure, 40 | # see below. 41 | - env: BUILD=cabal GHCVER=head CABALVER=head 42 | compiler: ": #GHC HEAD" 43 | addons: {apt: {packages: [cabal-install-head,ghc-head], sources: [hvr-ghc]}} 44 | 45 | # The Stack builds. We can pass in arbitrary Stack arguments via the ARGS 46 | # variable, such as using --stack-yaml to point to a different file. 47 | - env: BUILD=stack ARGS="--resolver lts-3" 48 | compiler: ": #stack 7.10.2" 49 | addons: {apt: {packages: [ghc-7.10.2], sources: [hvr-ghc]}} 50 | 51 | - env: BUILD=stack ARGS="--resolver lts-5" 52 | compiler: ": #stack 7.10.3 LTS 5" 53 | addons: {apt: {packages: [ghc-7.10.3], sources: [hvr-ghc]}} 54 | 55 | - env: BUILD=stack ARGS="--resolver lts-6" 56 | compiler: ": #stack 7.10.3 LTS 6" 57 | addons: {apt: {packages: [ghc-7.10.3], sources: [hvr-ghc]}} 58 | 59 | # Nightly builds are allowed to fail 60 | - env: BUILD=stack ARGS="--resolver nightly" 61 | compiler: ": #stack nightly" 62 | addons: {apt: {packages: [libgmp-dev]}} 63 | 64 | # GHCJS build via stack 65 | - env: BUILD=ghcjs ARGS="--stack-yaml=stack-ghcjs.yaml" 66 | compiler: ": #stack GHCJS" 67 | addons: {apt: {packages: [ghc-7.10.3], sources: [hvr-ghc]}} 68 | 69 | # Build on OS X in addition to Linux 70 | - env: BUILD=stack ARGS="--resolver lts-6" 71 | compiler: ": #stack 7.10.3 LTS 6 (OS X)" 72 | os: osx 73 | 74 | allow_failures: 75 | - os: osx 76 | - env: BUILD=ghcjs ARGS="--stack-yaml=stack-ghcjs.yaml" 77 | - env: BUILD=cabal GHCVER=head CABALVER=head 78 | - env: BUILD=stack ARGS="--resolver nightly" 79 | 80 | before_install: 81 | # Using compiler above sets CC to an invalid value, so unset it 82 | - unset CC 83 | - export CASHER_TIME_OUT=600 84 | - if [ $BUILD = "ghcjs" ]; then nvm install 6; fi 85 | 86 | # We want to always allow newer versions of packages when building on GHC HEAD 87 | - CABALARGS="" 88 | - if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi 89 | 90 | # Download and unpack the stack executable 91 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:$PATH 92 | - mkdir -p ~/.local/bin 93 | - | 94 | if [ `uname` = "Darwin" ] 95 | then 96 | curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 97 | else 98 | curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 99 | fi 100 | 101 | 102 | install: 103 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 104 | - if [ -f configure.ac ]; then autoreconf -i; fi 105 | - | 106 | case "$BUILD" in 107 | stack) 108 | stack --no-terminal --install-ghc $ARGS test --only-dependencies 109 | ;; 110 | cabal) 111 | cabal --version 112 | travis_retry cabal update 113 | cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS 114 | ;; 115 | ghcjs) 116 | stack --no-terminal setup $ARGS 117 | stack --no-terminal --install-ghc $ARGS test --only-dependencies 118 | ;; 119 | esac 120 | 121 | script: 122 | - | 123 | case "$BUILD" in 124 | cabal) 125 | cabal configure --enable-tests --enable-benchmarks -v2 --ghc-options="-O0" 126 | cabal build 127 | cabal check || [ "$CABALVER" == "1.16" ] 128 | cabal test 129 | cabal sdist 130 | cabal copy 131 | SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && \ 132 | (cd dist && cabal install --force-reinstalls "$SRC_TGZ") 133 | ;; 134 | *) 135 | stack --no-terminal $ARGS test --haddock --no-haddock-deps 136 | ;; 137 | esac 138 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/transient-haskell/transient-universe/7cfbbdfa8eefbea79f48ccb69bc1823ba9abc7ea/ChangeLog.md -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Alberto G. Corona 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | IMPORTANT NOTE: Transient is being translated to a new repo 2 | 3 | THIS REPO IS DEPRECATED 4 | 5 | Please, for the last version, go to: 6 | 7 | https://github.com/transient-haskell/transient-stack 8 | 9 | There is all the haskell packages, including distributed computing (transient-universe) and client-side web (axiom) 10 | 11 | ![Universe logo](universe.png) 12 | ========= 13 | 14 | [![Hackage](https://img.shields.io/hackage/v/transient-universe.svg)](http://hackage.haskell.org/package/transient-universe) 15 | [![Stackage LTS](http://stackage.org/package/transient-universe/badge/lts)](http://stackage.org/lts/package/transient-universe) 16 | [![Stackage Nightly](http://stackage.org/package/transient-universe/badge/nightly)](http://stackage.org/nightly/package/transient-universe) 17 | [![Build Status](https://travis-ci.org/transient-haskell/transient-universe.png?branch=master)](https://travis-ci.org/transient-haskell/transient-universe) 18 | [![Gitter](https://badges.gitter.im/theam/haskell-do.svg)](https://gitter.im/Transient-Transient-Universe-HPlay/Lobby?utm_source=share-link&utm_medium=link&utm_campaign=share-link) 19 | 20 | [![Simple Haskell](http://simplehaskell.org/badges/badge.svg)](http://simplehaskell.org) 21 | 22 | See the [Wiki](https://github.com/agocorona/transient/wiki) 23 | 24 | transient-universe is the distributed computing extension of [transient](https://github.com/agocorona/transient) and uses transient primitives heavily for parsing, threading, event handling, exception handling, messaging etc. It support moving computations between Haskell closures in different computers in the network. Even among different architectures: Linux nodes can work with windows and browser nodes running haskell compiled with [ghcjs](https://github.com/ghcjs/ghcjs). 25 | 26 | The primitives that perform the moving of computations are called `wormhole` and `teleport`, the names express the semantics. Hence the name of the package. 27 | 28 | All the nodes run the same program compiled for different architectures. It defines a Cloud computation (monad). It is a thin layer on top of transient with additional primitives and services that run a single program in one or many nodes. 29 | 30 | Example: 31 | ======= 32 | 33 | ```haskell 34 | import Transient.Base 35 | import Transient.Move 36 | import Control.Monad 37 | 38 | main= keep . initNode $ inputNodes <|> mypPogram 39 | 40 | myProgram :: Cloud () 41 | myProgram= do 42 | nodes <- local getNodes 43 | guard $ length nodes > 1 44 | let node2= nodes !! 1 45 | r <- runAt node2 . local $ waitEvents getLine 46 | localIO $ print r 47 | 48 | ``` 49 | 50 | This program will stream and print any text that you input in the console of the node 2. 51 | 52 | To know how to initialize the nodes, see the section of the [Tutorial](https://github.com/transient-haskell/transient/wiki/Transient-tutorial#command-line-input) 53 | 54 | Browser integration 55 | ================== 56 | 57 | Browser nodes, running transient programs compiled with ghcjs are integrated with server nodes, using websockets for communication. Just compile the program with ghcjs and point the browser to http://server:port. The server nodes have a HTTP server that will send the compiled program to the browser. 58 | 59 | Distributed Browser/server Widgets 60 | ------- 61 | Browser nodes can integrate a reactive client side library based in trasient (package [axiom](https://github.com/transient-haskell/axiom)). These widgets can create widgets with HTML form elements and control the server nodes. A computation can move from browser to server and back despite the different architecture. 62 | 63 | This program will obtain a string from the browser, will send it to the server, which will return three responses wich will be presented in the browser: 64 | 65 | ```haskell 66 | import Transient.Base 67 | import Transient.Move 68 | import Transient.Indeterminism 69 | import GHCJS.HPlay.View 70 | 71 | main= keep . initNode $ myProgram 72 | 73 | myProgram :: Cloud () 74 | myProgram= do 75 | name <- local . render $ getString Nothing `fire` OnChange 76 | r <- atRemote . local . choose . take 3 . repeat $ "hello "++ name 77 | local . render . rawHtml $ h1 r 78 | ``` 79 | See the package Axiom for instructions about how to compile and run this program. 80 | 81 | Widgets with code running in browser and servers can compose with other widgets. A Browser node can gain access to many server nodes trough the server that delivered the web application. 82 | 83 | These features can make transient ideal for client as well as server side-driven applications, whenever distribution and push-driven reactivity is necessary either in the servers or in the browser clients. 84 | 85 | New 86 | === 87 | The last release add 88 | 89 | - Hooks for secure communications: with [transient-universe-tls package](https://github.com/transient-haskell/transient-universe-tls), a node can use TLS to connect with other nodes, including web nodes. If the connection of a web node is initiated with "https" the websocket connection uses secure communications (wss). The only primitive added is `initTLS`. 90 | - Client websocket connections to connect with nodes within firewalled servers: a server node can connect with another situated after a HTTP server. All the process is transparent and add no new primitive; First `connect` tries a TCP socket connection if it receives other message than "OK", it tries a connection as a websocket client. This is important for P2P connections where a central server acts as coordinator. websocket connections can use TLS communications too. 91 | - No network traffic when a node invokes itself 92 | 93 | Map-reduce 94 | ========== 95 | transient-universe implements map-reduce in the style of [spark](http://spark.apache.org) as a particular case. It is at the same time a hard test of the distributed primitives since it involves a complex choreography of movement of computations. It supports in memory operations and caching. Resilience (restart from the last checkpoint in case of failure) is not implemented but it is foreseen. 96 | 97 | Look at [this article](https://www.schoolofhaskell.com/user/agocorona/estimation-of-using-distributed-computing-streaming-transient-effects-vi-1#distributed-datasets) 98 | 99 | There is a runnable example: [DistrbDataSets.hs](https://github.com/agocorona/transient-universe/blob/master/examples/DistrbDataSets.hs) that you can executed with: 100 | 101 | > runghc ./examples/DistrbDataSets.hs 102 | 103 | It uses a number of simulated nodes to calculate the frequency of words in a long text. 104 | 105 | Services 106 | ======== 107 | Services communicate two different transient applications. This allows to divide the running application in different independent tiers. No documentation is available yet. Sorry. 108 | 109 | General distributed primitives 110 | ============================= 111 | `teleport` is a primitive that translates computations back and forth reusing an already opened connection. 112 | 113 | The connection is initiated by `wormhole` with another node. This can be done anywhere in a computation without breaking composability. As always, Everything is composable. 114 | 115 | Both primitives support also streaming among nodes in an efficient way. It means that a remote call can return not just a single response, but many of them. 116 | 117 | All the other distributed primitives: `runAt`, `streamFrom` `clustered` etc are rewritten in terms of these two. 118 | 119 | How to run the ghcjs example: 120 | ============================= 121 | 122 | See the distributed examples in the [transient-examples](https://github.com/transient-haskell/transient) repository 123 | 124 | See this [video](https://www.livecoding.tv/agocorona/videos/Ke1Qz-seamless-composable-web-programming) to see this example running: 125 | 126 | The test program run among other things, two copies of a widget that start, stop and display a counter that run in the server. 127 | 128 | Documentation 129 | ============= 130 | 131 | The [Wiki](https://github.com/agocorona/transient/wiki) is more user oriented 132 | 133 | My video sessions in [livecoding.tv](https://www.livecoding.tv/agocorona/videos/) not intended as tutorials or presentations, but show some of the latest features running. 134 | 135 | The articles are more technical: 136 | 137 | - [Philosophy, async, parallelism, thread control, events, Session state](https://www.fpcomplete.com/user/agocorona/EDSL-for-hard-working-IT-programmers?show=tutorials) 138 | - [Backtracking and undoing IO transactions](https://www.fpcomplete.com/user/agocorona/the-hardworking-programmer-ii-practical-backtracking-to-undo-actions?show=tutorials) 139 | - [Non-deterministic list like processing, multithreading](https://www.fpcomplete.com/user/agocorona/beautiful-parallel-non-determinism-transient-effects-iii?show=tutorials) 140 | - [Distributed computing](https://www.fpcomplete.com/user/agocorona/moving-haskell-processes-between-nodes-transient-effects-iv?show=tutorials) 141 | - [Publish-Subscribe variables](https://www.schoolofhaskell.com/user/agocorona/publish-subscribe-variables-transient-effects-v) 142 | - [Distributed streaming, map-reduce](https://www.schoolofhaskell.com/user/agocorona/estimation-of-using-distributed-computing-streaming-transient-effects-vi-1) 143 | 144 | These articles contain executable examples (not now, since the site no longer support the execution of Haskell snippets). 145 | 146 | 147 | 148 | Future plans 149 | ============ 150 | The only way to improve it is using it. Please send me bugs and additional functionalities! 151 | 152 | -I plan to improve map-reduce to create a viable platform for serious data analysis and machine learning using haskell. It will have a web notebook running in the browser. 153 | 154 | -Create services and examples for general Web applications with distributed servers and create services for them 155 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/client/Transient/Move/Services/void.hs: -------------------------------------------------------------------------------- 1 | main= return () 2 | -------------------------------------------------------------------------------- /app/server/Transient/Move/Services/MonitorService.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Transient.Move.Services.MonitorService 4 | -- Copyright : 5 | -- License : MIT 6 | -- 7 | -- Maintainer : agocorona@gmail.com 8 | -- Stability : 9 | -- Portability : 10 | -- 11 | -- | 12 | -- 13 | ----------------------------------------------------------------------------- 14 | {-# LANGUAGE ScopedTypeVariables #-} 15 | module Main where 16 | 17 | import Transient.Internals 18 | import Transient.Logged 19 | import Transient.Indeterminism(choose) 20 | import Transient.Move.Internals 21 | import Transient.Move.Utils 22 | import Transient.Move.Services 23 | import Control.Applicative 24 | import Control.Monad.IO.Class 25 | import Control.Exception(SomeException(..)) 26 | import Control.Concurrent 27 | import Control.Monad 28 | import Data.List 29 | import System.IO 30 | import System.Process 31 | import System.Directory 32 | import Data.Monoid 33 | import Unsafe.Coerce 34 | import System.IO.Unsafe 35 | import Data.IORef 36 | import qualified Data.Map as M 37 | import GHC.Conc 38 | import Data.Maybe(fromMaybe) 39 | import Control.Exception 40 | import qualified Data.ByteString.Lazy.Char8 as BS 41 | import qualified Data.ByteString.Char8 as BSS 42 | 43 | 44 | 45 | 46 | main = do 47 | putStrLn "Starting Transient monitor" 48 | keep $ runService monitorService 3000 49 | 50 | [serve receiveStatus 51 | ,serve returnInstances 52 | ,serve reReturnInstances 53 | 54 | ,serve receiveFromNodeStandardOutputIt 55 | ,serve sendToNodeStandardInputIt 56 | ,serve getLogIt 57 | ] 58 | empty 59 | 60 | 61 | {- ping is not used to determine healt of services. The client program notify the 62 | monitor when a service fails, with reInitService. 63 | pings = do 64 | 65 | localIO $ print $ "INITIATING PINGSSSSSSSSSSSSSSSSSSSSSSS" 66 | local $ threads 0 $ choose ([1..] :: [Int]) 67 | 68 | nodes <- local getNodes 69 | return () !> ("NODES=", length nodes) 70 | 71 | localIO $ threadDelay 10000000 72 | 73 | local $ threads 1 $ runCloud $ mapM ping $ tail nodes 74 | empty 75 | -} 76 | 77 | 78 | type Port= Int 79 | 80 | -- | receive a status from an executable. 81 | receiveStatus :: (Port, String) -> Cloud () 82 | receiveStatus (port, logLine)= do 83 | localIO $ appendFile ("log"++ show port) $ logLine++"\n" 84 | 85 | 86 | blockings= unsafePerformIO $ newIORef M.empty 87 | 88 | 89 | withBlockingService :: Service -> Cloud a -> Cloud a 90 | withBlockingService serv proc= do 91 | beingDone <- localIO $ atomicModifyIORef blockings $ \map -> 92 | let mv = M.lookup serv map 93 | in case mv of 94 | Nothing -> (M.insert serv () map,False) 95 | Just () -> (map,True) 96 | if beingDone 97 | then do 98 | --localIO $ threadDelay 3000000 99 | withBlockingService serv proc 100 | else do 101 | r <- proc 102 | localIO $ atomicModifyIORef blockings $ \map -> (M.delete serv map,()) 103 | return r 104 | 105 | -- | gets a node with a service, which probably failed and return other n instances of the same service. 106 | -- This is used to implement failover. 107 | reReturnInstances :: (String, Node, Int) -> Cloud [Node] 108 | reReturnInstances (ident, node, num)= do 109 | local $ delNodes [node] 110 | returnInstances (ident, nodeServices node, num) 111 | 112 | -- | install and return n instances of a service, distributed 113 | -- among all the nodes which have monitoService executables running and connected 114 | returnInstances :: (String, Service, Int) -> Cloud [Node] 115 | returnInstances (ident, service, num)= withBlockingService service $ do 116 | return () !> "RETURNINSTANCES" 117 | nodes <- local $ findInNodes service >>= return . take num 118 | 119 | let n= num - length nodes 120 | if n <= 0 then return $ take num nodes 121 | else return nodes <> requestInstall ident service n 122 | where 123 | 124 | requestInstall :: String -> Service -> Int -> Cloud [ Node] 125 | requestInstall ident service num= do 126 | ns <- local getNodes 127 | return () !> ("equal",ns) 128 | auth <- callNodes' ns (<>) mempty $ localIO $ authorizeService ident service >>= \x -> return [x] 129 | return () !> auth 130 | let nodes = map fst $ filter snd $ zip ns auth 131 | nnodes= length nodes 132 | pernode= num `div` nnodes 133 | lacking= num `rem` nnodes 134 | (nodes1,nodes2)= splitAt lacking nodes 135 | return () !> (pernode,lacking,nodes1,nodes2) 136 | rs <- callNodes' nodes1 (<>) mempty (installHere service (pernode+1)) <> 137 | callNodes' nodes2 (<>) mempty (installHere service pernode) 138 | local $ addNodes rs 139 | ns <- onAll getNodes 140 | 141 | return rs !> ("MONITOR RETURN---------------------------------->", rs) 142 | 143 | -- installIt = installHere service <|> installThere service 144 | installHere :: Service -> Int -> Cloud [ Node] 145 | installHere service n= local $ replicateM n installOne 146 | where 147 | installOne= do 148 | port <- liftIO freePort 149 | install service port 150 | return () !> "INSTALLED" 151 | 152 | thisNode <- getMyNode 153 | let node= Node (nodeHost thisNode) port Nothing (service ++ relayinfo thisNode) -- node to be published 154 | addNodes [node] 155 | return node 156 | `catcht` \(e :: SomeException) -> liftIO (putStr "INSTALLLLLLLLLLLLLLL2222222: " >> print e) >> empty 157 | 158 | relayinfo mon= if nodeHost mon /= "localhost" then [("relay",show(nodeHost mon,nodePort mon))] else [] 159 | 160 | 161 | 162 | 163 | 164 | 165 | install :: Service -> Int -> TransIO () 166 | 167 | install service port= do 168 | -- return () !> "IIIIIIIIIIIIIIINSTALL" 169 | 170 | install' `catcht` \(e :: SomeException) -> liftIO (putStr "INSTALL error: " >> print e) >> empty 171 | where 172 | install'= do 173 | my <- getMyNode 174 | let host= nodeHost my 175 | program <- return (lookup "executable" service) `onNothing` empty 176 | -- return () !> ("program",program) 177 | tryExec program host port <|> tryDocker service host port program 178 | <|> do tryInstall service ; tryExec program host port 179 | 180 | 181 | tryInstall :: Service -> TransIO () 182 | tryInstall service = do 183 | package <- emptyIfNothing (lookup "package" service) 184 | install package 185 | where 186 | install package 187 | | "git:" `isPrefixOf` package= installGit package 188 | | "https://github.com" `isPrefixOf` package = installGit package 189 | | "http://github.com" `isPrefixOf` package = installGit package 190 | 191 | 192 | tryDocker service host port program= do 193 | image <- emptyIfNothing $ lookup "image" service 194 | path <- Transient $ liftIO $ findExecutable "docker" -- return empty if not found 195 | liftIO $ callProcess path ["run", image,"-p"," start/"++ host++"/"++ show port++ " " ++ program] 196 | 197 | 198 | tryExec program host port= do 199 | path <- Transient $ liftIO $ findExecutable program -- would abandon (empty) if the executable is not found 200 | spawnProgram program host port -- !>"spawn" 201 | where 202 | spawnProgram program host port= do 203 | 204 | let prog = pathExe program host port 205 | liftIO $ putStr "executing: " >> putStrLn prog 206 | 207 | (networkExecuteStreamIt prog >> empty) <|> return () !> "INSTALLING" 208 | liftIO $ threadDelay 2000000 209 | 210 | return() !> ("INSTALLED", program) 211 | where 212 | 213 | pathExe program host port= 214 | program ++ " -p start/" ++ (host ::String) 215 | ++"/" ++ show (port ::Int) -- ++ " > "++ program ++ host ++ show port ++ ".log 2>&1" 216 | 217 | 218 | 219 | 220 | 221 | 222 | installGit package = liftIO $ do 223 | 224 | let packagename = name package 225 | when (null packagename) $ error $ "source for \""++package ++ "\" not found" 226 | callProcess "git" ["clone",package] 227 | liftIO $ putStr package >> putStrLn " cloned" 228 | setCurrentDirectory packagename 229 | callProcess "cabal" ["install","--force-reinstalls"] 230 | setCurrentDirectory ".." 231 | 232 | 233 | where 234 | name url= slash . slash . slash $ slash url 235 | where 236 | slash= tail1 . dropWhile (/='/') 237 | tail1 []=[] 238 | tail1 x= tail x 239 | 240 | 241 | -------------------------execution ---------------------------- 242 | 243 | getLogIt :: GetLog -> Cloud BS.ByteString 244 | getLogIt (GetLog node)= do 245 | let program = fromMaybe (error "no Executable in service "++ show (nodeServices node)) $ 246 | lookup "executable" (nodeServices node) 247 | let expr = pathExe program (nodeHost node) (nodePort node) 248 | localIO $ BS.readFile $ logFileName expr 249 | 250 | 251 | sendToNodeStandardInputIt :: (Node, String) -> Cloud () 252 | sendToNodeStandardInputIt (node,inp)= do 253 | let program = fromMaybe (error "no Executable in service "++ show (nodeServices node)) $ 254 | lookup "executable" (nodeServices node) 255 | expr= pathExe program (nodeHost node) (nodePort node) 256 | return () !> ("SEND TO NODE STANDARD INPUT", program, expr) 257 | sendExecuteStreamIt1 (expr, inp) 258 | where 259 | sendExecuteStreamIt1 (cmdline, inp)= localIO $ do 260 | map <- readIORef rinput 261 | let input1= fromMaybe (error "this command line has not been opened") $ M.lookup cmdline map 262 | hPutStrLn input1 inp 263 | hFlush input1 264 | return() 265 | 266 | receiveFromNodeStandardOutputIt :: ReceiveFromNodeStandardOutput -> Cloud String 267 | receiveFromNodeStandardOutputIt (ReceiveFromNodeStandardOutput node ident) = local $ do 268 | let program = fromMaybe (error "no Executable in service "++ show (nodeServices node)) $ 269 | lookup "executable" (nodeServices node) 270 | expr= pathExe program (nodeHost node) (nodePort node) 271 | return () !> ("RECEIVE FROM STANDARD OUTPUT",expr) 272 | labelState ident 273 | getMailbox' ("output"++ expr) 274 | 275 | rinput :: IORef (M.Map String Handle) 276 | rinput= unsafePerformIO $ newIORef M.empty 277 | 278 | 279 | logFolder= "./.log/" 280 | 281 | logFileName ('.':expr) = logFileName expr 282 | logFileName expr= logFolder ++ subst expr ++ ".log" 283 | where 284 | subst []= [] 285 | subst (' ':xs)= '-':subst xs 286 | subst ('/':xs)= '-':subst xs 287 | subst ('\"':xs)= '-':subst xs 288 | subst (x:xs)= x:subst xs 289 | 290 | -- | execute the shell command specified in a string and stream back at runtime -line by line- the standard output 291 | -- as soon as there is any output. It also stream all the standard error in case of exiting with a error status. 292 | -- to the service caller. invoked by `networkExecuteStream`. 293 | 294 | 295 | networkExecuteStreamIt :: String -> TransIO String 296 | networkExecuteStreamIt expr = do 297 | liftIO $ createDirectoryIfMissing True logFolder 298 | 299 | r <- liftIO $ createProcess $ (shell expr){std_in=CreatePipe,std_err=CreatePipe,std_out=CreatePipe} 300 | liftIO $ atomicModifyIORef rinput $ \map -> (M.insert expr (input1 r) map,()) 301 | 302 | let logfile= logFileName expr 303 | 304 | hlog <- liftIO $ openFile logfile WriteMode 305 | liftIO $ hPutStrLn hlog expr 306 | liftIO $ hClose hlog 307 | 308 | line <- watch (output r) <|> watch (err r) <|> watchExitError r 309 | putMailbox' ("output" ++ expr) line 310 | hlog <- liftIO $ openFile logfile AppendMode 311 | liftIO $ hPutStrLn hlog line 312 | liftIO $ hClose hlog 313 | return line 314 | where 315 | 316 | input1 r= inp where (Just inp,_,_,_)= r 317 | output r= out where (_,Just out,_,_)= r 318 | err r= err where (_,_,Just err,_)= r 319 | handle r= h where (_,_,_,h)= r 320 | 321 | watch :: Handle -> TransIO String 322 | watch h= do 323 | abduce 324 | mline <- threads 0 $ (parallel $ (SMore <$> hGetLine' h) `catch` \(e :: SomeException) -> return SDone) 325 | case mline of 326 | SDone -> empty 327 | SMore line -> return line 328 | 329 | where 330 | 331 | hGetLine' h= do 332 | buff <- newIORef [] 333 | getMore buff 334 | 335 | where 336 | 337 | getMore buff= do 338 | b <- hWaitForInput h 10 339 | if not b 340 | then do 341 | r <-readIORef buff 342 | if null r then getMore buff else return r 343 | else do 344 | c <- hGetChar h 345 | if c== '\n' then readIORef buff else do 346 | modifyIORef buff $ \str -> str ++ [c] 347 | getMore buff 348 | 349 | watchExitError r= do -- make it similar to watch 350 | abduce 351 | liftIO $ waitForProcess $ handle r 352 | errors <- liftIO $ hGetContents (err r) 353 | return errors 354 | 355 | -------------------------------------------------------------------------------- /app/server/Transient/Move/Services/controlServices.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | 4 | import Transient.Internals 5 | import Transient.Move.Internals 6 | import Transient.Indeterminism 7 | import Transient.Move.Utils 8 | import Transient.Logged 9 | import Transient.Move.Services 10 | import Transient.Move.Services.Executor 11 | import Control.Applicative 12 | import Control.Monad 13 | 14 | import Data.Typeable 15 | import Data.IORef 16 | import Control.Concurrent (threadDelay) 17 | import Control.Monad.IO.Class 18 | import Control.Exception hiding (onException) 19 | import System.IO.Unsafe 20 | import Data.Maybe 21 | 22 | 23 | import System.IO 24 | import System.Process 25 | import Control.Concurrent 26 | {- 27 | 28 | 29 | example record updates, distributed database? 30 | connect. Un servicio para conectar añadir instancias? 31 | 32 | 33 | connect created instances 34 | connectNode as service. 35 | 36 | 37 | a transient service as REST service: in the http treatment in listen: /a/b/c/d -> (a,b,c,d) 38 | 39 | option to discover the types of service parameters: 40 | get the services 41 | return the types 42 | 43 | -} 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | main = keep $ runService [("executable","testService")] 8000 [serve selfService] $ do 59 | control2 <|> examples 60 | 61 | 62 | examples= do 63 | local $ option "examples" "some examples and test of service usage" 64 | ping1 <|> ping2 <|> singleExec <|> stream <|> 65 | failThreeTimes <|> many1 <|> fail3requestNew <|> 66 | requestAtHost <|> self <|> distrib 67 | 68 | distrib= do 69 | local $ option "dis" "request another instance of this program and call it" 70 | this <- local getMyNode 71 | localIO $ print this 72 | [node] <- requestInstance (nodeServices this) 1 73 | local $ option "launch" "launch" 74 | r <- runAt node $ return "hello world" 75 | localIO $ print r 76 | 77 | 78 | control2 = control <|> spawn1 79 | 80 | spawn1= do 81 | local $ option "spawn" "spawn a bash shell and a loop that can be visited/controlled" 82 | networkExecuteStream' "bash" 83 | networkExecuteStream' "./loop.sh 'hello'" 84 | localIO $ putStrLn "SPAWNED\n\nUse \"control\" to manage the processes" 85 | empty 86 | 87 | control= do 88 | local $ option "control" "control a node or process initiated by previous examples" 89 | cloudControl 90 | 91 | 92 | cloudControl= do 93 | localIO $ putStrLn "\n...........VISIBLE NODES AND PROCESSES............" 94 | 95 | callService monitorService () :: Cloud () -- start/ping monitor if not started 96 | 97 | localIO $ do 98 | 99 | putStr $ nodeHost monitorNode 100 | putChar ':' 101 | putStr $ show $ nodePort monitorNode 102 | putChar '/' 103 | putStrLn $ fromJust $ lookup "service" $ nodeServices monitorNode 104 | squeezeMonitor 4 monitorNode 105 | where 106 | 107 | squeezeMonitor tab nod= do 108 | nodes <- callService' nod GetNodes :: Cloud [Node] 109 | 110 | 111 | vis <- local $ do 112 | visited <- getState <|> return [] 113 | let vis = nod `elem` visited 114 | when (not vis) $ setState $ nod:visited 115 | return vis 116 | when (not vis) $ spawn $ controlMonitor nod 117 | 118 | mapM_ squeeze $ tail nodes 119 | where 120 | 121 | squeeze node= do 122 | vis <- local $ do 123 | visited <- getState <|> return [] 124 | let vis= node `elem` visited 125 | when (not vis) $ setState $ node:visited 126 | return vis 127 | when (not vis) $ do 128 | localIO $ do 129 | putStr $ take tab $ repeat ' ' 130 | putStr $ nodeHost node 131 | putChar ':' 132 | putStr $ show $ nodePort node 133 | putChar '/' 134 | putStrLn $ fromJust $ lookup "service" $ nodeServices node 135 | 136 | 137 | 138 | case lookup "service" $ nodeServices node of 139 | 140 | Just "monitor" -> do 141 | spawn $ controlMonitor node 142 | visited <- local $ getState <|> return [] 143 | when (not $ node `elem` visited) $ do 144 | local $ setState $ node:visited 145 | 146 | localIO $ do 147 | putStr $ take tab $ repeat ' ' 148 | putStr " " 149 | putStrLn "Services:" 150 | squeezeMonitor (tab+4) node 151 | 152 | Just "executor" -> do 153 | spawn $ controlService node 154 | procs <- callService' node GetProcesses :: Cloud [String] 155 | 156 | 157 | when (not $ null procs) $ do 158 | localIO $ do 159 | putStr $ take tab $ repeat ' ' 160 | putStrLn " Running processes:" 161 | mapM_ ( spawn . controlProcess) procs 162 | 163 | _ -> return () 164 | 165 | controlMonitor node= do 166 | local $ do 167 | n <- getState <|> return (0 :: Int) 168 | setState $ n +1 169 | liftIO $ putStr "\t\t" 170 | option1 n "control this node\n" 171 | abduce 172 | controlNode node 173 | 174 | controlService node= do 175 | local $ do 176 | n <- getState <|> return (0 :: Int) 177 | setState $ n +1 178 | liftIO $ putStr "\t\t" 179 | option1 n "control this node\n" 180 | abduce 181 | 182 | controlNodeService node 183 | 184 | spawn f= (f >> empty) <|> return () 185 | 186 | controlProcess str= do 187 | local $ do 188 | n <- getState <|> return (0 :: Int) 189 | setState $ n +1 190 | liftIO $ do 191 | putStr $ take tab $ repeat ' ' 192 | putStr " " 193 | putStrLn str 194 | putStr "\t\t" 195 | option1 n "control this process\n" 196 | abduce 197 | controlNodeProcess str 198 | 199 | 200 | 201 | 202 | {- 203 | registerUpdate= do 204 | local $ option "reg" "simulate a two way reactive database update service" 205 | reg <- input (const True) "enter register content " 206 | reg' <- updateDistributedDatabase reg 207 | localIO $ putStr "new register changed: " >> putStrLn reg' 208 | 209 | in the service, made by the same service executable running in different machines and connected among them: 210 | 211 | updateDistributedDatabaseIt= clustered $ do 212 | update reg 213 | return reg 214 | -} 215 | 216 | self= do 217 | local $ option "own" "call a service of my own program" 218 | 219 | nod <- local $ getMyNode 220 | 221 | r <- callService' nod "Alberto" :: Cloud String 222 | localIO $ print r 223 | 224 | selfService str = localIO $ return $ "hello " ++ str 225 | 226 | ping1 = do 227 | local $ option "ping1" "ping monitor (must have been started)" 228 | r <- callService' monitorNode () 229 | localIO $ print (r :: ()) 230 | 231 | 232 | ping2 = do 233 | local $ option "ping" "ping two executors, must return: [((),())]" 234 | 235 | ns <- requestInstance executorService 2 236 | r <- mapM ping ns 237 | localIO $ print r 238 | 239 | 240 | 241 | singleExec= do 242 | local $ option "single" "execution of \"ls -al\" in a executor process" 243 | r <- networkExecute "ls -al" "" 244 | localIO $ print ("RESULT",r) 245 | 246 | 247 | 248 | 249 | stream= do 250 | local $ setRState False 251 | local $ option "stream" "start a remote shell with the executor, then executes different command inputs and stream results" 252 | r <- networkExecuteStream "bash" 253 | s <- local getRState 254 | if s then localIO $ putStr "[bash]" >> print r 255 | else do 256 | local $ setRState True 257 | inputs r -- the first output of the command is the process identifier 258 | where 259 | inputs idproc= do 260 | command <- local $ do 261 | option "send" "send to the remote shell" 262 | input (const True) "command" 263 | sendExecuteStream idproc command 264 | empty 265 | 266 | 267 | fail3requestNew= do 268 | local $ option "fail6" "try a new instance" 269 | 270 | retries <- onAll $ liftIO $ newIORef (0 :: Int) 271 | 272 | local $ onException $ retry6 retries 273 | 274 | r <- networkExecute "UNKNOWN COMMAND" "" 275 | 276 | localIO $ print ("LINE=",r :: String ) 277 | 278 | where 279 | retry6 retries (CloudException node _ _ )= runCloud $ do 280 | localIO $ print ("tried to execute in", node) 281 | n <- onAll $ liftIO $ atomicModifyIORef retries $ \n -> (n+1,n+1) 282 | localIO $ print ("NUMBER OF RETRIES",n) 283 | 284 | if n == 3 then do 285 | localIO $ putStrLn "failed after three retries, reclaiming new instance" 286 | local continue 287 | [node'] <- requestInstanceFail node 1 288 | localIO $ print ("NEW NODE FOR SERVICE", node') 289 | 290 | else if n < 6 then local continue 291 | 292 | else localIO $ print "failed after six retries with two instances, aborting" 293 | 294 | 295 | failThreeTimes= do 296 | local $ option "fail" "fail after three retries" 297 | 298 | 299 | retries <- onAll $ liftIO $ newIORef (0 :: Int) 300 | 301 | let retry3 e= do 302 | liftIO $ print e 303 | n <- liftIO $ atomicModifyIORef retries $ \n -> (n+1,n+1) 304 | liftIO $ print ("NUMBER OF RETRIES",n) 305 | if n < 3 then continue else do 306 | liftIO $ print "failed after three retries" 307 | empty 308 | 309 | local $ onException $ \(e :: CloudException) -> retry3 e 310 | 311 | r <- networkExecute "UNKNOWN COMMAND" "" 312 | 313 | localIO $ print ("LINE=",r :: String ) 314 | 315 | many1= do 316 | local $ option "many" "show how a command is tried to be executed in different executor instances" 317 | requestInstance executorService 5 318 | retries <- onAll $ liftIO $ newIORef (0 :: Int) 319 | 320 | local $ onException $ \e -> retry1 5 retries e 321 | 322 | networkExecute "unknow command" "" 323 | 324 | return () 325 | 326 | where 327 | retry1 n' retries (CloudException node _ _ )= do 328 | liftIO $ print ("tried to execute in", node) 329 | n <- liftIO $ atomicModifyIORef retries $ \n -> (n+1,n+1) 330 | liftIO $ print ("NUMBER OF RETRIES",n) 331 | if n < n' then continue else do 332 | liftIO $ putStr "stop after " >> putStr (show n) >> putStrLn "retries" 333 | empty 334 | 335 | requestAtHost= do 336 | local $ option "host" "request the execution of a shell process at a given machine" 337 | hostname <- local $ input (const True) "enter the hostname (the machine should have monitorService running at port 3000) " 338 | process <- local $ input (const True) "enter the process to run (for example: bash) " 339 | line <- atHost hostname process <|> inputCommands process 340 | localIO $ print ("LINE", line) 341 | where 342 | inputCommands process= do 343 | 344 | local $ option "inp" "enter input for the process created" 345 | inp <- local $ input (const True) "input string: " :: Cloud String 346 | callService executorService (process, inp) :: Cloud() 347 | empty 348 | 349 | atHost :: String -> String -> Cloud String 350 | atHost hostname process = do 351 | executor <- requestInstanceHost hostname executorService 352 | callService' executor process 353 | 354 | 355 | 356 | 357 | 358 | -------------------------------------------------------------------------------- /app/server/Transient/Move/Services/executor.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Transient.Move.Services.Executor 4 | -- Copyright : 5 | -- License : MIT 6 | -- 7 | -- Maintainer : agocorona@gmail.com 8 | -- Stability : 9 | -- Portability : 10 | -- 11 | -- | 12 | -- 13 | ----------------------------------------------------------------------------- 14 | {-# LANGUAGE ScopedTypeVariables #-} 15 | module Main where 16 | 17 | import Transient.Internals 18 | import Transient.Move.Services.Executor 19 | import Transient.Move.Internals 20 | import Transient.Move.Utils 21 | import Transient.Logged(maybeFromIDyn) 22 | import Transient.Move.Services 23 | import Transient.Move.Services.Executor 24 | import Control.Applicative 25 | import Control.Monad.IO.Class 26 | import Control.Exception(SomeException(..),catch) 27 | import Control.Concurrent 28 | import Control.Monad 29 | import Data.List 30 | import System.Process 31 | import System.Directory 32 | import Data.Monoid 33 | import Data.IORef 34 | import System.IO 35 | import System.IO.Unsafe 36 | import qualified Data.Map as M 37 | import Data.Maybe 38 | import qualified Data.ByteString.Lazy.Char8 as BS 39 | import qualified Data.ByteString.Char8 as BSS 40 | import Data.String 41 | import Data.Time 42 | 43 | 44 | main = do 45 | putStrLn "Starting Transient Executor Service" 46 | keep $ runService executorService 3005 47 | [ serve networkExecuteStreamIt 48 | , serve networkExecuteIt 49 | , serve sendExecuteStreamIt 50 | , serve receiveExecuteStreamIt 51 | , serve networkExecuteStreamIt' 52 | , serve getLogIt 53 | , serve getProcessesIt] 54 | empty 55 | 56 | getProcessesIt :: GetProcesses -> Cloud [String] 57 | getProcessesIt _= localIO $ do 58 | map1 <- readIORef rinput 59 | return $ map fst $ M.toList map1 60 | 61 | -- | send input to a remote process initiated with `networkExecuteStream` or `networkExecuteStream'` 62 | sendExecuteStreamIt :: (String,String) -> Cloud () 63 | sendExecuteStreamIt (cmdline, inp)= do 64 | localIO $ do 65 | map <- readIORef rinput 66 | let input= fromMaybe (error "this command line has not been opened") $ M.lookup cmdline map 67 | hPutStrLn input inp 68 | hFlush input 69 | return () 70 | 71 | -- receive input from a remote process initiated with `networkExecuteStream'` 72 | receiveExecuteStreamIt :: ReceiveExecuteStream -> Cloud String 73 | receiveExecuteStreamIt (ReceiveExecuteStream expr ident)= local $ do 74 | labelState ident 75 | getMailbox' ("output"++ expr) 76 | 77 | -- | execute a shell script and a input, and return all the output. Called externally by `networkExecute` 78 | networkExecuteIt :: (String, String, ()) -> Cloud String 79 | networkExecuteIt (expr, input,()) = localIO $ readCreateProcess (shell expr) input 80 | 81 | getLogIt :: GetLogCmd -> Cloud BS.ByteString 82 | getLogIt (GetLogCmd cmd)= localIO $ BS.readFile $ logFileName cmd 83 | 84 | 85 | logFileName ('.':expr) = logFileName expr 86 | logFileName expr= logFolder ++ subst expr ++ ".log" 87 | where 88 | subst []= [] 89 | subst (' ':xs)= '-':subst xs 90 | subst ('/':xs)= '-':subst xs 91 | subst ('\"':xs)= '-':subst xs 92 | subst (x:xs)= x:subst xs 93 | 94 | networkExecuteStreamIt' :: ExecuteStream -> Cloud String 95 | networkExecuteStreamIt' (ExecuteStream expr) = local $ do 96 | 97 | setRState False 98 | 99 | r <- executeStreamIt expr 100 | 101 | 102 | 103 | init <- getRState 104 | if init then empty 105 | else do 106 | setRState True 107 | return r -- return the first output line only 108 | 109 | 110 | -- execute the shell command specified in a string and stream line by line the standard output/error 111 | -- to the service caller. It also store the output in a logfile and update a mailbox that can be 112 | -- inspected by `receiveExecuteStreamIt`. Invoked by `networkExecuteStream`. 113 | -- The first result returned is the process identifier. 114 | networkExecuteStreamIt :: String -> Cloud String 115 | networkExecuteStreamIt expr = local $ executeStreamIt expr 116 | 117 | logFolder= "./.log/" 118 | 119 | executeStreamIt expr = do 120 | liftIO $ createDirectoryIfMissing True logFolder 121 | r <- liftIO $ createProcess $ (shell expr){std_in=CreatePipe,std_err=CreatePipe,std_out=CreatePipe} 122 | 123 | time <- liftIO $ getCurrentTime 124 | let header= expr ++" "++ show time 125 | abduce 126 | labelState $ BSS.pack header 127 | 128 | 129 | onException $ \(e :: SomeException) -> do 130 | liftIO $ do 131 | print ("watch:",e) 132 | cleanupProcess r 133 | atomicModifyIORef rinput $ \map -> (M.delete header map,()) 134 | empty 135 | 136 | let logfile= logFileName header 137 | let box= "output" ++ header 138 | liftIO $ atomicModifyIORef rinput $ \map -> (M.insert header (input1 r) map,()) 139 | 140 | line <- async (return header) <|> watch (output r) <|> watch (err r) <|> watchExitError r 141 | 142 | putMailbox' box line 143 | 144 | hlog <- liftIO $ openFile logfile AppendMode 145 | liftIO $ hPutStrLn hlog line 146 | liftIO $ hClose hlog 147 | return line 148 | 149 | where 150 | 151 | input1 r= inp where (Just inp,_,_,_)= r 152 | output r= out where (_,Just out,_,_)= r 153 | err r= err where (_,_,Just err,_)= r 154 | handle r= h where (_,_,_,h)= r 155 | 156 | watch :: Handle -> TransIO String 157 | watch h = do 158 | abduce 159 | mline <- threads 0 $ (parallel $ (SMore <$> hGetLine' h) `catch` \(e :: SomeException) -> return SDone) 160 | case mline of 161 | SDone -> empty 162 | SError e -> do liftIO $ print ("watch:",e); empty 163 | SMore line -> return line 164 | 165 | where 166 | 167 | hGetLine' h= do 168 | buff <- newIORef [] 169 | getMore buff 170 | 171 | where 172 | 173 | getMore buff= do 174 | b <- hWaitForInput h 10 175 | if not b 176 | then do 177 | r <-readIORef buff 178 | if null r then getMore buff else return r 179 | else do 180 | c <- hGetChar h 181 | if c == '\n' then readIORef buff else do 182 | modifyIORef buff $ \str -> str ++ [c] 183 | getMore buff 184 | 185 | watchExitError r= do -- make it similar to watch 186 | abduce 187 | liftIO $ waitForProcess $ handle r 188 | errors <- liftIO $ hGetContents (err r) 189 | return errors 190 | 191 | 192 | rinput= unsafePerformIO $ newIORef M.empty -------------------------------------------------------------------------------- /buildrun.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | ghcjs -j2 -isrc -i../transient/src -i../transient-universe/src -i../ghcjs-hplay/src -i../ghcjs-perch/src $1 -o static/out 4 | runghc -j2 -isrc -i../transient/src -i../transient-universe/src -i../ghcjs-hplay/src -i../ghcjs-perch/src $1 $2 $3 $4 5 | -------------------------------------------------------------------------------- /circle.yml: -------------------------------------------------------------------------------- 1 | machine: 2 | environment: 3 | GHC: 8.0.1 4 | CABAL: 1.24 5 | NODE: 6.9.1 6 | ARGS: --stack-yaml stack-ghcjs.yaml 7 | PATH: $HOME/.local/bin:$PATH 8 | 9 | dependencies: 10 | cache_directories: 11 | - ~/.ghc 12 | - ~/.cabal 13 | - ~/.stack 14 | - ~/.ghcjs 15 | - ~/.local/bin 16 | pre: 17 | - cabal update 18 | - cabal install hsc2hs 19 | - mkdir -p ~/.local/bin 20 | - curl -L https://www.stackage.org/stack/linux-x86_64 \ 21 | | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 22 | - nvm install $NODE 23 | override: 24 | - stack --no-terminal setup $ARGS 25 | 26 | test: 27 | pre: 28 | - stack --no-terminal $ARGS test --only-dependencies 29 | override: 30 | - stack --no-terminal test $ARGS 31 | - stack --no-terminal haddock --no-haddock-deps $ARGS 32 | -------------------------------------------------------------------------------- /examples/distributedApps.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, NoMonomorphismRestriction, DeriveDataTypeable #-} 2 | 3 | module Main where 4 | 5 | import Prelude hiding (div,id) 6 | import Transient.Internals 7 | 8 | 9 | 10 | import GHCJS.HPlay.Cell 11 | import GHCJS.HPlay.View 12 | #ifdef ghcjs_HOST_OS 13 | hiding (map, input,option) 14 | #else 15 | hiding (map, option,input) 16 | #endif 17 | 18 | 19 | import Transient.Move 20 | import Transient.EVars 21 | import Transient.Indeterminism 22 | 23 | import Control.Applicative 24 | import qualified Data.Vector as V 25 | import qualified Data.Map as M 26 | import Transient.MapReduce 27 | import Control.Monad.IO.Class 28 | import Data.String 29 | import qualified Data.Text as T 30 | 31 | #ifdef ghcjs_HOST_OS 32 | import qualified Data.JSString as JS hiding (span,empty,strip,words) 33 | #endif 34 | 35 | import Data.Typeable 36 | 37 | 38 | 39 | 40 | 41 | data Options= MapReduce | Chat | MonitorNodes | AllThree deriving (Typeable, Read, Show) 42 | 43 | main = keep' $ initNode $ inputNodes <|> menuApp <|> thelink 44 | 45 | -- thelink :: Cloud () 46 | thelink= do 47 | local . render $ rawHtml $ do 48 | br;br 49 | a ! href (fs "https://github.com/agocorona/transient-universe/blob/master/examples/distributedApps.hs") $ "source code" 50 | 51 | -- menuApp :: Cloud () 52 | menuApp= do 53 | local . render . rawHtml $ do 54 | h1 "Transient Demo" 55 | br; br 56 | op <- local . render $ 57 | wlink MapReduce (b "map-reduce") <++ fs " " <|> 58 | wlink Chat (b "chat") <++ fs " " <|> 59 | wlink MonitorNodes (b "monitor nodes") <++ fs " " <|> 60 | wlink AllThree (b "all widgets") 61 | 62 | case op of 63 | AllThree -> allw 64 | MapReduce -> mapReduce 65 | Chat -> chat 66 | MonitorNodes -> monitorNodes 67 | 68 | -- allw :: Cloud () 69 | allw= mapReduce <|> chat <|> monitorNodes 70 | 71 | 72 | 73 | 74 | -- A Web node launch a map-reduce computation in all the server nodes, getting data from a 75 | -- textbox and render the results returned 76 | 77 | -- mapReduce :: Cloud () 78 | mapReduce= onBrowser $ do 79 | 80 | content <- local . render $ 81 | h1 "Map-Reduce widget" ++> 82 | p "Return the frequencies of words from a text using all the server nodes connected" ++> 83 | textArea (fs "") ! atr "placeholder" (fs "enter the content") 84 | ! atr "rows" (fs "4") 85 | ! atr "cols" (fs "80") 86 | <++ br 87 | <** inputSubmit "send" `fire` OnClick 88 | <++ br 89 | 90 | r <- atRemote $ do 91 | lliftIO $ print content 92 | r<- reduce (+) . mapKeyB (\w -> (w, 1 :: Int)) $ distribute $ V.fromList $ words content 93 | lliftIO $ putStr "result:" >> print r 94 | return (r :: M.Map String Int) 95 | 96 | 97 | local . render $ rawHtml $ do 98 | h1 "Results" 99 | mconcat[i "word " >> b w >> i " appears " >> b n >> i " times" >> br 100 | | (w,n) <- M.assocs r] 101 | 102 | empty 103 | 104 | fs= fromString 105 | 106 | -- a chat widget that run in the browser and in a cloud of servers 107 | 108 | -- chat :: Cloud () 109 | chat = do 110 | 111 | let chatMessages= fs "chatMessages" 112 | 113 | local . render . rawHtml $ do 114 | h1 "Federated chat server" 115 | div ! id (fs "chatbox") 116 | ! style (fs $"overflow: auto;height: 200px;" 117 | ++ "background-color: #FFCC99; max-height: 200px;") 118 | $ noHtml -- create the chat box 119 | 120 | sendMessages chatMessages <|> waitMessages chatMessages 121 | 122 | where 123 | 124 | -- sendMessages :: Text -> Cloud () 125 | sendMessages chatMessages = do 126 | -- node <- atRemote $ local getMyNode 127 | let entry= boxCell (fs "msg") ! atr "size" (fs "60") 128 | (nick,text) <- local . render $ (,) <$> getString (Just "anonymous") ! size (fs "10") 129 | <*> mk entry Nothing `fire` OnChange 130 | <** inputSubmit "send" 131 | <++ br 132 | local $ entry .= "" 133 | 134 | atRemote $ do 135 | node <- local getMyNode 136 | 137 | clustered $ local $ putMailbox chatMessages (showPrompt nick node ++ text ) >> empty :: Cloud () 138 | empty 139 | 140 | where 141 | fs= fromString 142 | size= atr (fs "size") 143 | showPrompt u (Node h p _ _)= u ++ "@" ++ h ++ ":" ++ show p ++ "> " 144 | 145 | -- waitMessages :: Text -> Cloud () 146 | waitMessages chatMessages = do 147 | 148 | resp <- atRemote . local $ single $ getMailbox chatMessages 149 | -- wait in the server for messages 150 | 151 | local . render . at (fs "#chatbox") Append $ rawHtml $ do 152 | p (resp :: String) -- display the response 153 | #ifdef ghcjs_HOST_OS 154 | liftIO $ scrollBottom $ fs "chatbox" 155 | 156 | 157 | foreign import javascript unsafe 158 | "var el= document.getElementById($1);el.scrollTop= el.scrollHeight" 159 | scrollBottom :: JS.JSString -> IO() 160 | #endif 161 | 162 | -- monitorNodes :: Cloud () 163 | monitorNodes= do 164 | local . render $ rawHtml $ do 165 | h1 "Nodes connected" 166 | div ! atr (fs "id") (fs "nodes") $ noHtml 167 | 168 | nodes <- atRemote . local $ single $ sample getNodes 1000000 169 | 170 | local . render . at (fs "#nodes") Insert . rawHtml $ 171 | table $ mconcat[tr $ td h >> td p >> td s | Node h p _ s <- nodes] 172 | empty 173 | 174 | 175 | 176 | 177 | 178 | 179 | 180 | 181 | -------------------------------------------------------------------------------- /examples/runweb2.sh: -------------------------------------------------------------------------------- 1 | stack --resolver lts-7.14 --allow-different-user --install-ghc --compiler ghcjs-0.1.0.20150924_ghc-7.10.2 ghc $1 --package ghcjs-hplay --package ghcjs-perch --package transient --package transient-universe -- -o static/out 2 | stack --resolver lts-7.14 --allow-different-user --install-ghc runghc $1 --package ghcjs-hplay --package ghcjs-perch --package transient --package transient-universe -- -p start/localhost/8080 3 | -------------------------------------------------------------------------------- /execthirdlinedocker.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | command=`sed -n '3p' ${1} | sed 's/-- //'` 3 | echo $command 4 | if [ -f /.dockerenv ]; then 5 | eval $command $1 $2 $3 $4 6 | else 7 | set -e && port=`echo ${3} | awk -F/ '{print $(3)}'` && docker run -it -p ${port}:${port} -v $(pwd):/work agocorona/transient:22-05-2018 bash -c "cd /work && $1 $2 $3 $4" 8 | fi 9 | -------------------------------------------------------------------------------- /loop.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | COUNTER=0 3 | while [ true ]; do 4 | echo $1 $COUNTER 5 | let COUNTER=COUNTER+1 6 | sleep 4 7 | done 8 | -------------------------------------------------------------------------------- /src/Transient/MapReduce.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification, DeriveDataTypeable 2 | , FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, CPP #-} 3 | 4 | 5 | module Transient.MapReduce 6 | ( 7 | Distributable(..),distribute, getText, 8 | getUrl, getFile,textUrl, textFile, 9 | mapKeyB, mapKeyU, reduce,eval, 10 | --v* internals 11 | DDS(..),Partition(..),PartRef(..)) 12 | where 13 | 14 | #ifdef ghcjs_HOST_OS 15 | import Transient.Base 16 | import Transient.Move hiding (pack) 17 | import Transient.Logged 18 | -- dummy Transient.MapReduce module, 19 | reduce _ _ = local stop :: Loggable a => Cloud a 20 | mapKeyB _ _= undefined 21 | mapKeyU _ _= undefined 22 | distribute _ = undefined 23 | getText _ _ = undefined 24 | textFile _ = undefined 25 | getUrl _ _ = undefined 26 | textUrl _ = undefined 27 | getFile _ _ = undefined 28 | eval _= local stop 29 | data Partition 30 | data DDS= DDS 31 | class Distributable 32 | data PartRef a=PartRef a 33 | 34 | #else 35 | 36 | import Transient.Internals hiding (Ref) 37 | 38 | import Transient.Move.Internals hiding (pack) 39 | import Transient.Indeterminism 40 | import Control.Applicative 41 | import System.Random 42 | import Control.Monad.State 43 | 44 | import Control.Monad 45 | import Data.Monoid 46 | 47 | import Data.Typeable 48 | import Data.List hiding (delete, foldl') 49 | import Control.Exception 50 | import Control.Concurrent 51 | --import Data.Time.Clock 52 | import Network.HTTP 53 | import Data.TCache hiding (onNothing) 54 | import Data.TCache.Defs 55 | 56 | import Data.ByteString.Lazy.Char8 (pack,unpack) 57 | import qualified Data.Map.Strict as M 58 | import Control.Arrow (second) 59 | import qualified Data.Vector.Unboxed as DVU 60 | import qualified Data.Vector as DV 61 | import Data.Hashable 62 | import System.IO.Unsafe 63 | 64 | import qualified Data.Foldable as F 65 | import qualified Data.Text as Text 66 | import Data.IORef 67 | 68 | data DDS a= Loggable a => DDS (Cloud (PartRef a)) 69 | data PartRef a= Ref Node Path Save deriving (Typeable, Read, Show) 70 | data Partition a= Part Node Path Save a deriving (Typeable,Read,Show) 71 | type Save= Bool 72 | 73 | 74 | instance Indexable (Partition a) where 75 | key (Part _ string b _)= keyp string b 76 | 77 | 78 | 79 | keyp s True= "PartP@"++s :: String 80 | keyp s False="PartT@"++s 81 | 82 | instance Loggable a => IResource (Partition a) where 83 | keyResource= key 84 | readResourceByKey k= r 85 | where 86 | typePart :: IO (Maybe a) -> a 87 | typePart = undefined 88 | r = if k !! 4 /= 'P' then return Nothing else 89 | defaultReadByKey (defPath (typePart r) ++ k) >>= return . fmap ( read . unpack) 90 | writeResource (s@(Part _ _ save _))= 91 | unless (not save) $ defaultWrite (defPath s ++ key s) (pack $ show s) 92 | 93 | 94 | eval :: DDS a -> Cloud (PartRef a) 95 | eval (DDS mx) = mx 96 | 97 | 98 | type Path=String 99 | 100 | 101 | instance F.Foldable DVU.Vector where 102 | {-# INLINE foldr #-} 103 | foldr = foldr 104 | 105 | {-# INLINE foldl #-} 106 | foldl = foldl 107 | 108 | {-# INLINE foldr1 #-} 109 | foldr1 = foldr1 110 | 111 | {-# INLINE foldl1 #-} 112 | foldl1 = foldl1 113 | 114 | --foldlIt' :: V.Unbox a => (b -> a -> b) -> b -> V.Vector a -> b 115 | --foldlIt' f z0 xs= V.foldr f' id xs z0 116 | -- where f' x k z = k $! f z x 117 | -- 118 | --foldlIt1 :: V.Unbox a => (a -> a -> a) -> V.Vector a -> a 119 | --foldlIt1 f xs = fromMaybe (error "foldl1: empty structure") 120 | -- (V.foldl mf Nothing xs) 121 | -- where 122 | -- mf m y = Just (case m of 123 | -- Nothing -> y 124 | -- Just x -> f x y) 125 | 126 | class (F.Foldable c, Typeable c, Typeable a, Monoid (c a), Loggable (c a)) => Distributable c a where 127 | singleton :: a -> c a 128 | splitAt :: Int -> c a -> (c a, c a) 129 | fromList :: [a] -> c a 130 | 131 | 132 | instance (Loggable a) => Distributable DV.Vector a where 133 | singleton = DV.singleton 134 | splitAt= DV.splitAt 135 | fromList = DV.fromList 136 | 137 | instance (Loggable a,DVU.Unbox a) => Distributable DVU.Vector a where 138 | singleton= DVU.singleton 139 | splitAt= DVU.splitAt 140 | fromList= DVU.fromList 141 | 142 | 143 | 144 | 145 | -- | perform a map and partition the result with different keys using boxed vectors 146 | -- The final result will be used by reduce. 147 | mapKeyB :: (Loggable a, Loggable b, Loggable k,Ord k) 148 | => (a -> (k,b)) 149 | -> DDS (DV.Vector a) 150 | -> DDS (M.Map k(DV.Vector b)) 151 | mapKeyB= mapKey 152 | 153 | -- | perform a map and partition the result with different keys using unboxed vectors 154 | -- The final result will be used by reduce. 155 | mapKeyU :: (Loggable a, DVU.Unbox a, Loggable b, DVU.Unbox b, Loggable k,Ord k) 156 | => (a -> (k,b)) 157 | -> DDS (DVU.Vector a) 158 | -> DDS (M.Map k(DVU.Vector b)) 159 | mapKeyU= mapKey 160 | 161 | -- | perform a map and partition the result with different keys. 162 | -- The final result will be used by reduce. 163 | mapKey :: (Distributable vector a,Distributable vector b, Loggable k,Ord k) 164 | => (a -> (k,b)) 165 | -> DDS (vector a) 166 | -> DDS (M.Map k (vector b)) 167 | mapKey f (DDS mx)= DDS $ loggedc $ do 168 | refs <- mx 169 | process refs -- !> ("process",refs) 170 | 171 | where 172 | -- process :: Partition a -> Cloud [Partition b] 173 | process (ref@(Ref node path sav))= runAt node $ local $ do 174 | xs <- getPartitionData ref -- !> ("CMAP", ref,node) 175 | (generateRef $ map1 f xs) 176 | 177 | 178 | 179 | -- map1 :: (Ord k, F.Foldable vector) => (a -> (k,b)) -> vector a -> M.Map k(vector b) 180 | map1 f v= F.foldl' f1 M.empty v 181 | where 182 | f1 map x= 183 | let (k,r) = f x 184 | in M.insertWith (<>) k (Transient.MapReduce.singleton r) map 185 | 186 | 187 | 188 | data ReduceChunk a= EndReduce | Reduce a deriving (Typeable, Read, Show) 189 | 190 | boxids= unsafePerformIO $ newIORef (0 :: Int) 191 | 192 | 193 | reduce :: (Hashable k,Ord k, Distributable vector a, Loggable k,Loggable a) 194 | => (a -> a -> a) -> DDS (M.Map k (vector a)) ->Cloud (M.Map k a) 195 | 196 | reduce red (dds@(DDS mx))= loggedc $ do 197 | 198 | mboxid <- localIO $ atomicModifyIORef boxids $ \n -> let n'= n+1 in (n',n') 199 | nodes <- local getEqualNodes 200 | 201 | let lengthNodes = length nodes 202 | shuffler nodes = do 203 | localIO $ threadDelay 100000 204 | ref@(Ref node path sav) <- mx -- return the resulting blocks of the map 205 | 206 | runAt node $ foldAndSend node nodes ref 207 | 208 | stop 209 | 210 | -- groupByDestiny :: (Hashable k, Distributable vector a) => M.Map k (vector a) -> M.Map Int [(k ,vector a)] 211 | groupByDestiny map = M.foldlWithKey' f M.empty map 212 | where 213 | -- f :: M.Map Int [(k ,vector a)] -> k -> vector a -> M.Map Int [(k ,vector a)] 214 | f map k vs= M.insertWith (<>) (hash1 k) [(k,vs)] map 215 | hash1 k= abs $ hash k `rem` length nodes 216 | 217 | 218 | -- foldAndSend :: (Hashable k, Distributable vector a)=> (Int,[(k,vector a)]) -> Cloud () 219 | foldAndSend node nodes ref= do 220 | 221 | pairs <- onAll $ getPartitionData1 ref 222 | <|> return (error $ "DDS computed out of his node:"++ show ref ) 223 | let mpairs = groupByDestiny pairs 224 | 225 | length <- local . return $ M.size mpairs 226 | 227 | let port2= nodePort node 228 | 229 | 230 | if length == 0 then sendEnd nodes else do 231 | 232 | nsent <- onAll $ liftIO $ newMVar 0 233 | 234 | (i,folded) <- local $ parallelize foldthem (M.assocs mpairs) 235 | 236 | n <- localIO $ modifyMVar nsent $ \r -> return (r+1, r+1) 237 | 238 | (runAt (nodes !! i) $ local $ putMailbox' mboxid (Reduce folded)) 239 | !> ("SENDDDDDDDDDDDDDDDDDDDDDDD",n,length,i,folded) 240 | 241 | -- return () !> (port,n,length) 242 | 243 | when (n == length) $ sendEnd nodes 244 | empty 245 | 246 | where 247 | 248 | 249 | foldthem (i,kvs)= async . return 250 | $ (i,map (\(k,vs) -> (k,foldl1 red vs)) kvs) 251 | 252 | 253 | sendEnd nodes = onNodes nodes $ local $ do 254 | node <- getMyNode 255 | putMailbox' mboxid (EndReduce `asTypeOf` paramOf dds) 256 | !> ("SEEEEEEEEEEEEEEEEEEEEEEEEND ENDREDUCE FROM", node) 257 | 258 | 259 | onNodes nodes f = foldr (<|>) empty $ map (\n -> runAt n f) nodes 260 | 261 | sumNodes nodes f= do foldr (<>) mempty $ map (\n -> runAt n f) nodes 262 | 263 | reducer nodes= sumNodes nodes reduce1 -- a reduce1 process in each node, get the results and mappend them 264 | 265 | -- reduce :: (Ord k) => Cloud (M.Map k v) 266 | 267 | reduce1 = local $ do 268 | reduceResults <- liftIO $ newMVar M.empty 269 | numberSent <- liftIO $ newMVar 0 270 | 271 | minput <- getMailbox' mboxid -- get the chunk once it arrives to the mailbox 272 | 273 | case minput of 274 | 275 | EndReduce -> do 276 | 277 | n <- liftIO $ modifyMVar numberSent $ \r -> let r'= r+1 in return (r', r') 278 | 279 | 280 | if n == lengthNodes 281 | !> ("END REDUCE RECEIVEDDDDDDDDDDDDDDDDDDDDDDDDDD",n, lengthNodes) 282 | then do 283 | cleanMailbox' mboxid (EndReduce `asTypeOf` paramOf dds) 284 | r <- liftIO $ readMVar reduceResults 285 | rem <- getState <|> return NoRemote 286 | return r !> ("RETURNING",r,rem) 287 | 288 | else stop 289 | 290 | Reduce kvs -> do 291 | let addIt (k,inp) = do 292 | let input= inp `asTypeOf` atype dds 293 | liftIO $ modifyMVar_ reduceResults 294 | $ \map -> do 295 | let maccum = M.lookup k map 296 | return $ M.insert k (case maccum of 297 | Just accum -> red input accum 298 | Nothing -> input) map 299 | 300 | mapM addIt (kvs `asTypeOf` paramOf' dds) 301 | !> ("RECEIVED REDUCEEEEEEEEEEEEE",kvs) 302 | stop 303 | 304 | 305 | reducer nodes <|> shuffler nodes 306 | where 307 | atype ::DDS(M.Map k (vector a)) -> a 308 | atype = undefined -- type level 309 | 310 | paramOf :: DDS (M.Map k (vector a)) -> ReduceChunk [( k, a)] 311 | paramOf = undefined -- type level 312 | paramOf' :: DDS (M.Map k (vector a)) -> [( k, a)] 313 | paramOf' = undefined -- type level 314 | 315 | 316 | 317 | 318 | -- parallelize :: Loggable b => (a -> Cloud b) -> [a] -> Cloud b 319 | parallelize f xs = foldr (<|>) empty $ map f xs 320 | 321 | mparallelize f xs = loggedc $ foldr (<>) mempty $ map f xs 322 | 323 | 324 | getPartitionData :: Loggable a => PartRef a -> TransIO a 325 | getPartitionData (Ref node path save) = Transient $ do 326 | mp <- (liftIO $ atomically 327 | $ readDBRef 328 | $ getDBRef 329 | $ keyp path save) 330 | `onNothing` error ("not found DDS data: "++ keyp path save) 331 | case mp of 332 | (Part _ _ _ xs) -> return $ Just xs 333 | 334 | getPartitionData1 :: Loggable a => PartRef a -> TransIO a 335 | getPartitionData1 (Ref node path save) = Transient $ do 336 | mp <- liftIO $ atomically 337 | $ readDBRef 338 | $ getDBRef 339 | $ keyp path save 340 | 341 | case mp of 342 | Just (Part _ _ _ xs) -> return $ Just xs 343 | Nothing -> return Nothing 344 | 345 | getPartitionData2 :: Loggable a => PartRef a -> IO a 346 | getPartitionData2 (Ref node path save) = do 347 | mp <- ( atomically 348 | $ readDBRef 349 | $ getDBRef 350 | $ keyp path save) 351 | `onNothing` error ("not found DDS data: "++ keyp path save) 352 | case mp of 353 | (Part _ _ _ xs) -> return xs 354 | 355 | -- en caso de fallo de Node, se lanza un clustered en busca del path 356 | -- si solo uno lo tiene, se copia a otro 357 | -- se pone ese nodo de referencia en Part 358 | runAtP :: Loggable a => Node -> (Path -> IO a) -> Path -> Cloud a 359 | runAtP node f uuid= do 360 | r <- runAt node $ onAll . liftIO $ (SLast <$> f uuid) `catch` sendAnyError 361 | case r of 362 | SLast r -> return r 363 | SError e -> do 364 | nodes <- mclustered $ search uuid 365 | when(length nodes < 1) $ asyncDuplicate node uuid 366 | runAtP ( head nodes) f uuid 367 | 368 | search uuid= error $ "chunk failover not yet defined. Lookin for: "++ uuid 369 | 370 | asyncDuplicate node uuid= do 371 | forkTo node 372 | nodes <- onAll getEqualNodes 373 | let node'= head $ nodes \\ [node] 374 | content <- onAll . liftIO $ readFile uuid 375 | runAt node' $ local $ liftIO $ writeFile uuid content 376 | 377 | sendAnyError :: SomeException -> IO (StreamData a) 378 | sendAnyError e= return $ SError e 379 | 380 | 381 | -- | distribute a vector of values among many nodes. 382 | -- If the vector is static and sharable, better use the get* primitives 383 | -- since each node will load the data independently. 384 | distribute :: (Loggable a, Distributable vector a ) => vector a -> DDS (vector a) 385 | distribute = DDS . distribute' 386 | 387 | distribute' xs= loggedc $ do 388 | nodes <- local getEqualNodes -- !> "DISTRIBUTE" 389 | let lnodes = length nodes 390 | let size= case F.length xs `div` (length nodes) of 0 ->1 ; n -> n 391 | xss= split size lnodes 1 xs -- !> size 392 | r <- distribute'' xss nodes 393 | return r 394 | where 395 | split n s s' xs | s==s' = [xs] 396 | split n s s' xs= 397 | let (h,t)= Transient.MapReduce.splitAt n xs 398 | in h : split n s (s'+1) t 399 | 400 | distribute'' :: (Loggable a, Distributable vector a) 401 | => [vector a] -> [Node] -> Cloud (PartRef (vector a)) 402 | distribute'' xss nodes = 403 | parallelize move $ zip nodes xss -- !> show xss 404 | where 405 | move (node, xs)= runAt node $ local $ do 406 | par <- generateRef xs 407 | return par 408 | -- !> ("move", node,xs) 409 | 410 | -- | input data from a text that must be static and shared by all the nodes. 411 | -- The function parameter partition the text in words 412 | getText :: (Loggable a, Distributable vector a) => (String -> [a]) -> String -> DDS (vector a) 413 | getText part str= DDS $ loggedc $ do 414 | nodes <- local getEqualNodes -- !> "getText" 415 | 416 | return () !> ("DISTRIBUTE TEXT IN NODES:",nodes) 417 | let lnodes = length nodes 418 | 419 | parallelize (process lnodes) $ zip nodes [0..lnodes-1] 420 | where 421 | 422 | process lnodes (node,i)= 423 | runAt node $ local $ do 424 | let xs = part str 425 | size= case length xs `div` lnodes of 0 ->1 ; n -> n 426 | xss= Transient.MapReduce.fromList $ 427 | if i== lnodes-1 then drop (i* size) xs else take size $ drop (i * size) xs 428 | generateRef xss 429 | 430 | -- | get the worlds of an URL 431 | textUrl :: String -> DDS (DV.Vector Text.Text) 432 | textUrl= getUrl (map Text.pack . words) 433 | 434 | -- | generate a DDS from the content of a URL. 435 | -- The first parameter is a function that divide the text in words 436 | getUrl :: (Loggable a, Distributable vector a) => (String -> [a]) -> String -> DDS (vector a) 437 | getUrl partitioner url= DDS $ do 438 | nodes <- local getEqualNodes -- !> "DISTRIBUTE" 439 | let lnodes = length nodes 440 | 441 | parallelize (process lnodes) $ zip nodes [0..lnodes-1] -- !> show xss 442 | where 443 | process lnodes (node,i)= runAt node $ local $ do 444 | r <- liftIO . simpleHTTP $ getRequest url 445 | body <- liftIO $ getResponseBody r 446 | let xs = partitioner body 447 | size= case length xs `div` lnodes of 0 ->1 ; n -> n 448 | xss= Transient.MapReduce.fromList $ 449 | if i== lnodes-1 then drop (i* size) xs else take size $ drop (i * size) xs 450 | 451 | generateRef xss 452 | 453 | 454 | -- | get the words of a file 455 | textFile :: String -> DDS (DV.Vector Text.Text) 456 | textFile= getFile (map Text.pack . words) 457 | 458 | -- | generate a DDS from a file. All the nodes must access the file with the same path 459 | -- the first parameter is the parser that generates elements from the content 460 | getFile :: (Loggable a, Distributable vector a) => (String -> [a]) -> String -> DDS (vector a) 461 | getFile partitioner file= DDS $ do 462 | nodes <- local getEqualNodes -- !> "DISTRIBUTE" 463 | let lnodes = length nodes 464 | 465 | parallelize (process lnodes) $ zip nodes [0..lnodes-1] -- !> show xss 466 | where 467 | process lnodes (node, i)= runAt node $ local $ do 468 | content <- do 469 | c <- liftIO $ readFile file 470 | length c `seq` return c 471 | let xs = partitioner content 472 | 473 | size= case length xs `div` lnodes of 0 ->1 ; n -> n 474 | xss= Transient.MapReduce.fromList $ 475 | if i== lnodes-1 then drop (i* size) xs else take size $ drop (i * size) xs 476 | 477 | generateRef xss 478 | 479 | 480 | 481 | generateRef :: Loggable a => a -> TransIO (PartRef a) 482 | generateRef x= do 483 | node <- getMyNode 484 | liftIO $ do 485 | temp <- getTempName 486 | let reg= Part node temp False x 487 | atomically $ newDBRef reg 488 | -- syncCache 489 | (return $ getRef reg) -- !> ("generateRef",reg,node) 490 | 491 | getRef (Part n t s x)= Ref n t s 492 | 493 | getTempName :: IO String 494 | getTempName= ("DDS" ++) <$> replicateM 5 (randomRIO ('a','z')) 495 | 496 | 497 | -------------- Distributed Datasource Streams --------- 498 | -- | produce a stream of DDS's that can be map-reduced. Similar to spark streams. 499 | -- each interval of time,a new DDS is produced.(to be tested) 500 | streamDDS 501 | :: (Loggable a, Distributable vector a) => 502 | Int -> IO (StreamData a) -> DDS (vector a) 503 | streamDDS time io= DDS $ do 504 | xs <- local . groupByTime time $ do 505 | r <- parallel io 506 | case r of 507 | SDone -> empty 508 | SLast x -> return [x] 509 | SMore x -> return [x] 510 | SError e -> error $ show e 511 | distribute' $ Transient.MapReduce.fromList xs 512 | 513 | 514 | 515 | 516 | #endif -------------------------------------------------------------------------------- /src/Transient/Move.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Transient.Move 4 | -- Copyright : 5 | -- License : MIT 6 | -- 7 | -- Maintainer : agocorona@gmail.com 8 | -- Stability : 9 | -- Portability : 10 | -- 11 | -- | @transient-universe@ extends the seamless composability of concurrent 12 | -- multi-threaded programs provided by 13 | -- 14 | -- to a multi-node cloud. Distributed concurrent programs are created and 15 | -- composed seamlessly and effortlessly as if they were written for a single 16 | -- node. @transient-universe@ has diverse applications from simple distributed 17 | -- applications to massively parallel and distributed map-reduce problems. If 18 | -- you are considering Apache Spark or Cloud Haskell then transient might be a 19 | -- simpler yet better solution for you. 20 | -- 21 | -- Transient makes it easy to write composable, distributed event driven 22 | -- reactive UI applications with client side and server side code composed 23 | -- freely in the same application. For example, 24 | -- is a transient based 25 | -- unified client and server side web application framework that provides a 26 | -- better programming model and composability compared to frameworks like 27 | -- ReactJS. 28 | -- 29 | -- = Overview 30 | -- 31 | -- The 'Cloud' monad adds the following facilities to complement the 'TransIO' 32 | -- monad: 33 | -- 34 | -- * Create a distributed compute cluster of nodes 35 | -- * Move computations across nodes at any point during computation 36 | -- * Run computations on multiple nodes in parallel 37 | -- 38 | -- = Further Reading 39 | -- 40 | -- * 41 | -- * 42 | -- * 43 | -- 44 | ----------------------------------------------------------------------------- 45 | {-# LANGUAGE CPP #-} 46 | 47 | module Transient.Move( 48 | 49 | -- * Running the Monad 50 | Cloud(..),runCloud, runCloudIO, runCloudIO', 51 | 52 | -- * Node & Cluster Management 53 | -- $cluster 54 | Node(..), 55 | -- ** Creating nodes 56 | Service(), createNodeServ, createNode, createWebNode, 57 | 58 | -- ** Joining the cluster 59 | Transient.Move.Internals.connect, connect', listen, 60 | -- Low level APIs 61 | addNodes, addThisNodeToRemote, shuffleNodes, 62 | --Connection(..), ConnectionData(..), defConnection, 63 | 64 | -- ** Querying nodes 65 | getMyNode, getWebServerNode, getNodes, nodeList, isBrowserInstance, 66 | 67 | 68 | -- * Running Local Computations 69 | local, onAll, lazy, localFix, fixRemote, loggedc, lliftIO, localIO, 70 | 71 | -- * Moving Computations 72 | wormhole, teleport, copyData, fixClosure, 73 | 74 | -- * Running at a Remote Node 75 | beamTo, forkTo, callTo, runAt, atRemote, setSynchronous, syncStream, 76 | 77 | -- * Running at Multiple Nodes 78 | clustered, mclustered, callNodes, 79 | 80 | -- * Messaging 81 | putMailbox, putMailbox',getMailbox,getMailbox',cleanMailbox,cleanMailbox', 82 | 83 | -- * Thread Control 84 | single, unique, 85 | 86 | #ifndef ghcjs_HOST_OS 87 | -- * Buffering Control 88 | setBuffSize, getBuffSize, 89 | #endif 90 | 91 | #ifndef ghcjs_HOST_OS 92 | -- * REST API 93 | api, HTTPMethod(..), PostParams, 94 | #endif 95 | ) where 96 | 97 | import Transient.Move.Internals 98 | 99 | -- $cluster 100 | -- 101 | -- To join the cluster a node 'connect's to a well known node already part of 102 | -- the cluster. 103 | -- 104 | -- @ 105 | -- import Transient.Move (runCloudIO, lliftIO, createNode, connect, getNodes, onAll) 106 | -- 107 | -- main = runCloudIO $ do 108 | -- this <- lliftIO (createNode "192.168.1.2" 8000) 109 | -- master <- lliftIO (createNode "192.168.1.1" 8000) 110 | -- connect this master 111 | -- onAll getNodes >>= lliftIO . putStrLn . show 112 | -- @ 113 | -- 114 | -------------------------------------------------------------------------------- /src/Transient/Move/Services.hs: -------------------------------------------------------------------------------- 1 | 2 | ----------------------------------------------------------------------------- 3 | -- 4 | -- Module : Transient.Move.Services 5 | -- Copyright : 6 | -- License : MIT 7 | -- 8 | -- Maintainer : agocorona@gmail.com 9 | -- Stability : 10 | -- Portability : 11 | -- 12 | -- | 13 | -- 14 | ----------------------------------------------------------------------------- 15 | {-# LANGUAGE ScopedTypeVariables, CPP, FlexibleInstances, FlexibleContexts, UndecidableInstances, RecordWildCards, MultiParamTypeClasses #-} 16 | 17 | {- 18 | TODO: 19 | service=[("runsource", "this")] 20 | 21 | send the execution arguments, the source code to all monitors 22 | compile it using the command arguments 23 | find the host:port and set up them for each node 24 | 25 | generate a web interface for each service: 26 | get the type of the argument 27 | parse the type and generate axiom source code. 28 | -} 29 | 30 | 31 | 32 | module Transient.Move.Services( 33 | runService,callService, callService',callServiceFail,serve,ping 34 | , monitorNode, monitorService, setRemoteJob,killRemoteJob 35 | 36 | #ifndef ghcjs_HOST_OS 37 | 38 | ,initService,authorizeService,requestInstance,requestInstanceFail,requestInstanceHost 39 | ,findInNodes,endMonitor,freePort, controlNodeService, controlNode 40 | ,setAuthKey 41 | -- * implementation details 42 | ,GetNodes(..) 43 | ,GetLog (..) 44 | ,ReceiveFromNodeStandardOutput (..) 45 | ,controlToken 46 | #endif 47 | ) where 48 | 49 | import Transient.Internals 50 | import Transient.Logged(maybeFromIDyn,toIDyn,fromIDyn) 51 | import Transient.Move.Internals 52 | import Transient.Move.Utils 53 | 54 | import Control.Monad.State 55 | import System.IO (hFlush,stdout) 56 | import System.IO.Unsafe 57 | import Control.Concurrent.MVar 58 | import Control.Applicative 59 | 60 | import Control.Concurrent(threadDelay) 61 | import Control.Exception hiding(onException) 62 | import Data.IORef 63 | import Control.Monad(when) 64 | import Data.Typeable 65 | import System.Random 66 | import Data.Maybe 67 | import qualified Data.Map as M 68 | import System.Environment 69 | import Data.List(isPrefixOf) 70 | import Unsafe.Coerce 71 | import Data.Monoid 72 | import Data.String 73 | import qualified Data.ByteString.Char8 as BSS 74 | 75 | #ifndef ghcjs_HOST_OS 76 | import System.Directory 77 | import qualified Data.ByteString.Lazy.Char8 as BS 78 | 79 | 80 | import GHC.IO.Handle 81 | #else 82 | import qualified Data.JSString as JS 83 | #endif 84 | 85 | 86 | 87 | #ifndef ghcjs_HOST_OS 88 | import System.Process 89 | #endif 90 | 91 | 92 | 93 | monitorService= [("service","monitor") 94 | ,("executable", "monitorService") 95 | ,("package","https://github.com/transient-haskell/transient-universe")] 96 | 97 | 98 | monitorPort= 3000 99 | 100 | #ifndef ghcjs_HOST_OS 101 | 102 | reInitService :: Node -> Cloud Node 103 | reInitService node= loggedc $ cached <|> installIt 104 | where 105 | cached= local $ do 106 | ns <- findInNodes $ nodeServices node 107 | if null ns then empty 108 | else do 109 | ind <- liftIO $ randomRIO(0,length ns-1) 110 | return $ ns !! ind 111 | installIt= do -- TODO block by service name, to avoid double initializations 112 | ns <- requestInstanceFail node 1 113 | if null ns then empty else return $ head ns 114 | 115 | 116 | -- | initService search for any node in the list of nodes that the local node may know, for that service, instead of calling 117 | -- the monitor. if there is no such node, it request an instance from the monitor `requestInstance`. `initService` is used by `callService` 118 | initService :: Service -> Cloud Node 119 | initService service= loggedc $ cached <|> installed <|> installIt 120 | where 121 | installed= local $ do 122 | --if has host-port key it has been installed manually 123 | host <- emptyIfNothing $ lookup "nodehost" service 124 | port <- emptyIfNothing $ lookup "nodeport" service 125 | node <- liftIO $ createNodeServ host (read' port) service 126 | addNodes [node] 127 | return node 128 | 129 | cached= local $ do 130 | ns <- findInNodes service 131 | if null ns then empty 132 | else do 133 | ind <- liftIO $ randomRIO(0,length ns-1) 134 | return $ ns !! ind 135 | 136 | installIt= do -- TODO block by service name, to avoid double initializations 137 | ns <- requestInstance service 1 138 | if null ns then empty else return $ head ns 139 | 140 | -- | receives the specification of a service and install (if necessary) and run it (if necessary) 141 | -- if the servi ce has been started previously, it returns the node immediately. 142 | -- if the monitor service executable is not running `requestInstace` initiates it. 143 | -- Instances are provisioned among the available nodes 144 | -- The returned nodes are added to the list of known nodes. 145 | 146 | requestInstance :: Service -> Int -> Cloud [Node] 147 | requestInstance service num= loggedc $ do 148 | local $ onException $ \(e:: ConnectionError) -> do 149 | liftIO $ putStrLn "Monitor was not running. STARTING MONITOR for this machine" 150 | continue 151 | startMonitor 152 | 153 | ident <- localIO $ readIORef rkey 154 | nodes <- callService' monitorNode (ident,service, num ) 155 | local $ addNodes nodes -- !> ("ADDNODES",service) 156 | return nodes 157 | 158 | requestInstanceHost :: String -> Service -> Cloud Node 159 | requestInstanceHost hostname service= do 160 | monitorHost <- localIO $ createNodeServ hostname 161 | (fromIntegral monitorPort) 162 | monitorService 163 | 164 | ident <- localIO $ readIORef rkey 165 | nodes@[node] <- callService' monitorHost (ident,service, 1::Int) 166 | local $ addNodes nodes 167 | return node 168 | 169 | requestInstanceFail :: Node -> Int -> Cloud [Node] 170 | requestInstanceFail node num= loggedc $ do 171 | return () !> "REQUEST INSTANCEFAIL" 172 | local $ delNodes [node] 173 | local $ onException $ \(e:: ConnectionError) -> do 174 | liftIO $ putStrLn "Monitor was not running. STARTING MONITOR" 175 | continue 176 | startMonitor !> ("EXCEPTIOOOOOOOOOOON",e) 177 | 178 | ident <- localIO $ readIORef rkey 179 | nodes <- callService' monitorNode (ident,node, num ) !> "CALLSERVICE'" 180 | local $ addNodes nodes !> ("ADDNODES") 181 | return nodes 182 | 183 | 184 | rmonitor= unsafePerformIO $ newMVar () -- to avoid races starting the monitor 185 | startMonitor :: TransIO () 186 | startMonitor = ( liftIO $ do 187 | return () !> "START MONITOR" 188 | b <- tryTakeMVar rmonitor 189 | when (b== Just()) $ do 190 | 191 | r <- findExecutable "monitorService" 192 | when ( r == Nothing) $ error "monitor not found" 193 | (_,_,_,h) <- createProcess $ (shell $ "monitorService -p start/localhost/"++ show monitorPort ++ " > monitor.log 2>&1"){std_in=NoStream} 194 | 195 | writeIORef monitorHandle $ Just h 196 | putMVar rmonitor () 197 | 198 | threadDelay 2000000) 199 | `catcht` \(e :: SomeException) -> do 200 | liftIO $ putStrLn "'monitorService' binary should be in some folder included in the $PATH variable. Computation aborted" 201 | empty 202 | 203 | monitorHandle= unsafePerformIO $ newIORef Nothing 204 | 205 | endMonitor= do 206 | mm <- readIORef monitorHandle 207 | case mm of 208 | Nothing -> return () 209 | Just h -> interruptProcessGroupOf h 210 | 211 | findInNodes :: Service -> TransIO [Node] 212 | findInNodes service = do 213 | return () !> "FINDINNODES" 214 | nodes <- getNodes 215 | 216 | return $ filter (\node -> head service == head1 (nodeServices node)) nodes 217 | 218 | where 219 | head1 []= ("","") 220 | head1 x= head x 221 | 222 | 223 | rfriends = unsafePerformIO $ newIORef ([] ::[String]) 224 | rservices = unsafePerformIO $ newIORef ([] ::[Service]) 225 | ridentsBanned = unsafePerformIO $ newIORef ([] ::[String]) 226 | rServicesBanned = unsafePerformIO $ newIORef ([] ::[Service]) 227 | 228 | inputAuthorizations :: Cloud () 229 | inputAuthorizations= onServer $ Cloud $ do 230 | abduce 231 | oneThread $ option "auth" "add authorizations for users and services" 232 | showPerm <|> friends <|> services <|> identBanned <|> servicesBanned 233 | empty 234 | 235 | where 236 | friends= do 237 | option "friends" "friendsss" 238 | fr <- input (const True) "enter the friend list: " 239 | liftIO $ writeIORef rfriends (fr :: [String]) 240 | 241 | services= do 242 | option "services" "services" 243 | serv <- input (const True) "enter service list: " 244 | liftIO $ writeIORef rservices (serv :: [Service]) 245 | 246 | identBanned= do 247 | option "bannedIds" "banned users" 248 | ban <- input (const True) "enter the users banned: " 249 | liftIO $ writeIORef ridentsBanned (ban ::[String ]) 250 | rs <- liftIO $ readIORef ridentsBanned 251 | liftIO $ print rs 252 | 253 | servicesBanned= do 254 | option "bannedServ" "banned services" 255 | ban <- input (const True) "enter the services banned: " 256 | liftIO $ writeIORef rServicesBanned (ban :: [Service]) 257 | 258 | showPerm= do 259 | option "show" "show permissions" 260 | friends <- liftIO $ readIORef rfriends 261 | services <- liftIO $ readIORef rservices 262 | identsBanned <- liftIO $ readIORef ridentsBanned 263 | servicesBanned <- liftIO $ readIORef rServicesBanned 264 | liftIO $ putStr "allowed: " >> print friends 265 | liftIO $ putStr "banned: " >> print identsBanned 266 | liftIO $ putStr "services allowed: " >> print services 267 | liftIO $ putStr "services banned: " >> print servicesBanned 268 | 269 | rfreePort :: MVar Int 270 | rfreePort = unsafePerformIO $ newMVar (monitorPort +2) -- executor use 3001 by default 271 | 272 | freePort :: MonadIO m => m Int 273 | freePort= liftIO $ modifyMVar rfreePort $ \ n -> return (n+1,n) 274 | 275 | 276 | rkey= unsafePerformIO $ newIORef "" 277 | setAuthKey key= liftIO $ writeIORef rkey key 278 | 279 | authorizeService :: MonadIO m => String -> Service -> m Bool 280 | authorizeService ident service= do 281 | 282 | friends <- liftIO $ readIORef rfriends 283 | services <- liftIO $ readIORef rservices 284 | identsBanned <- liftIO $ readIORef ridentsBanned 285 | servicesBanned <- liftIO $ readIORef rServicesBanned 286 | 287 | return $ if (null friends || ident `elem` friends) 288 | && (null services || service `elem` services) 289 | && (null identsBanned || ident `notElem` identsBanned) 290 | && (null servicesBanned || service `notElem` servicesBanned) 291 | then True else False 292 | where 293 | notElem a b= not $ elem a b 294 | 295 | 296 | runEmbeddedService :: (Loggable a, Loggable b) => Service -> (a -> Cloud b) -> Cloud b 297 | runEmbeddedService servname serv = do 298 | node <- localIO $ do 299 | port <- freePort 300 | createNodeServ "localhost" (fromIntegral port) servname 301 | listen node 302 | wormhole (notused 4) $ loggedc $ do 303 | x <- local $ return (notused 0) 304 | r <- onAll $ runCloud (serv x) <** setData WasRemote 305 | local $ return r 306 | teleport 307 | return r 308 | 309 | #endif 310 | 311 | -- | call a service. If the service is not running in some node, the monitor service would install 312 | -- and run it. The first parameter is a weak password. 313 | 314 | #ifndef ghcjs_HOST_OS 315 | callService 316 | :: (Subst1 a String,Loggable a,Loggable1 a, Loggable1 b,Loggable b) 317 | => Service -> a -> Cloud b 318 | callService service params = loggedc $ do 319 | 320 | node <- initService service !> ("callservice initservice", service) 321 | let type1 = fromMaybe "" $ lookup "type" service 322 | if type1=="HTTP" 323 | then do 324 | callstr <- local $ emptyIfNothing $ lookup "HTTPstr" service 325 | callRestService node callstr params 326 | else callService' node params !> ("NODE FOR SERVICE",node) 327 | #else 328 | callService 329 | :: (Loggable a, Loggable b) 330 | => Service -> a -> Cloud b 331 | callService service params = local $ empty 332 | #endif 333 | 334 | setRemoteJob :: BSS.ByteString -> Node -> TransIO () 335 | setRemoteJob thid node= do 336 | JobGroup map <- getRState <|> return (JobGroup M.empty) 337 | setRState $ JobGroup $ M.insert thid (node,0) map 338 | 339 | data KillRemoteJob = KillRemoteJob BSS.ByteString deriving (Read,Show, Typeable) 340 | 341 | killRemoteJob :: Node -> BSS.ByteString -> Cloud () 342 | killRemoteJob node thid= callService' node (KillRemoteJob thid) 343 | 344 | 345 | killRemoteJobIt :: KillRemoteJob -> Cloud () 346 | killRemoteJobIt (KillRemoteJob thid)= local $ do 347 | st <- findState match =<< topState 348 | liftIO $ killBranch' st 349 | where 350 | match st= do 351 | (_,lab) <-liftIO $ readIORef $ labelth st 352 | return $ if lab == thid then True else False 353 | 354 | 355 | -- | notify the the monitor that a node has failed for a service and reclaim another 356 | -- to execute the request. If the service is not running in some node, the monitor service would install 357 | -- and run it. The first parameter is a weak password. 358 | callServiceFail 359 | :: (Loggable a, Loggable b) 360 | => Node -> a -> Cloud b 361 | #ifndef ghcjs_HOST_OS 362 | callServiceFail node params = loggedc $ do 363 | node <- reInitService node 364 | callService' node params 365 | #else 366 | callServiceFail node params = local empty 367 | #endif 368 | 369 | monitorNode= unsafePerformIO $ createNodeServ "localhost" 370 | (fromIntegral monitorPort) 371 | monitorService 372 | 373 | 374 | -- | call a service located in a node 375 | callService' :: (Loggable a, Loggable b) => Node -> a -> Cloud b 376 | #ifndef ghcjs_HOST_OS 377 | callService' node params = r 378 | where 379 | r= loggedc $ do 380 | onAll $ abduce 381 | my <- onAll getMyNode -- to force connection when calling himself 382 | if node== my 383 | then do 384 | -- when (node== my) $ 385 | -- liftIO $ modifyMVar_ (fromMaybe (error "callService: no connection") $ connection my) $ const $ return [] 386 | 387 | svs <- onAll $ liftIO $ readIORef selfServices 388 | d <- svs $ toIDyn params 389 | return $ fromIDyn d 390 | else do 391 | 392 | localFixServ True 393 | local $ return () 394 | service 395 | 396 | where 397 | service = do 398 | 399 | 400 | 401 | mr <- wormhole node $ do 402 | 403 | local $ return $ toIDyn params 404 | 405 | teleport 406 | 407 | local empty 408 | 409 | local $ delData ( undefined :: (Bool,Int ,Int ,IORef (M.Map Int Int))) 410 | case maybeFromIDyn mr of 411 | Just x -> return x 412 | Nothing -> error $ "type mismatch calling service (data,input type,expected return type,node/service)= " 413 | ++ show (mr,typeOf params, typeOf(typeof1 r), node) 414 | 415 | 416 | 417 | typeof1 :: Cloud b -> b 418 | typeof1= error "typeof: type level" 419 | 420 | 421 | 422 | -- on exception, callService is called to reclaim a new node to the monitor if necessary 423 | 424 | ---- `catchc` \(e :: SomeException ) -> do onAll $ delNodes [node] ; callServiceFail node params 425 | 426 | 427 | typea :: a -> Cloud a 428 | typea = undefined 429 | restoreLog (Log _ _ logw hash)= onAll $ do 430 | Log _ _ logw' hash' <- getSData <|> return emptyLog 431 | 432 | let newlog= reverse logw' ++ logw 433 | -- return () !> ("newlog", logw,logw') 434 | setData $ Log False newlog newlog (hash + hash') 435 | 436 | #else 437 | callService' node params = local empty 438 | #endif 439 | 440 | sendStatusToMonitor :: String -> Cloud () 441 | #ifndef ghcjs_HOST_OS 442 | sendStatusToMonitor status= loggedc $ do 443 | local $ onException $ \(e:: ConnectionError) -> continue >> startMonitor -- !> ("EXCEPTIOOOOOOOOOOON",e) 444 | nod <- local getMyNode 445 | callService' monitorNode (nodePort nod, status) -- <|> return() 446 | #else 447 | sendStatusToMonitor status= local $ return () 448 | 449 | inputAuthorizations :: Cloud () 450 | inputAuthorizations= empty 451 | #endif 452 | 453 | 454 | emptyLog= Log False [] [] 0 455 | 456 | catchc :: Exception e => Cloud a -> (e -> Cloud a) -> Cloud a 457 | catchc a b= Cloud $ catcht (runCloud' a) (\e -> runCloud' $ b e) 458 | 459 | 460 | selfServices= unsafePerformIO $ newIORef $ const empty 461 | notused n= error $ "runService: "++ show (n::Int) ++ " variable should not be used" 462 | 463 | -- | executes a program that export endpoints that can be called with `callService` primitives. 464 | -- It receives the service description, a default port, the services to set up and the computation to start. 465 | -- for example the monitor exposes two services, and is started with: 466 | -- 467 | -- > main = keep $ runService monitorService 3000 $ 468 | -- > [serve returnInstances 469 | -- > ,serve addToLog] pings 470 | -- 471 | -- every service incorporates a ping service and a error service, invoqued when the parameter received 472 | -- do not match with any of the endpoints implemented. 473 | runService :: Service -> Int -> [(IDynamic -> Cloud IDynamic)] -> Cloud () -> TransIO ( IDynamic) 474 | runService servDesc defPort servs proc= runCloud $ 475 | runService' servDesc defPort servAll proc 476 | where 477 | 478 | servAll d = foldr (<|>) empty $ map (\f -> f d) $ servs 479 | ++ [serve killRemoteJobIt 480 | , serve ping 481 | , serve (local . addNodes) 482 | , serve getNodesIt 483 | #ifndef ghcjs_HOST_OS 484 | , serve redirectOutputIt 485 | , serve sendToInputIt 486 | #endif 487 | , serveerror] 488 | 489 | ping :: () -> Cloud () 490 | ping = const $ return() !> "PING" 491 | 492 | serveerror d= empty -- localIO $ do 493 | -- error $ "parameter mismatch calling service (parameter,service): "++ show (d :: IDynamic,servDesc) 494 | -- empty 495 | 496 | 497 | data GetNodes = GetNodes deriving(Read,Show, Typeable) 498 | -- | return the list of nodes known by the service 499 | getNodesIt :: GetNodes -> Cloud [Node] 500 | getNodesIt _ = local getNodes 501 | {- 502 | $ do 503 | ns <- getNodes 504 | my <- getMyNode 505 | return $ if nodeHost my == "localhost" then ns else map (fix my) ns 506 | where 507 | fix my n = if nodeHost n== "localhost" 508 | then n{nodeServices= ("relay", relinfo my):nodeServices n} 509 | else n 510 | relinfo my= show (nodeHost my, nodePort my) 511 | -} 512 | 513 | 514 | runService' :: Service -> Int -> (IDynamic -> Cloud IDynamic) -> Cloud() -> Cloud ( IDynamic) 515 | runService' servDesc defPort servAll proc= do 516 | {- 517 | onAll $ onException $ \(e :: SomeException) -> runCloud $ do 518 | localIO $ print ("SENDSTATUSTO MONITOR",e) 519 | node <- local getMyNode 520 | sendStatusToMonitor $ show e 521 | -} 522 | onAll $ liftIO $ writeIORef selfServices servAll 523 | serverNode <- initNodeServ servDesc 524 | wormhole serverNode $ inputNodes <|> proc >> empty >> return() 525 | services 526 | 527 | where 528 | 529 | services= do 530 | 531 | wormhole (notused 1) $ do 532 | -- onAll reportBack 533 | 534 | x <- local $ (return $ notused 2) 535 | {- Closure closRemote <- getData `onNothing` onAll (do liftIO $ print "teleport: no closRemote"; empty) 536 | 537 | onAll $ do 538 | conn@Connection {localClosures=localClosures} <- getData `onNothing` error "Listen: myNode not set" 539 | cont <- get 540 | liftIO $ modifyMVar_ localClosures $ \map -> do 541 | case M.lookup 0 map of 542 | Nothing -> return $ M.insert 0 (unsafePerformIO $ newEmptyMVar, cont) map 543 | Just _ -> return map 544 | -} 545 | 546 | r <- loggedc $ servAll' x 547 | return () !> ("SENDING",r) 548 | setData emptyLog 549 | local $ return r 550 | teleport 551 | 552 | return r 553 | where 554 | 555 | servAll' x= servAll x 556 | 557 | `catchc` \(e:: SomeException ) -> do 558 | return () !> ("ERRORRRRRR:",e) 559 | node <- local getMyNode 560 | sendStatusToMonitor $ show e 561 | 562 | local $ do 563 | Closure closRemote <- getData `onNothing` error "teleport: no closRemote" 564 | conn <- getData `onNothing` error "reportBack: No connection defined: use wormhole" 565 | msend conn $ SError $ toException $ ErrorCall $ show $ show $ CloudException node closRemote $ show e 566 | empty -- return $ toIDyn () 567 | 568 | 569 | 570 | 571 | initNodeServ servs=do 572 | (mynode,serverNode) <- onAll $ do 573 | node <- getNode "localhost" defPort servDesc 574 | addNodes [node] 575 | serverNode <- getWebServerNode 576 | mynode <- if isBrowserInstance 577 | then do 578 | addNodes [serverNode] 579 | return node 580 | else return serverNode 581 | 582 | conn <- defConnection 583 | liftIO $ writeIORef (myNode conn) mynode 584 | 585 | setState conn 586 | return (mynode,serverNode) 587 | 588 | inputAuthorizations <|> return () 589 | 590 | listen mynode <|> return () 591 | return serverNode 592 | 593 | where 594 | 595 | -- getNode :: TransIO Node 596 | getNode host port servs= def <|> getNodeParams 597 | where 598 | def= do 599 | args <- liftIO getArgs 600 | 601 | if "-p" `elem` args then empty else liftIO $ createNodeServ host port servs 602 | getNodeParams= 603 | if isBrowserInstance then liftIO createWebNode else do 604 | oneThread $ option "start" "re/start node" 605 | host <- input' (Just "localhost") (const True) "hostname of this node (must be reachable) (\"localhost\"): " 606 | port <- input' (Just 3000) (const True) "port to listen? (3000) " 607 | liftIO $ createNodeServ host port servs 608 | 609 | 610 | 611 | -- | ping a service in a node. since services now try in other nodes created by the monitor until succees, ping can be 612 | -- used to preemptively assure that there is a node ready for the service. 613 | ping node= callService' node () :: Cloud () 614 | 615 | sendToNodeStandardInput :: Node -> String -> Cloud () 616 | sendToNodeStandardInput node cmd= callService' (monitorOfNode node) (node,cmd) :: Cloud () 617 | 618 | -- | monitor for a node is the monitor process that is running in his host 619 | monitorOfNode node= 620 | case lookup "relay" $ nodeServices node of 621 | Nothing -> node{nodePort= 3000, nodeServices=monitorService} 622 | Just info -> let (h,p)= read info 623 | in Node h p Nothing monitorService 624 | 625 | data ReceiveFromNodeStandardOutput= ReceiveFromNodeStandardOutput Node BSS.ByteString deriving (Read,Show,Typeable) 626 | receiveFromNodeStandardOutput :: Node -> BSS.ByteString -> Cloud String 627 | receiveFromNodeStandardOutput node ident= callService' (monitorOfNode node) $ ReceiveFromNodeStandardOutput node ident 628 | 629 | 630 | 631 | -- | encode and decode parameters from/to the individual services. a service within a program is invoked if the types of 632 | -- the parameters received match with what the service expect. See `runService` for a usage example 633 | serve :: (Loggable a, Loggable b) => (a -> Cloud b) -> IDynamic -> Cloud IDynamic 634 | serve f d = do 635 | return () !> ("MAYBEFROMIDYN", typeOf f,d) 636 | 637 | case maybeFromIDyn d of 638 | Nothing -> empty 639 | Just x -> toIDyn <$> f x -- (f x <** setState WasRemote) 640 | 641 | 642 | #ifndef ghcjs_HOST_OS 643 | 644 | 645 | -- callRestService :: (Subst1 a String, fromJSON b) => Node -> String -> a -> Cloud ( BS.ByteString) 646 | callRestService node callString vars= local $ do 647 | newVar "hostnode" $ nodeHost node 648 | newVar "hostport" $ nodePort node 649 | let calls = subst callString vars 650 | restmsg <- replaceVars calls 651 | return () !> ("restmsg",restmsg) 652 | rawREST node restmsg 653 | 654 | 655 | 656 | 657 | controlNodeService node= send <|> receive 658 | where 659 | send= do 660 | local abduce 661 | local $ do 662 | let nname= nodeHost node ++":" ++ show(nodePort node) 663 | 664 | liftIO $ putStr "Controlling node " >> print nname 665 | liftIO $ writeIORef lineprocessmode True 666 | oldprompt <- liftIO $ atomicModifyIORef rprompt $ \oldp -> ( nname++ "> ",oldp) 667 | cbs <- liftIO $ atomicModifyIORef rcb $ \cbs -> ([],cbs) -- remove local node options 668 | setState (oldprompt,cbs) -- store them 669 | 670 | 671 | endcontrol <|> log <|> inputs 672 | empty 673 | 674 | endcontrol= do 675 | 676 | local $ option "endcontrol" "end controlling node" 677 | killRemoteJob (monitorOfNode node) $ controlToken 678 | local $ do 679 | liftIO $ writeIORef lineprocessmode False 680 | liftIO $ putStrLn "end controlling remote node" 681 | (oldprompt,cbs) <- getState 682 | liftIO $ writeIORef rcb cbs -- restore local node options 683 | liftIO $ writeIORef rprompt oldprompt 684 | 685 | log = do 686 | local $ option "log" "display the log of the node" 687 | log <- getLog node 688 | localIO $ do 689 | 690 | putStr "\n\n------------- LOG OF NODE: ">> print node >> putStrLn "" 691 | mapM_ BS.putStrLn $ BS.lines log 692 | putStrLn "------------- END OF LOG" 693 | 694 | inputs= do 695 | line <- local $ inputf False "input" Nothing (const True) 696 | sendToNodeStandardInput node line 697 | 698 | 699 | receive= do 700 | local $ setRemoteJob controlToken $ monitorOfNode node 701 | r <- receiveFromNodeStandardOutput node $ controlToken 702 | when (not $ null r) $ localIO $ putStrLn r 703 | empty 704 | 705 | 706 | controlNode node= send <|> receive 707 | where 708 | send= do 709 | local abduce 710 | local $ do 711 | let nname= nodeHost node ++":" ++ show(nodePort node) 712 | liftIO $ writeIORef lineprocessmode True 713 | liftIO $ putStr "Controlling node " >> print nname 714 | 715 | oldprompt <- liftIO $ atomicModifyIORef rprompt $ \oldp -> ( nname++ "> ",oldp) 716 | cbs <- liftIO $ atomicModifyIORef rcb $ \cbs -> ([],cbs) -- remove local node options 717 | setState (oldprompt,cbs) -- store them 718 | 719 | 720 | endcontrol <|> log <|> inputs 721 | empty 722 | 723 | endcontrol= do 724 | local $ option "endcontrol" "end controlling node" 725 | killRemoteJob node $ controlToken 726 | local $ do 727 | liftIO $ writeIORef lineprocessmode False 728 | liftIO $ putStrLn "end controlling remote node" 729 | (oldprompt,cbs) <- getState 730 | liftIO $ writeIORef rcb cbs -- restore local node options 731 | liftIO $ writeIORef rprompt oldprompt 732 | 733 | log = do 734 | local $ option "log" "display the log of the node" 735 | log <- getLog node 736 | localIO $ do 737 | 738 | putStr "\n\n------------- LOG OF NODE: ">> print node >> putStrLn "" 739 | mapM_ BS.putStrLn $ BS.lines log 740 | putStrLn "------------- END OF LOG" 741 | 742 | inputs= do 743 | line <- local $ inputf False "input" Nothing (const True) 744 | callService' node $ SendToInput line :: Cloud () 745 | 746 | 747 | receive= do 748 | local $ setRemoteJob controlToken $ monitorOfNode node 749 | r <- callService' node $ RedirectOutput $ controlToken 750 | localIO $ putStrLn r 751 | empty 752 | 753 | {-# NOINLINE controlToken#-} 754 | controlToken :: BSS.ByteString 755 | controlToken= fromString "#control" <> fromString (show (unsafePerformIO $ (randomIO :: IO Int))) 756 | 757 | newtype RedirectOutput= RedirectOutput BSS.ByteString deriving (Read,Show,Typeable) 758 | newtype SendToInput= SendToInput String deriving (Read,Show,Typeable) 759 | 760 | sendToInputIt :: SendToInput -> Cloud () 761 | sendToInputIt (SendToInput input)= localIO $ processLine input >> hFlush stdout -- to force flush stdout 762 | 763 | redirectOutputIt (RedirectOutput label)= local $ do 764 | 765 | (rr,ww) <- liftIO createPipe 766 | stdout_dup <- liftIO $ hDuplicate stdout 767 | liftIO $ hDuplicateTo ww stdout 768 | finish stdout_dup 769 | labelState label 770 | read rr 771 | where 772 | read rr = waitEvents $ hGetLine rr 773 | 774 | finish stdout_dup = onException $ \(e :: SomeException) -> do 775 | 776 | liftIO $ hDuplicateTo stdout_dup stdout 777 | liftIO $ putStrLn "restored control" 778 | empty 779 | 780 | 781 | 782 | 783 | newtype GetLog= GetLog Node deriving (Read,Show, Typeable) 784 | getLog :: Node -> Cloud BS.ByteString 785 | getLog node= callService' (monitorOfNode node) (GetLog node) 786 | 787 | 788 | -------------------cloudshell vars ------------------------- 789 | data LocalVars = LocalVars (M.Map String String) deriving (Typeable, Read, Show) 790 | 791 | 792 | newVar :: (Show a, Typeable a) => String -> a -> TransIO () 793 | newVar name val= noTrans $ do 794 | LocalVars map <- getData `onNothing` return (LocalVars M.empty) 795 | setState $ LocalVars $ M.insert name (show1 val) map 796 | 797 | replaceVars :: String -> TransIO String 798 | replaceVars []= return [] 799 | replaceVars ('$':str)= do 800 | LocalVars localvars <- getState <|> return (LocalVars M.empty) 801 | let (var,rest')= break (\c -> c=='-' || c==' ' || c=='\r' || c == '\n' ) str 802 | (manifest, rest)= if null rest' || head rest'=='-' 803 | then break (\c -> c=='\r' || c =='\n' || c==' ') $ tailSafe rest' 804 | else ("", rest') 805 | 806 | if var== "port"&& null manifest then (++) <$> (show <$> freePort) <*> replaceVars rest -- $host variable 807 | else if var== "host" && null manifest then (++) <$> (nodeHost <$> getMyNode) <*> replaceVars rest 808 | else if null manifest then 809 | case M.lookup var localvars of 810 | Just v -> do 811 | v' <- processVar v 812 | (++) <$> return (show1 v') <*> replaceVars rest 813 | Nothing -> (:) <$> return '$' <*> replaceVars rest 814 | else do 815 | map <- liftIO $ readFile manifest >>= return . toMap 816 | let mval = lookup var map 817 | case mval of 818 | Nothing -> error $ "Not found variable: "++ "$" ++ var ++ manifest 819 | Just val -> (++) <$> return val <*> replaceVars rest 820 | where 821 | tailSafe []=[] 822 | tailSafe xs= tail xs 823 | 824 | processVar= return . id 825 | 826 | toMap :: String -> [(String, String)] 827 | toMap desc= map break1 $ lines desc 828 | where 829 | break1 line= 830 | let (k,v1)= break (== ' ') line 831 | in (k,dropWhile (== ' ') v1) 832 | 833 | replaceVars (x:xs) = (:) <$> return x <*> replaceVars xs 834 | 835 | ---------------- substitution --------------------------------------------- 836 | 837 | subst :: Subst1 a r => String -> a -> r 838 | subst expr= subst1 expr 1 839 | 840 | 841 | class Subst1 a r where 842 | subst1 :: String -> Int -> a -> r 843 | 844 | 845 | instance (Show b, Typeable b, Subst1 a r) => Subst1 b (a -> r) where 846 | subst1 str n x = \a -> subst1 (subst1 str n x) (n+1) a 847 | 848 | instance {-# Overlaps #-} (Show a,Typeable a, Show b, Typeable b) => Subst1 (a,b) String where 849 | subst1 str n (x,y)= subst str x y 850 | 851 | instance {-# Overlaps #-} (Show a,Typeable a, Show b, Typeable b 852 | ,Show c, Typeable c) => Subst1 (a,b,c) String where 853 | subst1 str n (x,y,z)= subst str x y z 854 | 855 | instance {-# Overlaps #-} (Show a,Typeable a, Show b, Typeable b 856 | ,Show c,Typeable c, Show d, Typeable d) 857 | => Subst1 (a,b,c,d) String where 858 | subst1 str n (x,y,z,t)= subst str x y z t 859 | 860 | 861 | instance {-# Overlaps #-} (Show a,Typeable a) => Subst1 a String where 862 | subst1 str n x= subst2 str n x 863 | 864 | subst2 str n x= replaces str ('$' : show n ) x 865 | 866 | replaces str var x= replace var (show1 x) str 867 | 868 | replace _ _ [] = [] 869 | replace a b s@(x:xs) = 870 | if isPrefixOf a s 871 | then b++replace a b (drop (length a) s) 872 | else x:replace a b xs 873 | 874 | 875 | 876 | 877 | show1 :: (Show a, Typeable a) => a -> String 878 | show1 x | typeOf x == typeOf (""::String)= unsafeCoerce x 879 | | otherwise= show x 880 | #endif -------------------------------------------------------------------------------- /src/Transient/Move/Services/Executor.hs: -------------------------------------------------------------------------------- 1 | module Transient.Move.Services.Executor where 2 | 3 | import Transient.Internals 4 | import Transient.Move.Internals 5 | import Transient.Move.Services 6 | import Data.IORef 7 | import System.IO.Unsafe 8 | import qualified Data.Map as M 9 | import qualified Data.ByteString.Lazy.Char8 as BS 10 | import qualified Data.ByteString.Char8 as BSS 11 | import Data.String 12 | import Data.Typeable 13 | import Control.Applicative 14 | import Control.Monad 15 | import Control.Monad.State (liftIO) 16 | 17 | executorService = [("service","executor") 18 | ,("executable", "executor") 19 | ,("package","https://github.com/transient-haskell/transient-universe")] 20 | 21 | 22 | 23 | -- initialize N instances, of the executor service. The monitor would spread them among the nodes available. 24 | -- the number N should be less of equal than the number of phisical machines. 25 | -- Since the executor serivice can execute any number of processes, it sould be at most one per machine. 26 | 27 | initExecute number= requestInstance executorService number 28 | 29 | -- | execute a command in some node by an executor service, and return the result when the program finishes 30 | networkExecute :: String -> String -> Cloud String 31 | networkExecute cmdline input= 32 | callService executorService (cmdline, input,()) 33 | 34 | 35 | 36 | -- | execute a process in some machine trough the local monitor and the executor. 37 | -- This call return a process identifier 38 | -- The process can be controlled with other services like `controlNodeProcess` 39 | networkExecuteStream' :: String -> Cloud String 40 | networkExecuteStream' cmdline= do 41 | -- callService executorService cmdline 42 | node <- initService executorService 43 | return () !> ("STORED NODE", node) 44 | name <- callService' node $ ExecuteStream cmdline 45 | localIO $ print ("NAME", name) 46 | localIO $ atomicModifyIORef rnodecmd $ \map -> (M.insert name node map,()) 47 | local $ setRemoteJob (BSS.pack name) node -- so it can be stopped by `killRemoteJob` 48 | return name 49 | 50 | -- | execute a shell command in some node using the executor service. 51 | -- The response is received as an stream of responses, one per line 52 | networkExecuteStream :: String -> Cloud String -- '[Multithreaded,Streaming] 53 | networkExecuteStream cmdline= do 54 | node <- initService executorService 55 | flag <- onAll $ liftIO $ newIORef False 56 | r <- callService' node cmdline 57 | init <- onAll $ liftIO $ readIORef flag 58 | when (not init) $ do 59 | onAll $ liftIO $ writeIORef flag True -- get the first line (header) as the name of the process 60 | local $ setRemoteJob (BSS.pack r) node -- so it can be stopped by `killRemoteJob` 61 | localIO $ atomicModifyIORef rnodecmd $ \map -> (M.insert r node map,()) 62 | return r 63 | 64 | rnodecmd= unsafePerformIO $ newIORef M.empty 65 | 66 | -- | send a message that will be read by the standard input of the program initiated by `networkExecuteStream`, identified by the command line. 67 | -- the stream of responses is returned by that primitive. `sendExecuteStream` never return anything, since it is asynchronous 68 | sendExecuteStream :: String -> String -> Cloud () -- '[Asynchronous] 69 | sendExecuteStream cmdline msg= do 70 | 71 | return () !> ("SENDEXECUTE", cmdline) 72 | node <- nodeForProcess cmdline 73 | --localIO $ do 74 | -- map <- readIORef rnodecmd 75 | -- let mn = M.lookup cmdline map 76 | -- case mn of 77 | -- Nothing -> error $ "sendExecuteStream: no node executing the command: "++ cmdline 78 | -- Just n -> return n 79 | return () !> ("NODE", node) 80 | callService' node (cmdline, msg) 81 | 82 | 83 | controlNodeProcess cmdline= do 84 | exnode <- nodeForProcess cmdline 85 | --local $ do 86 | -- map <- readIORef rinput 87 | -- let mn = M.lookup cmdline map 88 | -- return $ case mn of 89 | -- Nothing -> error $ "sendExecuteStream: no node executing the command: "++ cmdline 90 | -- Just n -> n 91 | 92 | send exnode <|> receive exnode 93 | where 94 | 95 | send exnode= do 96 | local abduce 97 | local $ do 98 | liftIO $ writeIORef lineprocessmode True 99 | oldprompt <- liftIO $ atomicModifyIORef rprompt $ \oldp -> ( takeWhile (/= ' ') cmdline++ "> ",oldp) 100 | cbs <- liftIO $ atomicModifyIORef rcb $ \cbs -> ([],cbs) -- remove local node options 101 | setState (oldprompt,cbs) -- store them 102 | 103 | 104 | endcontrolop exnode <|> kill exnode <|> log exnode <|> inputs exnode 105 | empty 106 | 107 | kill exnode= do 108 | local $ option "kill" "kill the process" 109 | localIO $ putStrLn "process terminated" 110 | killRemoteJob exnode $ fromString cmdline 111 | endcontrol exnode 112 | 113 | endcontrolop exnode= do 114 | local $ option "endcontrol" "end controlling the process" 115 | localIO $ putStrLn "end controlling the process" 116 | endcontrol exnode 117 | 118 | endcontrol exnode= do 119 | localIO $ writeIORef lineprocessmode False 120 | killRemoteJob exnode controlToken 121 | local $ do 122 | 123 | (oldprompt,cbs) <- getState 124 | liftIO $ writeIORef rcb cbs -- restore local node options 125 | liftIO $ writeIORef rprompt oldprompt 126 | 127 | log exnode = do 128 | local $ option "log" "display the log of the node" 129 | log <- getLogCmd cmdline exnode 130 | localIO $ do 131 | 132 | putStr "\n\n------------- LOG OF PROCESS: ">> print cmdline >> putStrLn "" 133 | mapM_ BS.putStrLn $ BS.lines log 134 | putStrLn "------------- END OF LOG" 135 | 136 | inputs exnode= do 137 | 138 | line <- local $ inputf False "input" Nothing (const True) 139 | sendExecuteStream cmdline line 140 | 141 | 142 | receive exnode= do 143 | r <- receiveExecuteStream cmdline exnode 144 | when (not $ null r) $ localIO $ putStrLn r 145 | empty 146 | 147 | receiveExecuteStream cmd node=do 148 | local $ setRemoteJob controlToken node 149 | callService' node $ ReceiveExecuteStream cmd controlToken 150 | 151 | getLogCmd :: String -> Node -> Cloud BS.ByteString 152 | getLogCmd cmd node= callService' node (GetLogCmd cmd) 153 | 154 | newtype GetLogCmd= GetLogCmd String deriving (Read, Show, Typeable) 155 | newtype ExecuteStream= ExecuteStream String deriving (Read, Show, Typeable) 156 | data ReceiveExecuteStream= ReceiveExecuteStream String BSS.ByteString deriving (Read, Show, Typeable) 157 | data GetProcesses= GetProcesses deriving (Read, Show, Typeable) 158 | 159 | getProcesses :: Node -> Cloud [String] 160 | getProcesses node= callService' node GetProcesses 161 | 162 | 163 | 164 | 165 | 166 | -- | get the executor that executes a process 167 | 168 | 169 | nodeForProcess :: String -> Cloud Node 170 | nodeForProcess process= do 171 | 172 | callService monitorService () :: Cloud () -- start/ping monitor if not started 173 | 174 | nods <- squeezeMonitor [] monitorNode 175 | case nods of 176 | [] -> error $ "no node running: "++ process 177 | nod:_ -> return nod 178 | where 179 | squeezeMonitor :: [Node] -> Node -> Cloud [Node] 180 | squeezeMonitor exc nod= do 181 | if nod `elem` exc then return [] else do 182 | nodes <- callService' nod GetNodes :: Cloud [Node] 183 | return . concat =<< mapM squeeze (tail nodes) 184 | 185 | where 186 | squeeze :: Node -> Cloud [Node] 187 | squeeze node= do 188 | 189 | case lookup "service" $ nodeServices node of 190 | 191 | Just "monitor" -> squeezeMonitor (nod:exc) node 192 | 193 | Just "executor" -> do 194 | 195 | procs <- callService' node GetProcesses :: Cloud [String] 196 | if process `elem` procs then return [node] else return [] 197 | 198 | _ -> return [] 199 | 200 | 201 | 202 | -------------------------------------------------------------------------------- /src/Transient/Move/Utils.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Transient.Move.Utils 4 | -- Copyright : 5 | -- License : MIT 6 | -- 7 | -- Maintainer : agocorona@gmail.com 8 | -- Stability : 9 | -- Portability : 10 | -- 11 | -- | 12 | -- 13 | ----------------------------------------------------------------------------- 14 | {-# LANGUAGE ScopedTypeVariables #-} 15 | module Transient.Move.Utils (initNode,initNodeDef, initNodeServ, inputNodes, simpleWebApp, initWebApp 16 | , onServer, onBrowser, atServer, atBrowser, runTestNodes) 17 | where 18 | 19 | --import Transient.Base 20 | import Transient.Internals 21 | import Transient.Move.Internals 22 | import Control.Applicative 23 | import Control.Monad.State 24 | import Data.IORef 25 | import System.Environment 26 | import Data.List((\\)) 27 | 28 | import Control.Exception hiding(onException) 29 | 30 | -- | ask in the console for the port number and initializes a node in the port specified 31 | -- It needs the application to be initialized with `keep` to get input from the user. 32 | -- the port can be entered in the command line with " -p start/" 33 | -- 34 | -- A node is also a web server that send to the browser the program if it has been 35 | -- compiled to JavaScript with ghcjs. `initNode` also initializes the web nodes. 36 | -- 37 | -- This sequence compiles to JScript and executes the program with a node in the port 8080 38 | -- 39 | -- > ghc program.hs 40 | -- > ghcjs program.hs -o static/out 41 | -- > ./program -p start/myhost/8080 42 | -- 43 | -- `initNode`, when the application has been loaded and executed in the browser, will perform a `wormhole` to his server node. 44 | -- So the application run within this wormhole. 45 | -- 46 | -- Since the code is executed both in server node and browser node, to avoid confusion and in order 47 | -- to execute in a single logical thread, use `onServer` for code that you need to execute only in the server 48 | -- node, and `onBrowser` for code that you need in the browser, although server code could call the browser 49 | -- and vice-versa. 50 | -- 51 | -- To invoke from browser to server and vice-versa, use `atRemote`. 52 | -- 53 | -- To translate the code from the browser to the server node, use `teleport`. 54 | -- 55 | initNode :: Loggable a => Cloud a -> TransIO a 56 | initNode app= do 57 | node <- getNodeParams 58 | --abduce 59 | initWebApp node app 60 | 61 | 62 | getNodeParams :: TransIO Node 63 | getNodeParams = 64 | if isBrowserInstance then liftIO createWebNode else do 65 | oneThread $ option "start" "re/start node" 66 | host <- input (const True) "hostname of this node. (Must be reachable)? " 67 | port <- input (const True) "port to listen? " 68 | liftIO $ createNode host port 69 | 70 | initNodeDef :: Loggable a => String -> Int -> Cloud a -> TransIO a 71 | initNodeDef host port app= do 72 | node <- def <|> getNodeParams 73 | initWebApp node app 74 | where 75 | def= do 76 | args <- liftIO getArgs 77 | if null args then liftIO $ createNode host port else empty 78 | 79 | initNodeServ :: Loggable a => Service -> String -> Int -> Cloud a -> TransIO a 80 | initNodeServ services host port app= do 81 | node <- def <|> getNodeParams 82 | let node'= node{nodeServices=services} 83 | initWebApp node' $ app 84 | where 85 | def= do 86 | args <- liftIO getArgs 87 | if null args then liftIO $ createNode host port else empty 88 | 89 | -- | ask for nodes to be added to the list of known nodes. it also ask to connect to the node to get 90 | -- his list of known nodes. It returns empty. 91 | -- to input a node, enter "add" then the host and the port, the service description (if any) and "y" or "n" 92 | -- to either connect to that node and synchronize their lists of nodes or not. 93 | -- 94 | -- A typical sequence of initiation of an application that includes `initNode` and `inputNodes` is: 95 | -- 96 | -- > program -p start/host/8000/add/host2/8001/n/add/host3/8005/y 97 | -- 98 | -- "start/host/8000" is read by `initNode`. The rest is initiated by `inputNodes` in this case two nodes are added. 99 | -- the first of the two is not connected to synchronize their list of nodes. The second does. 100 | inputNodes :: Cloud empty 101 | inputNodes= onServer $ do 102 | local abduce 103 | listNodes <|> addNew 104 | where 105 | addNew= do 106 | local $ oneThread $ option "add" "add a new node" 107 | host <- local $ do 108 | r <- input (const True) "Hostname of the node (none): " 109 | if r == "" then stop else return r 110 | 111 | port <- local $ input (const True) "port? " 112 | serv <- local $ nodeServices <$> getMyNode 113 | services <- local $ input' (Just serv) (const True) ("services? ("++ show serv ++ ") ") 114 | 115 | connectit <- local $ input (\x -> x=="y" || x== "n") "connect to the node to interchange node lists? (n) " 116 | nnode <- localIO $ createNodeServ host port services 117 | if connectit== "y" then connect' nnode 118 | else local $ do 119 | liftIO $ putStr "Added node: ">> print nnode 120 | addNodes [nnode] 121 | empty 122 | 123 | listNodes= do 124 | local $ option "list" "list nodes" 125 | local $ do 126 | nodes <- getNodes 127 | liftIO $ putStrLn "list of nodes known in this node:" 128 | liftIO $ mapM (\(i,n) -> do putStr (show i); putChar('\t'); print n) $ zip [0..] nodes 129 | empty 130 | 131 | 132 | 133 | 134 | -- | executes the application in the server and the Web browser. 135 | -- the browser must point to http://hostname:port where port is the first parameter. 136 | -- It creates a wormhole to the server. 137 | -- The code of the program after `simpleWebApp` run in the browser unless `teleport` translates the execution to the server. 138 | -- To run something in the server and get the result back to the browser, use `atRemote` 139 | -- This last also works in the other side; If the application was teleported to the server, `atRemote` will 140 | -- execute his parameter in the browser. 141 | -- 142 | -- It is necesary to compile the application with ghcjs: 143 | -- 144 | -- > ghcjs program.js 145 | -- > ghcjs program.hs -o static/out 146 | -- 147 | -- > ./program 148 | -- 149 | -- 150 | simpleWebApp :: Loggable a => Integer -> Cloud a -> IO () 151 | simpleWebApp port app = do 152 | node <- createNode "localhost" $ fromIntegral port 153 | keep $ initWebApp node app 154 | return () 155 | 156 | -- | use this instead of simpleWebApp when you have to do some initializations in the server prior to the 157 | -- initialization of the web server 158 | initWebApp :: Loggable a => Node -> Cloud a -> TransIO a 159 | initWebApp node app= do 160 | 161 | conn <- defConnection 162 | liftIO $ writeIORef (myNode conn) node 163 | addNodes [node] 164 | serverNode <- getWebServerNode :: TransIO Node 165 | 166 | mynode <- if isBrowserInstance 167 | then do 168 | addNodes [serverNode] 169 | return node 170 | else return serverNode 171 | 172 | 173 | runCloud' $ do 174 | listen mynode <|> return() 175 | wormhole serverNode app 176 | 177 | -- | only execute if the the program is executing in the browser. The code inside can contain calls to the server. 178 | -- Otherwise return empty (so it stop the computation and may execute alternative computations). 179 | onBrowser :: Cloud a -> Cloud a 180 | onBrowser x= do 181 | r <- local $ return isBrowserInstance 182 | if r then x else empty 183 | 184 | -- | only executes the computaion if it is in the server, but the computation can call the browser. Otherwise return empty 185 | onServer :: Cloud a -> Cloud a 186 | onServer x= do 187 | r <- local $ return isBrowserInstance 188 | if not r then x else empty 189 | 190 | 191 | -- | If the computation is running in the server, translates i to the browser and return back. 192 | -- If it is already in the browser, just execute it 193 | atBrowser :: Loggable a => Cloud a -> Cloud a 194 | atBrowser x= do 195 | r <- local $ return isBrowserInstance 196 | if r then x else atRemote x 197 | 198 | -- | If the computation is running in the browser, translates i to the server and return back. 199 | -- If it is already in the server, just execute it 200 | atServer :: Loggable a => Cloud a -> Cloud a 201 | atServer x= do 202 | r <- local $ return isBrowserInstance 203 | if not r then x else atRemote x 204 | 205 | -- | run N nodes (N ports to listen) in the same program. For testing purposes. 206 | -- It add them to the list of known nodes, so it is possible to perform `clustered` operations with them. 207 | runTestNodes ports= do 208 | nodes <- onAll $ mapM (\p -> liftIO $ createNode "localhost" p) ports 209 | onAll $ addNodes nodes 210 | foldl (<|>) empty (map listen1 nodes) <|> return() 211 | where 212 | listen1 n= do 213 | listen n 214 | onAll $ do 215 | ns <- getNodes 216 | addNodes $ n: (ns \\[n]) 217 | conn <- getState <|> error "runTestNodes error" 218 | liftIO $ writeIORef (myNode conn) n 219 | 220 | -------------------------------------------------------------------------------- /stack-ghcjs.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-6.6 2 | packages: 3 | - '.' 4 | - location: 5 | git: https://github.com/agocorona/transient.git 6 | commit: d3a96df9ecaf0f09f756fb0fc28901e74c894360 7 | extra-dep: true 8 | extra-package-dbs: [] 9 | flags: {} 10 | 11 | compiler: ghcjs-0.2.0.20160917_ghc-7.10.3 12 | compiler-check: match-exact 13 | setup-info: 14 | ghcjs: 15 | source: 16 | ghcjs-0.2.0.20160917_ghc-7.10.3: 17 | url: http://ghcjs.luite.com/master-20160917.tar.gz 18 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-6.6 2 | packages: 3 | - '.' 4 | - location: 5 | git: https://github.com/transient-haskell/transient.git 6 | commit: b15972a71634efe3b85a1480cecc35b50d424e5d 7 | 8 | extra-dep: true 9 | extra-package-dbs: [] 10 | flags: {} 11 | 12 | -------------------------------------------------------------------------------- /tests/Dockerfile: -------------------------------------------------------------------------------- 1 | from test 2 | CMD cd /bin && ./distributedApps -p start/localhost/8080 3 | -------------------------------------------------------------------------------- /tests/Parameters.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification , ScopedTypeVariables, FlexibleInstances #-} 2 | module Transient.Move.Parameters where 3 | 4 | import Transient.Internals 5 | import Transient.Move 6 | import Transient.Move.Utils 7 | import Data.Typeable 8 | import Data.Map as M 9 | import System.Random 10 | import System.IO.Unsafe 11 | import Data.IORef 12 | import Control.Monad.IO.Class 13 | import Control.Monad 14 | 15 | import Control.Applicative 16 | import Transient.Indeterminism 17 | import Control.Concurrent 18 | import Control.Exception hiding (onException) 19 | import System.CPUTime 20 | -- -- opcion reactiva= parameter= EVar o mailbox 21 | 22 | -- TODO: associate parameters to the hierarchy of threads 23 | -- optimize a branch, not the whole program 24 | -- TODO: Not only Int values 25 | 26 | parameters= unsafePerformIO $ newIORef $ M.empty 27 | 28 | -- | Parameters can be changed during the execution and are read by the application to modify his behaviour. `optimize`change the parameters in order 29 | -- to maximize an expression defined by the programmer. this expression may include latency, troughput, memory usage etc. 30 | -- 31 | -- To optimize the function, it uses a monte-carlo method that `optimize` a unser defined expression that 32 | -- evaluate the performance. 33 | -- 34 | -- Parameters can change buffer sizes, number of threads, number of instances. It depends on the programmer. 35 | setParameter :: String -> Int -> TransIO () 36 | setParameter n v= do 37 | vec <- liftIO $ readIORef parameters 38 | putMailbox' n v 39 | liftIO $ writeIORef parameters $ M.insert n v vec 40 | 41 | -- | The programmer can create a parameter anywhere 42 | addParameter :: MonadIO m => String -> Int -> m () 43 | addParameter n v= liftIO $ do 44 | vec <- readIORef parameters 45 | writeIORef parameters $ M.insert n v vec 46 | 47 | -- | get the value of a parameter reactively: this means that when `optimize` changes it, the application receives the new value. 48 | getParameter :: String -> Int -> TransIO Int 49 | getParameter n v= oneThread $ getMailbox' n <|> getParameterNR n v 50 | 51 | -- | A non reactive version of `getParameter` 52 | getParameterNR :: MonadIO m => String -> Int -> m Int 53 | getParameterNR n v= do 54 | map <- liftIO $ readIORef parameters 55 | case M.lookup n map of 56 | Nothing -> addParameter n v >> return v 57 | Just v -> return v 58 | 59 | -- | it should be a single `optimize` call. it executes the optimization expression in a loop within a different thread. 60 | -- The next iteration will start as soon as the previous has finished so it is 61 | -- necessary to introduce a delay which may be variable and subject also to optimizations 62 | -- Take into acount that `getParameter` abort any previous subsequent task in order to execute the continuation witht he new parameter. 63 | -- `optimize` will reset the parameter if the perturbed parameter vale gives less performance than the previous 64 | 65 | -- > main= keep $ optimizeProcess <|> process 66 | -- > optimizeProcess= optimize $ do 67 | -- > liftIO $ threadDelay 1000000 68 | -- > expression 69 | optimize :: TransIO Int -> TransIO () 70 | optimize expr= do 71 | abduce 72 | optimize' 73 | where 74 | optimize'= do 75 | v <- expr !> "OPTIMIZE" 76 | (randparam,old) <- perturbe 77 | v' <- expr 78 | when (v > v') $ setParameter randparam old 79 | optimize' 80 | 81 | perturbe = do 82 | vec <- liftIO $ readIORef parameters !> "PERTURBE" 83 | i <- liftIO $ randomRIO (0,M.size vec -1) 84 | let (name, pvalue) = M.toList vec !! i !> i 85 | let range= pvalue `div` 10 +1 86 | sign <- liftIO randomIO 87 | let pvalue' = max (pvalue + (range * if sign then 1 else -1)) 0 88 | 89 | setParameter name pvalue' 90 | return () !> ("pvalue",pvalue') 91 | return (name,pvalue) !> (name,pvalue) 92 | 93 | 94 | 95 | main= keep $ initNode $ local (optimizeProcess <|> process) 96 | 97 | process= do 98 | ths <- getParameter "number of threads" 20 99 | liftIO $ print ("new", ths) 100 | n <- threads ths $ choose [1..] 101 | 102 | liftIO $ do atomicModifyIORef counter $ \n -> (n+1,()) 103 | 104 | 105 | counter= unsafePerformIO $ newIORef (0 :: Int) 106 | 107 | optimizeProcess= optimize $ liftIO $ do 108 | r <- readIORef counter 109 | t <- getCPUTime 110 | threadDelay 1000000 111 | r' <- readIORef counter 112 | t' <- getCPUTime 113 | let ticks= fromIntegral $ (t'-t) `div` 1000000000 114 | nthreads <- getParameterNR "number of threads" 20 115 | let rr= (r' - r) `div` ticks `div` (nthreads +1) 116 | print ("counter",r'-r,ticks,rr, nthreads, rr) 117 | return $ rr 118 | 119 | -------------------------------------------------------------------------------- /tests/Stream.hs: -------------------------------------------------------------------------------- 1 | import Control.Concurrent.Async 2 | import Control.Concurrent 3 | import Control.Applicative 4 | 5 | newtype Stream a = Stream{ runStream :: IO [Async a]} 6 | 7 | instance Functor Stream where 8 | fmap f (Stream mxs) = Stream $ do 9 | xs <- mxs 10 | return [fmap f x | x <- xs] 11 | 12 | instance Applicative Stream where 13 | pure x= Stream $ do 14 | z <- async $ return x 15 | return [z] 16 | 17 | (Stream mfs) <*> (Stream mas) = Stream $do 18 | as <- mas 19 | fs <- mfs 20 | sequence [ 21 | async $ ( wait f) <*> ( wait a) 22 | | f <- fs, a <- as] 23 | 24 | instance Alternative Stream where 25 | empty= Stream $ return [] 26 | x <|> y = Stream $ do 27 | xs <- runStream x 28 | if null xs then runStream y 29 | else return xs 30 | 31 | 32 | instance Monad Stream where 33 | return = pure 34 | (Stream mxs) >>= f = Stream $ do 35 | xs <- mxs 36 | rs <- mapM wait xs 37 | rr <- sequence [ runStream $ f r | r <- rs] 38 | return $ concat rr 39 | 40 | 41 | 42 | stream :: [IO a] -> Stream a 43 | stream ioa= Stream $ mapM async ioa 44 | 45 | stream' :: [a] -> Stream a 46 | stream' = Stream . mapM (async . return) 47 | 48 | waitStream :: Stream a -> IO [a] 49 | waitStream (Stream mxs)= do 50 | xs <- mxs 51 | mapM wait xs 52 | 53 | 54 | main= do 55 | r <- waitStream $ stream' [1..10] 56 | print r 57 | r <- waitStream $ do 58 | x <- stream' [1..100] 59 | return $ 2 * x 60 | print r 61 | 62 | where 63 | fact 0 = 1 64 | fact n= n * fact (n -1) 65 | 66 | -------------------------------------------------------------------------------- /tests/Test.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env execthirdlinedocker.sh 2 | -- info: use sed -i 's/\r//g' file if report "/usr/bin/env: ‘execthirdlinedocker.sh\r’: No such file or directory" 3 | -- runghc -i../transient/src -i../transient-universe/src -i../axiom/src $1 ${2} ${3} 4 | 5 | -- mkdir -p ./static && ghcjs --make -i../transient/src -i../transient-universe/src -i../axiom/src $1 -o static/out && runghc -i../transient/src -i../transient-universe/src -i../axiom/src $1 ${2} ${3} 6 | 7 | 8 | -- cd /projects/transient && cabal install -f debug --force-reinstalls && cd ../transient-universe && cabal install --force-reinstalls && runghc $1 $2 $3 $4 9 | 10 | 11 | 12 | 13 | {-# LANGUAGE ScopedTypeVariables, CPP, FlexibleInstances, FlexibleContexts, UndecidableInstances, RecordWildCards, MultiParamTypeClasses #-} 14 | 15 | 16 | import Transient.Internals 17 | 18 | import Transient.Move.Internals 19 | import Transient.Move.Utils 20 | import Transient.Logged 21 | import Transient.Parse 22 | import Control.Monad.State 23 | import System.IO (hFlush,stdout) 24 | import System.IO.Unsafe 25 | import Control.Concurrent.MVar 26 | import Control.Applicative 27 | import System.Time 28 | import Control.Concurrent(threadDelay) 29 | import Control.Exception hiding(onException) 30 | import Data.IORef 31 | import Control.Monad(when) 32 | import Data.Typeable 33 | import System.Random 34 | import Data.Maybe 35 | import qualified Data.Map as M 36 | import System.Environment 37 | import Data.List(isPrefixOf) 38 | import Unsafe.Coerce 39 | import Data.Monoid 40 | import Transient.Indeterminism 41 | import Control.Exception hiding(onException) 42 | import System.IO 43 | import Control.Concurrent.MVar 44 | #ifndef ghcjs_HOST_OS 45 | import System.Directory 46 | import qualified Data.ByteString.Lazy.Char8 as BS 47 | import qualified Data.ByteString.Char8 as BSS 48 | import Data.ByteString.Builder 49 | import Data.String 50 | import GHC.IO.Handle 51 | #endif 52 | 53 | 54 | 55 | main3 = keep $ initNode $ inputNodes <|> do 56 | local $ option "go" "go" 57 | nodes <- local getNodes 58 | 59 | r1 <- loggedc' $ wormhole (nodes !! 1) $ do 60 | teleport 61 | 62 | r <- localIO $ print "HELLO" >> return "WORLD" 63 | teleport 64 | localIO $ print "WORLD" >> return r 65 | 66 | r2 <- wormhole (nodes !! 1) $ loggedc $ do 67 | 68 | teleport 69 | r <- local $ getSData <|> return "NOOOOOO DAAATAAAAAA" 70 | localIO $ print r 71 | r <- loggedc $ do localIO $ print $ "HELLO22222" ++ r1;return $ "hello2" ++ r1 72 | teleport 73 | 74 | return r 75 | localIO $ print $ "WORLD2222222" ++ r2 76 | 77 | 78 | main = keep $ initNode $ inputNodes <|> do 79 | local $ option "go" "go" 80 | nodes <- local getNodes 81 | t1 <- onAll $ liftIO $ getClockTime 82 | r <- runAt (nodes !! 1) $ localIO $ BS.pack <$> replicateM 10000000 (randomRIO('a','z')) 83 | --localFix 84 | 85 | --localIO $ print $ BS.pack "RETURNED: " <> r 86 | t2 <- onAll $ liftIO $ getClockTime 87 | localIO $ print $ diffClockTimes t2 t1 88 | 89 | main2 = keep $ initNode $ inputNodes <|> do 90 | local $ option "go" "go" 91 | nodes <- local getNodes 92 | runAt (nodes !! 1) $ local $ do 93 | n <- getMyNode 94 | handle <- liftIO $ openFile ("test"++ show (nodePort n)) AppendMode 95 | setData handle 96 | 97 | 98 | 99 | append nodes <|> close nodes 100 | 101 | append nodes = do 102 | local $ option "wr" "write" 103 | 104 | runAt (nodes !! 1) $ local $ do 105 | handle <- getSData <|> error "no handle" 106 | liftIO $ hPutStrLn handle "hello" 107 | 108 | close nodes = do 109 | local $ option "cl" "close" 110 | 111 | 112 | 113 | runAt (nodes !! 1) $ local $ do 114 | handle <- getSData <|> error "no handle" 115 | liftIO $ hClose handle 116 | 117 | 118 | 119 | 120 | -------------------------------------------------------------------------------- /tests/Test3.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad 4 | import Control.Monad.IO.Class 5 | import System.Environment 6 | import System.IO 7 | import Transient.Base 8 | import Transient.Indeterminism 9 | import Transient.Logged 10 | import Transient.Move 11 | import Transient.Stream.Resource 12 | import Control.Applicative 13 | import System.Info 14 | import Control.Concurrent 15 | 16 | main = do 17 | 18 | let nodes= [createNode "localhost" 2020, createNode "192.168.99.100" 2020] 19 | args <- getArgs 20 | let [localnode, remote]= if length args > 0 then nodes 21 | else reverse nodes 22 | 23 | 24 | runCloud' $ do 25 | onAll $ addNodes nodes 26 | listen localnode <|> return () 27 | hello <|> helloworld <|> stream localnode 28 | 29 | hello= do 30 | local $ option "hello" "each computer say hello" 31 | 32 | r <- clustered $ do 33 | node <- getMyNode 34 | onAll . liftIO . print $ "hello " ++ os 35 | return ("hello from",os,arch, nodeHost node) 36 | 37 | lliftIO $ print r 38 | 39 | helloworld= do 40 | local $ option "helloword" "both computers compose \"hello world\"" 41 | r <- mclustered $ return $ if os== "linux" then "hello " else "world" 42 | lliftIO $ print r 43 | 44 | 45 | stream remoteHost= do 46 | local $ option "stream" "stream from the Linux node to windows" 47 | let fibs= 0 : 1 : zipWith (+) fibs (tail fibs) :: [Int] -- fibonacci numbers 48 | 49 | r <- runAt remoteHost $ local $ do 50 | r <- threads 1 $ choose $ take 10 fibs 51 | liftIO $ putStr os >> print r 52 | liftIO $ threadDelay 1000000 53 | return r 54 | lliftIO $ print r 55 | -------------------------------------------------------------------------------- /tests/TestSuite: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/transient-haskell/transient-universe/7cfbbdfa8eefbea79f48ccb69bc1823ba9abc7ea/tests/TestSuite -------------------------------------------------------------------------------- /tests/TestSuite.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, ScopedTypeVariables #-} 2 | module Main where 3 | 4 | #ifndef ghcjs_HOST_OS 5 | 6 | import Control.Monad 7 | import Control.Monad.IO.Class 8 | import Control.Applicative 9 | import Data.Monoid 10 | import Transient.Base 11 | import Transient.Internals 12 | import Transient.Indeterminism 13 | import Transient.Move.Internals 14 | import Transient.Move.Utils 15 | import Transient.Move.Services 16 | import Transient.MapReduce 17 | import Data.List 18 | import qualified Data.Map as M 19 | import System.Exit 20 | import Control.Monad.State 21 | import Control.Exception 22 | 23 | import Control.Concurrent(threadDelay ) 24 | 25 | -- #define _UPK_(x) {-# UNPACK #-} !(x) 26 | 27 | 28 | SHOULDRUNIN x= local $ getMyNode >>= \p -> assert ( p == (x)) (liftIO $ print p) 29 | 30 | service= [("service","test suite") 31 | ,("executable", "test-transient1") 32 | ,("package","https://github.com/agocorona/transient-universe")] 33 | 34 | main= do 35 | mr <- keep test 36 | endMonitor 37 | 38 | case mr of 39 | Nothing -> print "NO RESULT, NO THREADS RUNNING" >> exitFailure 40 | Just Nothing -> print "SUCCESS" >> exitSuccess 41 | Just (Just e) -> putStr "FAIL: " >> print e >> exitFailure 42 | 43 | 44 | 45 | 46 | 47 | test= initNodeServ service "localhost" 8080 $ do 48 | node0 <- local getMyNode 49 | 50 | local $ guard (nodePort node0== 8080) -- only executes in node 8080 51 | 52 | [node1, node2] <- requestInstance service 2 53 | 54 | local ( option "f" "fire") <|> return "" -- to repeat the tests, remove the "exit" at the end 55 | 56 | 57 | 58 | localIO $ putStrLn "------checking empty in remote node when the remote call back the caller #46 --------" 59 | r <- runAt node1 $ do 60 | SHOULDRUNIN node1 61 | runAt node2 $ (runAt node1 $ SHOULDRUNIN node1 >> empty ) <|> (SHOULDRUNIN node2 >> return "world") 62 | localIO $ print r 63 | 64 | 65 | localIO $ putStrLn "------checking Alternative distributed--------" 66 | r <- local $ collect 3 $ 67 | runCloud $ (runAt node0 (SHOULDRUNIN( node0) >> return "hello" )) 68 | <|> (runAt node1 (SHOULDRUNIN( node1) >> return "world" )) 69 | <|> (runAt node2 (SHOULDRUNIN( node2) >> return "world2" )) 70 | 71 | assert(sort r== ["hello", "world","world2"]) $ localIO $ print r 72 | 73 | localIO $ putStrLn "--------------checking Applicative distributed--------" 74 | r <- loggedc $(runAt node0 (SHOULDRUNIN( node0) >> return "hello ")) 75 | <> (runAt node1 (SHOULDRUNIN( node1) >> return "world " )) 76 | <> (runAt node2 (SHOULDRUNIN( node2) >> return "world2" )) 77 | 78 | assert(r== "hello world world2") $ localIO $ print r 79 | 80 | localIO $ putStrLn "----------------checking monadic, distributed-------------" 81 | r <- runAt node0 (SHOULDRUNIN(node0) 82 | >> runAt node1 (SHOULDRUNIN(node1) 83 | >> runAt node2 (SHOULDRUNIN(node2) >> (return "HELLO" )))) 84 | 85 | assert(r== "HELLO") $ localIO $ print r 86 | 87 | localIO $ putStrLn "----------------checking map-reduce -------------" 88 | 89 | r <- reduce (+) . mapKeyB (\w -> (w, 1 :: Int)) $ getText words "hello world hello" 90 | localIO $ print r 91 | assert (sort (M.toList r) == sort [("hello",2::Int),("world",1)]) $ return r 92 | 93 | 94 | local $ exit (Nothing :: Maybe SomeException) -- remove this to repeat the test 95 | 96 | 97 | 98 | #else 99 | main= return () 100 | #endif 101 | -------------------------------------------------------------------------------- /tests/TestSuite1: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/transient-haskell/transient-universe/7cfbbdfa8eefbea79f48ccb69bc1823ba9abc7ea/tests/TestSuite1 -------------------------------------------------------------------------------- /tests/TestSuite1.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ./execcluster.sh 2 | 3 | 4 | {-# LANGUAGE CPP #-} 5 | module Main where 6 | 7 | #ifndef ghcjs_HOST_OS 8 | 9 | import Control.Monad 10 | import Control.Monad.IO.Class 11 | import Data.IORef 12 | import GHC.Conc 13 | import Control.Applicative 14 | import Data.Monoid 15 | 16 | import Transient.Internals 17 | import Transient.Indeterminism 18 | import Transient.Logged 19 | import Transient.Move 20 | import Transient.Move.Utils 21 | import Transient.Move.Services 22 | import Transient.MapReduce 23 | import Transient.EVars 24 | import Control.Concurrent 25 | import System.IO.Unsafe 26 | import Data.List 27 | import Control.Exception.Base 28 | import qualified Data.Map as M 29 | import System.Exit 30 | import System.Process 31 | 32 | import Control.Monad.State 33 | #define _UPK_(x) {-# UNPACK #-} !(x) 34 | 35 | 36 | #define shouldRun(x) (local $ getMyNode >>= \n -> assert (nodePort n == (nodePort x)) (return ())) 37 | #define shouldRun1(x) (local $ getMyNode >>= \(Node _ p _ _) -> liftIO (print p >> print x >> print ( p == (x)))) 38 | 39 | 40 | 41 | main= do 42 | 43 | keep $ initNode $ do 44 | n1 <- local getMyNode 45 | n2 <- requestInstall "" ("executable", "TestSuite1") !> "request" 46 | n3 <- requestInstall "" ("executable", "TestSuite1") 47 | 48 | -- shell "./TestSuite1 -p start/localhost/8081/add/localhost/8080/y" 49 | -- shell "./TestSuite1 -p start/localhost/8082/add/localhost/8080/y" 50 | 51 | 52 | local $ option "f" "fire" 53 | -- async $ do 54 | -- let delay= (nodePort node -2000 + 1) *10000000 55 | -- threadDelay delay 56 | 57 | nodes <- local getNodes 58 | onAll $ liftIO $ print nodes 59 | 60 | let n1= head nodes 61 | n2= nodes !! 1 62 | n3= nodes !! 2 63 | 64 | 65 | 66 | localIO $ putStrLn "------checking Alternative distributed--------" 67 | r <- local $ do 68 | runCloud $ (runAt n1 (shouldRun(n1) >> return "hello" )) 69 | <|> (runAt n2 (shouldRun(n2) >> return "world" )) 70 | <|> (runAt n3 (shouldRun(n3) >> return "world2" )) 71 | localIO $ print r 72 | 73 | -- loggedc $ assert(sort r== ["hello", "world","world2"]) $ localIO $ print r 74 | 75 | -- localIO $ putStrLn "--------------checking Applicative distributed--------" 76 | -- r <- loggedc $(runAt n2000 (shouldRun(2000) >> return "hello ")) 77 | -- <> (runAt n2001 (shouldRun(2001) >> return "world " )) 78 | -- <> (runAt n2002 (shouldRun(2002) >> return "world2" )) 79 | -- 80 | -- assert(r== "hello world world2") $ localIO $ print r 81 | 82 | -- localIO $ putStrLn "----------------checking monadic, distributed-------------" 83 | -- r <- runAt n2000 (shouldRun(2000) 84 | -- >> runAt n2001 (shouldRun(2001) 85 | -- >> runAt n2002 (shouldRun(2002) >> (return "HELLO" )))) 86 | -- 87 | -- assert(r== "HELLO") $ localIO $ print r 88 | -- 89 | -- 90 | -- localIO $ putStrLn "----------------checking map-reduce -------------" 91 | -- 92 | -- r <- reduce (+) . mapKeyB (\w -> (w, 1 :: Int)) $ getText words "hello world hello" 93 | -- localIO $ putStr "SOLUTION: " >> print r 94 | -- assert (sort (M.toList r) == sort [("hello",2::Int),("world",1)]) $ return r 95 | 96 | -- local $ exit () 97 | -- print "SUCCESS" 98 | -- exitSuccess 99 | 100 | 101 | runNodes nodes= foldr (<|>) empty (map listen nodes) <|> return () 102 | 103 | 104 | #else 105 | 106 | main= return () 107 | #endif 108 | -------------------------------------------------------------------------------- /tests/Testspark.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} 2 | module Main where 3 | import Transient.Base 4 | import Transient.Stream.Resource 5 | import Data.Char 6 | import Control.Monad.IO.Class 7 | 8 | main= keep . threads 0 $ do 9 | chunk <- sourceFile "../transient.cabal" 10 | liftIO $ print chunk 11 | return $ map toUpper chunk 12 | `sinkFile` "outfile" 13 | 14 | -------------------------------------------------------------------------------- /tests/api.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env execthirdlinedocker.sh 2 | -- info: use sed -i 's/\r//g' file if report "/usr/bin/env: ‘execthirdlinedocker.sh\r’: No such file or directory" 3 | -- runghc -i../transient/src -i../transient-universe/src -i../axiom/src tests/api.hs -p start/localhost/8000 4 | 5 | 6 | {- execute as ./tests/api.hs -p start// 7 | 8 | invoque: 9 | 10 | 11 | curl http://:/api 12 | 13 | to get some examples 14 | 15 | -} 16 | 17 | import Transient.Internals 18 | import Transient.Move 19 | import Transient.Move.Utils 20 | import Transient.Indeterminism 21 | import Control.Applicative 22 | import Transient.Logged 23 | import Control.Concurrent(threadDelay) 24 | import Control.Monad.IO.Class 25 | import qualified Data.ByteString.Lazy.Char8 as BS 26 | import qualified Data.ByteString as BSS 27 | import Data.Aeson 28 | import System.IO.Unsafe 29 | import Data.IORef 30 | 31 | 32 | helpmessage= "Invoke examples:\n\ 33 | \ GET: curl http://localhost:8000/api/hello/john\n\ 34 | \ curl http://localhost:8000/api/hellos/john\n\ 35 | \ POST: curl http://localhost:8000/api/params -d \"name=Hugh&age=30\"\n\ 36 | \ curl -H \"Content-Type: application/json\" http://localhost:8000/api/json -d '{\"name\":\"Hugh\",\"age\": 30}'\n" 37 | 38 | 39 | main = keep $ initNode apisample 40 | -- onAll $ liftIO $ putStrLn "\n\n" >> putStrLn helpmessage >> putStrLn "\n\n" 41 | 42 | 43 | apisample= (api $ gets <|> posts <|> badRequest) <|> localIO (print "hello") 44 | 45 | where 46 | 47 | posts= do 48 | received POST 49 | postJSON <|> postParams 50 | 51 | postJSON= do 52 | 53 | received "json" 54 | 55 | json <- param 56 | 57 | liftIO $ print (json :: Value) 58 | let msg= "received: " ++ show json ++ "\n" 59 | 60 | return $ BS.pack $ "HTTP/1.0 200 OK\nContent-Type: text/plain\nContent-Length: "++ show (length msg) 61 | ++ "\nConnection: close\n\n" ++ msg 62 | 63 | postParams= do 64 | received "params" 65 | postParams <- param 66 | liftIO $ print (postParams :: PostParams) 67 | let msg= "received\n" 68 | return $ BS.pack $ "HTTP/1.0 200 OK\nContent-Type: text/plain\nContent-Length: "++ show (length msg) 69 | ++ "\nConnection: close\n\n" ++ msg 70 | 71 | gets= do 72 | received GET 73 | hello <|> hellostream 74 | 75 | hello= do 76 | received "hello" 77 | 78 | name <- param 79 | 80 | let msg= "hello " ++ name ++ "\n" 81 | len= length msg 82 | return $ BS.pack $ "HTTP/1.0 200 OK\nContent-Type: text/plain\nContent-Length: "++ show len 83 | ++ "\nConnection: close\n\n" ++ msg 84 | 85 | 86 | hellostream = do 87 | received "hellos" 88 | name <- param 89 | header <|> stream name 90 | 91 | where 92 | 93 | header=async $ return $ BS.pack $ 94 | "HTTP/1.0 200 OK\nContent-Type: text/plain\nConnection: close\n\n"++ 95 | "here follows a stream\n" 96 | stream name= do 97 | i <- threads 0 $ choose [1 ..] 98 | liftIO $ threadDelay 100000 99 | return . BS.pack $ " hello " ++ name ++ " "++ show i 100 | 101 | badRequest = return $ BS.pack $ 102 | 103 | let resp="Bad Request\n"++ helpmessage 104 | in "HTTP/1.0 400 Bad Request\nContent-Length: " ++ show(length resp) 105 | ++"\nConnection: close\n\n"++ resp 106 | 107 | 108 | 109 | -------------------------------------------------------------------------------- /tests/build.sh: -------------------------------------------------------------------------------- 1 | ghc -i../transient/src -i../transient-universe/src -i../axiom/src -i../ghcjs-perch/src $1 2 | -------------------------------------------------------------------------------- /tests/buildrun.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | 4 | 5 | 6 | 7 | set -e 8 | 9 | 10 | 11 | ghcjs -j2 -isrc -i../transient/src -i../transient-universe/src -i../axiom/src -i../ghcjs-perch/src $1 -o static/out 12 | 13 | 14 | runghc -i../transient/src -i../transient-universe/src -i../axiom/src -i../ghcjs-perch/src $1 $2 $3 $4 15 | -------------------------------------------------------------------------------- /tests/cell.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | import Transient.Base 3 | import Transient.Move 4 | import Transient.Move.Utils 5 | import GHCJS.HPlay.Cell 6 | import GHCJS.HPlay.View 7 | import Control.Monad.IO.Class 8 | import Control.Monad 9 | 10 | 11 | -- ++> adds rendering to a widget 12 | 13 | main= keep $ initNode $ inputNodes <|> app 14 | 15 | app= onBrowser $ local $ render $ do 16 | mk space (Just 1) ! size "10" <|> br ++> 17 | mk time (Just 2) ! size "10" <|> br ++> 18 | mk speed (Just 3) ! size "10" 19 | 20 | calc 21 | where 22 | size= atr "size" 23 | 24 | space = scell "space" $ do -- runCloud $ atRemote $ local $ do 25 | liftIO $ print "running cella at server" 26 | norender $ gcell "speed" * gcell "time" 27 | 28 | time = scell "time" $ do -- runCloud $ atRemote $ local $ do 29 | liftIO $ print "running cellb at server" 30 | norender $ gcell "space" / gcell "speed" 31 | 32 | speed = scell "speed" $ do -- runCloud $ atRemote $ local $ do 33 | liftIO $ print "running cellc at server" 34 | norender $ gcell "space" / gcell "time" 35 | 36 | 37 | 38 | 39 | 40 | -------------------------------------------------------------------------------- /tests/certificate.csr: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE REQUEST----- 2 | MIICxzCCAa8CAQAwgYExCzAJBgNVBAYTAkVTMQswCQYDVQQIDAJBTDERMA8GA1UE 3 | BwwIQWxpY2FudGUxEjAQBgNVBAoMCVRyYW5zaWVudDEaMBgGA1UEAwwRQWxiZXJ0 4 | byBHLiBDb3JvbmExIjAgBgkqhkiG9w0BCQEWE2Fnb2Nvcm9uYUBnbWFpbC5jb20w 5 | ggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQCtCzOpiBpg1ze58hWrwirG 6 | GMjgUG4YC4px37fhhBhalXCkyQHXL7L5iFsOuuoLEymVm7XmKnqHGLoidaOtVKsO 7 | OF3rVWbkFma2llewNQBtW1ESpxMUv4Ff0OmIk6wzUvyRauH0Lh5g+/DRkYXM+Yqx 8 | psjxnVu1wguu0JK22vb9ZBU8yiJMmvUkG7mz+ZxJtPeHPm6r6RInYqNOQzwIRrhG 9 | Fs12jt/uIxby9yp9QU5IIPkTND+P7JgVj940oavKDcaOFiQDbtg7OoNBRrz2RC0z 10 | 7VDSTiNeIa5cF4q6zsFCqWa5pdGERvJmEiQCnLJGb1QOg0iBObeVzGATiUbub3xj 11 | AgMBAAGgADANBgkqhkiG9w0BAQsFAAOCAQEAAJ85w+4Sat6C7jbqrsMXxRrxMdIQ 12 | d+icek80MtuLp95o22auWAyhE7qD8C/XOed3x57HqdikCk4FX/8/ypzVriy6bKem 13 | pm1Ym96nY1SKA8cWqOR/2tLW88sFRqvuCv+n5nMCBKCJSnK15YxfJ3DU/KTXvQHJ 14 | OQE3a4o8q0jA85Dduk+BaqqQtc4yREQWdCb9WfM/JeIh8JyaCc100dNcmzctPJmp 15 | 2pktQgHTSMGLbWBjA94Kx7Ad1WKPtXUXPGOZpjEZmRlN+EOkQChtSdXfrDf0IhcA 16 | GOqL+VyP7zf5uEILCyFp4A//91SJKsT+qDT5+c7E31FXD29rt78a/42iTQ== 17 | -----END CERTIFICATE REQUEST----- 18 | -------------------------------------------------------------------------------- /tests/certificate.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE----- 2 | MIIDgDCCAmgCCQCPngD5S+HGtzANBgkqhkiG9w0BAQsFADCBgTELMAkGA1UEBhMC 3 | RVMxCzAJBgNVBAgMAkFMMREwDwYDVQQHDAhBbGljYW50ZTESMBAGA1UECgwJVHJh 4 | bnNpZW50MRowGAYDVQQDDBFBbGJlcnRvIEcuIENvcm9uYTEiMCAGCSqGSIb3DQEJ 5 | ARYTYWdvY29yb25hQGdtYWlsLmNvbTAeFw0xNzAyMTAxNTI3MzJaFw0xNzAzMTIx 6 | NTI3MzJaMIGBMQswCQYDVQQGEwJFUzELMAkGA1UECAwCQUwxETAPBgNVBAcMCEFs 7 | aWNhbnRlMRIwEAYDVQQKDAlUcmFuc2llbnQxGjAYBgNVBAMMEUFsYmVydG8gRy4g 8 | Q29yb25hMSIwIAYJKoZIhvcNAQkBFhNhZ29jb3JvbmFAZ21haWwuY29tMIIBIjAN 9 | BgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEArQszqYgaYNc3ufIVq8IqxhjI4FBu 10 | GAuKcd+34YQYWpVwpMkB1y+y+YhbDrrqCxMplZu15ip6hxi6InWjrVSrDjhd61Vm 11 | 5BZmtpZXsDUAbVtREqcTFL+BX9DpiJOsM1L8kWrh9C4eYPvw0ZGFzPmKsabI8Z1b 12 | tcILrtCSttr2/WQVPMoiTJr1JBu5s/mcSbT3hz5uq+kSJ2KjTkM8CEa4RhbNdo7f 13 | 7iMW8vcqfUFOSCD5EzQ/j+yYFY/eNKGryg3GjhYkA27YOzqDQUa89kQtM+1Q0k4j 14 | XiGuXBeKus7BQqlmuaXRhEbyZhIkApyyRm9UDoNIgTm3lcxgE4lG7m98YwIDAQAB 15 | MA0GCSqGSIb3DQEBCwUAA4IBAQCV9UZ5ym/fgitS0HmgvroFY9DCrz5lLGCxJw1v 16 | nfCxRzebtskgnbb1nX/dk8HLA/9qxjWMxr9hNHINgY+ER6yfJl2/tRfvziDlHpio 17 | O4tprK/HincK7g53jntXpJAvam0k2431SmV+KOBhVD80BEivmDlHI0S+n9SZlF50 18 | Xb9zHw5unLj8+iM6+ySRSgPAdroWFWgxCt8yFfKVubLyYDLfywSxLKbcEhvhW1iU 19 | AJkwhRjALJ9E5G9OmDIhmEVf01hlZxnZ2oiAk0WoEFqgMzXgTc8XEydkVIpm2UkO 20 | e1mN9AraJYMe/xzKuv5VS+2afYtI0JI/M0ttj0bT64Y0ZluR 21 | -----END CERTIFICATE----- 22 | -------------------------------------------------------------------------------- /tests/chen.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env execthirdlinedocker.sh 2 | -- info: use sed -i 's/\r//g' file if report "/usr/bin/env: ‘execthirdlinedocker.sh\r’: No such file or directory" 3 | -- runghc -DDEBUG -i../transient/src -i../transient-universe/src -i../axiom/src tests/chen.hs -p start/localhost/8000 4 | 5 | {-# LANGUAGE ScopedTypeVariables, OverloadedStrings, NoImplicitPrelude, DeriveGeneric #-} 6 | module Main 7 | (main 8 | ) where 9 | 10 | import Protolude hiding (async,local,Symbol,option, onException) 11 | import Transient.Base 12 | import Transient.Move.Internals 13 | import Transient.Move.Services 14 | import Transient.EVars 15 | import Transient.Indeterminism 16 | import Transient.Internals 17 | import Transient.Move.Utils 18 | import Transient.Parse 19 | import Control.Applicative 20 | import Data.Monoid 21 | import Control.Concurrent 22 | 23 | import Data.String 24 | import Control.Monad.State 25 | --import System.IO 26 | import Control.Exception hiding (onException) 27 | import Data.Char 28 | import Data.Aeson 29 | 30 | import qualified Data.ByteString as BS 31 | import qualified Data.ByteString.Lazy.Char8 as BSL 32 | import GHC.Generics 33 | 34 | getRESTReq= "GET /station?id=eq.$1 HTTP/1.1\r\n" 35 | <> "Host: $hostnode\r\n" 36 | -- <> "Connection: close\r\n" 37 | <> "\r\n" :: String 38 | 39 | getRestService = [("type","HTTP") 40 | ,("nodehost","47.112.196.170") 41 | ,("nodeport","9001"),("HTTPstr",getRESTReq)] 42 | 43 | postRESTReq= "POST /station HTTP/1.1\r\n" 44 | <> "Host: $hostnode\r\n" 45 | -- <> "Connection: close\r\n" 46 | <> "Content-Type: application/json\r\n" 47 | <> "Content-Length: $1\r\n\r\n" 48 | <> "$2" :: String 49 | 50 | postRestService= [("type","HTTP") 51 | ,("nodehost","47.112.196.170") 52 | ,("nodeport","9001"),("HTTPstr",postRESTReq)] 53 | 54 | 55 | 56 | 57 | type Literal = BS.ByteString -- appears with " " 58 | type Symbol= String -- no " when translated 59 | 60 | data Station = Station { name :: Text, remarks :: Maybe Text} deriving (Generic) 61 | instance ToJSON Station 62 | 63 | data PostResponse= OK | ErrorPost Value deriving (Typeable, Read,Show) 64 | 65 | instance Loggable1 PostResponse where 66 | serialize _ = undefined 67 | 68 | deserialize = (ErrorPost <$> deserialize) <|> return OK 69 | 70 | 71 | main= keep $ initNode $ inputNodes <|> do 72 | local $ option ("go" :: String) "go" 73 | 74 | let s1 = Station "stat16" (Just "zhongzhou5") 75 | let jsonmsg= BSL.unpack $ encode s1 76 | let len= length jsonmsg 77 | msg <- callService postRestService (len,jsonmsg) :: Cloud PostResponse 78 | local $ do 79 | headers <- getState <|> return (HTTPHeaders ("","","")[]) 80 | liftIO $ print headers 81 | liftIO $ print ("MESSAGE", msg) 82 | 83 | {- 84 | r <- callService getRestService (1 ::Int) 85 | local $ do 86 | headers <- getState <|> return (HTTPHeaders []) 87 | liftIO $ print headers 88 | localIO $ print (r :: Value) 89 | -} -------------------------------------------------------------------------------- /tests/distributedApps.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ./execthirdline.sh 2 | -- compile all the transient libraries whith ghcjs and run with ghc 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/tests/$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/tests/$1 $2 $3 $4" 4 | 5 | 6 | -- compile it with ghcjs and execute it with runghc 7 | -- 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}" 8 | 9 | 10 | -- 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" 11 | 12 | -- usage: ./distributedApps.hs -p start// 13 | 14 | {-# LANGUAGE CPP, NoMonomorphismRestriction, DeriveDataTypeable #-} 15 | 16 | module Main where 17 | 18 | import Prelude hiding (div,id) 19 | import Transient.Internals 20 | 21 | import GHCJS.HPlay.Cell 22 | import GHCJS.HPlay.View hiding (map, input,option,parent) 23 | 24 | import Transient.Move 25 | import Transient.EVars 26 | import Transient.Indeterminism 27 | 28 | import Control.Applicative 29 | import qualified Data.Vector as V 30 | import qualified Data.Map as M 31 | import Transient.MapReduce 32 | import Control.Monad.IO.Class 33 | import Control.Monad 34 | import Data.String 35 | import qualified Data.Text as T 36 | 37 | #ifdef ghcjs_HOST_OS 38 | import qualified Data.JSString as JS hiding (span,empty,strip,words) 39 | #endif 40 | 41 | import Data.Typeable 42 | import Data.Monoid 43 | 44 | import qualified Data.ByteString.Lazy.Char8 as BS 45 | import Transient.Logged 46 | 47 | 48 | import Transient.Internals 49 | import Control.Concurrent.MVar 50 | import System.IO.Unsafe 51 | import Control.Concurrent 52 | import Control.Monad.State 53 | import Control.Concurrent.STM 54 | 55 | data Options= MapReduce | Chat | MonitorNodes | AllThree deriving (Typeable, Read, Show) 56 | 57 | 58 | main = keep $ initNode $ inputNodes <|> menuApp <|> thelink 59 | 60 | 61 | 62 | 63 | thelink= do 64 | local . render $ rawHtml $ do 65 | br;br 66 | a ! href (fs "https://github.com/agocorona/transient-universe/blob/master/examples/distributedApps.hs") $ "source code" 67 | empty 68 | 69 | menuApp= do 70 | local . render . rawHtml $ do 71 | h1 "Transient Demo" 72 | br; br 73 | op <- local . render $ 74 | tlink MapReduce (b "map-reduce") <++ fs " " <|> 75 | tlink Chat (b "chat") <++ fs " " <|> 76 | tlink MonitorNodes (b "monitor nodes") <++ fs " " <|> 77 | tlink AllThree (b "all widgets") 78 | 79 | case op of 80 | AllThree -> allw 81 | MapReduce -> mapReduce -- !> " option mapReduce" 82 | Chat -> chat 83 | MonitorNodes -> monitorNodes 84 | 85 | 86 | allw= mapReduce <|> chat <|> monitorNodes 87 | 88 | 89 | 90 | 91 | -- A Web node launch a map-reduce computation in all the server nodes, getting data from a 92 | -- textbox and render the results returned 93 | 94 | mapReduce= onBrowser $ do 95 | 96 | content <- local . render $ 97 | h1 "Map-Reduce widget" ++> 98 | p "Return the frequencies of words from a text using all the server nodes connected" ++> 99 | textArea (fs "") ! atr "placeholder" (fs "enter the content") 100 | ! atr "rows" (fs "4") 101 | ! atr "cols" (fs "80") 102 | <++ br 103 | <** inputSubmit "send" `fire` OnClick 104 | <++ br 105 | -- return () !> ("content",content) 106 | 107 | guard (content /= "") 108 | msg <- local genNewId 109 | let entry= boxCell msg ! size (fs "60") 110 | 111 | r <- atRemote $ do 112 | lliftIO $ print content 113 | 114 | 115 | r<- reduce (+) . mapKeyB (\w -> (w, 1 :: Int)) $ distribute $ V.fromList $ words content 116 | lliftIO $ putStr "result:" >> print r 117 | return (r :: M.Map String Int) 118 | 119 | 120 | local . render $ rawHtml $ do 121 | h1 "Results" 122 | mconcat[i "word " >> b w >> i " appears " >> b n >> i " times" >> br 123 | | (w,n) <- M.assocs r] 124 | 125 | empty 126 | 127 | fs= fromString 128 | size= atr (fs "size") 129 | -- a chat widget that run in the browser and in a cloud of servers 130 | 131 | 132 | chat = onBrowser $ do 133 | let chatbox= fs "chatbox" -- <- local genNewId 134 | local . render . rawHtml $ do -- Perch monads 135 | h1 "Federated chat server" 136 | 137 | div ! id chatbox 138 | ! style (fs $"overflow: auto;height: 200px;" 139 | ++ "background-color: #FFCC99; max-height: 200px;") 140 | $ noHtml -- create the chat box 141 | 142 | sendMessages <|> waitMessages chatbox 143 | 144 | where 145 | 146 | sendMessages = do 147 | 148 | let msg = fs "messages" -- <- local genNewId 149 | let entry= boxCell msg ! size (fs "60") 150 | (nick,text) <- local . render $ (,) <$> getString (Just "anonymous") ! size (fs "10") 151 | <*> mk entry Nothing `fire` OnChange 152 | <** inputSubmit "send" 153 | <++ br 154 | local $ entry .= "" 155 | guard (not $ null text) 156 | 157 | atRemote $ do 158 | node <- local getMyNode 159 | clustered $ local $ putMailbox (showPrompt nick node ++ text ) >> empty :: Cloud () 160 | empty 161 | 162 | where 163 | 164 | showPrompt u (Node h p _ _)= u ++ "@" ++ h ++ ":" ++ show p ++ "> " 165 | 166 | waitMessages chatbox = do 167 | 168 | resp <- atRemote . local $ do 169 | labelState $ "getMailbox" 170 | r <- single getMailbox 171 | return r 172 | -- wait in the server for messages 173 | 174 | local . render . at (fs "#" <> chatbox) Append $ rawHtml $ do 175 | p (resp :: String) -- display the response 176 | #ifdef ghcjs_HOST_OS 177 | liftIO $ scrollBottom $ fs "chatbox" 178 | 179 | 180 | foreign import javascript unsafe 181 | "var el= document.getElementById($1);el.scrollTop= el.scrollHeight" 182 | scrollBottom :: JS.JSString -> IO() 183 | #endif 184 | 185 | monitorNodes= onBrowser $ do 186 | local . render $ rawHtml $ do 187 | h1 "Nodes connected" 188 | div ! atr (fs "id") (fs "nodes") $ noHtml 189 | 190 | nodes <- atRemote . local . single $ sample getNodes 1000000 191 | 192 | local . render . at (fs "#nodes") Insert . rawHtml $ 193 | table $ mconcat[tr $ td h >> td p >> td s | Node h p _ s <- nodes] 194 | empty 195 | -------------------------------------------------------------------------------- /tests/dockerclean.sh: -------------------------------------------------------------------------------- 1 | docker kill $(docker ps -q) 2 | docker rm $(docker ps -a -q) 3 | docker rmi $(docker images -q -f dangling=true) 4 | -------------------------------------------------------------------------------- /tests/execcluster.sh: -------------------------------------------------------------------------------- 1 | set -e 2 | # compile=`sed -n '3p' ${1} | sed 's/-- //'` 3 | # execute=`sed -n '4p' ${1} | sed 's/-- //'` 4 | 5 | 6 | # compile with ghcjs and ghc, run a cluster of N nodes: -p start// N 7 | 8 | compile (){ 9 | docker run -v $(pwd):/devel agocorona/transient:24-03-2017 bash -c "cd /devel && ghcjs -DGHCJS_BROWSER $1 -o static/out && ghc -O -threaded -rtsopts -j2 $1" 10 | } 11 | 12 | compile_no_ghcjs (){ 13 | docker run -v $(pwd):/devel agocorona/transient:24-03-2017 bash -c "cd /devel && ghc -O -threaded -rtsopts -j2 $1" 14 | } 15 | 16 | execute() { 17 | docker run -p ${port}:${port} -v $(pwd):/devel agocorona/transient:24-03-2017 bash -c "cd devel && $executable -p start/${host}/$port/add/${host}/$baseport/y +RTS -N" 18 | } 19 | 20 | executeone(){ 21 | docker run -p ${port}:${port} -v $(pwd):/devel agocorona/transient:24-03-2017 bash -c "cd devel && $1 $2 $3" 22 | } 23 | 24 | # compile with ghcjs and ghc with develop. libraries, run a cluster of N nodes: -p start// N 25 | 26 | compiled() { 27 | docker run -v /c/Users/magocoal/OneDrive/Haskell/devel:/devel agocorona/transient:24-03-2017 bash -c "cd /devel/transient-universe-tls/tests && mkdir -p static && ghcjs -DGHCJS_BROWSER --make -j2 -isrc -i/devel/transient/src -i/devel/transient-universe/src -i/devel/transient-universe-tls/src -i/devel/axiom/src -i/devel/ghcjs-perch/src $1 -o static/out && ghc -O -threaded -rtsopts --make -j2 -isrc -i/devel/transient/src -i/devel/transient-universe/src -i/devel/transient-universe-tls/src -i/devel/axiom/src -i/devel/ghcjs-perch/src $1" 28 | } 29 | 30 | 31 | nnodes=$4 32 | 33 | re='^[0-9]+$' 34 | if ! [[ $nnodes =~ $re ]] ; then 35 | nnodes=1 36 | fi 37 | 38 | host=`echo ${3} | awk -F/ '{print $(2)}'` 39 | baseport=`echo ${3} | awk -F/ '{print $(3)}'` 40 | finalport=`expr $baseport + $nnodes` 41 | port=$baseport 42 | executable=./$(basename $1 .hs) 43 | 44 | echo "compiling" 45 | compile_no_ghcjs $1 46 | 47 | echo executing $nnodes nodes 48 | if [ $nnodes -eq 1 ] 49 | then 50 | $executeone $executable $2 $3 51 | else 52 | while [ "$port" -lt "$finalport" ] 53 | do 54 | execute $executable & # >> log${port}.log & 55 | sleep 1 56 | ((port++)) 57 | done 58 | fi 59 | echo "done" 60 | 61 | 62 | -------------------------------------------------------------------------------- /tests/execthirdline.sh: -------------------------------------------------------------------------------- 1 | command=`sed -n '3p' ${1} | sed 's/-- //'` 2 | eval $command $1 $2 $3 3 | -------------------------------------------------------------------------------- /tests/ghcjs-websockets.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, DeriveDataTypeable, 3 | UnboxedTuples, GHCForeignImportPrim, UnliftedFFITypes, 4 | MagicHash, OverloadedStrings 5 | #-} 6 | import JavaScript.Web.WebSocket 7 | import JavaScript.Web.MessageEvent 8 | import Data.JSString (JSString) 9 | 10 | 11 | 12 | main :: IO () 13 | main = do 14 | wsloc <- wslocation 15 | print wsloc 16 | ws <- connect WebSocketRequest 17 | { url = wsloc -- "ws://localhost:2000" 18 | , protocols = ["chat"] 19 | , onClose = Just $ const $ return() -- Maybe (CloseEvent -> IO ()) -- ^ called when the connection closes (at most once) 20 | , onMessage = Just recMessage -- Maybe (MessageEvent -> IO ()) -- ^ called for each message 21 | } 22 | print "CONEXION REALIZADA" 23 | send "HELLOHELLOHELLOHELLOHELLOHELLO" ws 24 | 25 | recMessage e= -- print "SOMething HAS BEEN RECEIVED" 26 | do 27 | let d = getData e 28 | case d of 29 | StringData str -> putStrLn "RECEIVED " >> print str 30 | BlobData blob -> error " blob" 31 | ArrayBufferData arrBuffer -> error "arrBuffer" 32 | 33 | 34 | foreign import javascript unsafe 35 | "var loc = window.location, new_uri;\ 36 | \if (loc.protocol === \"https:\") {\ 37 | \ new_uri = \"wss:\";\ 38 | \} else {\ 39 | \ new_uri = \"ws:\";\ 40 | \}\ 41 | \new_uri += \"//\" + loc.host;\ 42 | \new_uri += loc.pathname;\ 43 | \$r = new_uri" 44 | wslocation :: IO JSString 45 | 46 | 47 | 48 | -------------------------------------------------------------------------------- /tests/hasrocket: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/transient-haskell/transient-universe/7cfbbdfa8eefbea79f48ccb69bc1823ba9abc7ea/tests/hasrocket -------------------------------------------------------------------------------- /tests/hasrocket.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ./execthirdline.sh 2 | -- compile and run within a docker image 3 | -- set -e && executable=`basename -s .hs ${1}` && docker run -it -v $(pwd):/work agocorona/transient:04-02-2017 bash -c "cabal install mono-traversable unagi-chan && ghc /work/${1} && /work/${executable} ${2} ${3}" 4 | 5 | 6 | -- transient application for the websocket shootout 7 | -- https://github.com/hashrocket/websocket-shootout 8 | 9 | {-#LANGUAGE OverloadedStrings, ScopedTypeVariables #-} 10 | 11 | module Main where 12 | import Transient.Internals 13 | import Transient.Move 14 | --import Transient.EVars 15 | import Control.Applicative 16 | import Transient.Logged 17 | import Transient.Move.Utils 18 | --import Data.Text hiding (empty) 19 | import Control.Monad.IO.Class 20 | 21 | 22 | import qualified Data.Aeson as Aeson 23 | import qualified Network.WebSockets.Connection as WS 24 | import qualified Data.ByteString.Lazy.Char8 as BS 25 | import Data.Containers 26 | import System.IO.Unsafe 27 | 28 | import System.Mem.StableName 29 | 30 | import Control.Concurrent 31 | import Data.IORef 32 | import qualified Data.Map as M 33 | import Control.Exception 34 | import Control.Monad 35 | import qualified Control.Concurrent.Chan.Unagi as Unagi 36 | 37 | rmap= unsafePerformIO $ newIORef M.empty 38 | 39 | data Msg = Echo | Broadcast BS.ByteString 40 | 41 | main= keep' . freeThreads $ do 42 | broad <- newEVar 43 | -- clients <- liftIO $ newIORef [] -- (M.empty) 44 | initNode $ apisample broad 45 | 46 | 47 | 48 | apisample5 clients = Cloud $ do 49 | Connection _(Just (Node2Web conn )) _ _ _ _ _ _ <- getSData <|> error "ERRROR" 50 | msg <- paramVal 51 | processMessage conn msg 52 | <|> do 53 | Connection _(Just (Node2Web conn )) _ _ _ _ _ _ <- getSData <|> error "ERRROR" 54 | liftIO . atomicModifyIORef clients $ \m -> ( conn :m , ()) 55 | where 56 | processMessage conn msg= do 57 | case parseMsg msg of 58 | -- Nothing -> error "NOTHING" -- WS.sendClose conn ("Invalid message" :: BS.ByteString) 59 | 60 | Just Echo -> liftIO $ WS.sendTextData conn msg 61 | 62 | Just (Broadcast res) -> do 63 | 64 | cs <- liftIO $ readIORef clients 65 | liftIO $ mapM (flip WS.sendTextData msg) cs -- !> (length cs) 66 | liftIO $ WS.sendTextData conn res 67 | 68 | 69 | parseMsg :: BS.ByteString -> Maybe Msg 70 | parseMsg msg = do 71 | Aeson.Object obj <- Aeson.decode msg 72 | Aeson.String typ <- Data.Containers.lookup "type" obj 73 | 74 | case typ of 75 | "echo" -> Just Echo 76 | 77 | "broadcast" -> let 78 | res = Aeson.encode (insertMap "type" "broadcastResult" obj) 79 | in Just (Broadcast res) 80 | 81 | _ -> Nothing 82 | 83 | 84 | apisample broad= api $ 85 | 86 | do msg <- paramVal 87 | processMessage broad msg 88 | <|> watchBroadcast broad 89 | 90 | 91 | 92 | processMessage broad msg= do 93 | Aeson.Object obj <- emptyIfNothing $ Aeson.decode msg 94 | Aeson.String typ <- emptyIfNothing $ Data.Containers.lookup "type" obj 95 | case typ of 96 | "echo" -> return msg 97 | "broadcast" -> do 98 | let res = Aeson.encode $ insertMap "type" "broadcastResult" obj 99 | writeEVar broad msg 100 | return res 101 | 102 | 103 | watchBroadcast broad= threads 0 $ readEVar broad 104 | 105 | emptyIfNothing= Transient . return 106 | 107 | 108 | data EVar a= EVar (Unagi.InChan ( StreamData a)) 109 | 110 | readEVar :: EVar a -> TransIO a 111 | readEVar (EVar ref1)= do 112 | tchan <- liftIO $ Unagi.dupChan ref1 113 | mx <- parallel $ Unagi.readChan tchan `catch` \(e :: SomeException) -> error $ show e 114 | case mx of 115 | SError e -> finish $ Just e 116 | SMore x -> return x 117 | 118 | 119 | newEVar :: TransIO (EVar a) 120 | newEVar = Transient $ do 121 | (ref, _) <- liftIO $ Unagi.newChan 122 | return . Just $ EVar ref 123 | 124 | writeEVar (EVar ref1) x= liftIO $ do 125 | Unagi.writeChan ref1 $ SMore x 126 | 127 | -------------------------------------------------------------------------------- /tests/iterate.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | ghc -j2 -isrc -i../transient/src -i../transient-universe/src -i../ghcjs-hplay/src -i../ghcjs-perch/src tests/hasrocket.hs -O2 -threaded -rtsopts "-with-rtsopts=-N -A64m -n2m" 4 | ./tests/hasrocket -p start/localhost/8080 & 5 | sleep 2 6 | ../websocket-shootout/bin/websocket-bench broadcast ws://127.0.0.1:8080/ws -c 4 -s 40 --step-size 100 7 | -------------------------------------------------------------------------------- /tests/key.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN RSA PRIVATE KEY----- 2 | MIIEpQIBAAKCAQEArQszqYgaYNc3ufIVq8IqxhjI4FBuGAuKcd+34YQYWpVwpMkB 3 | 1y+y+YhbDrrqCxMplZu15ip6hxi6InWjrVSrDjhd61Vm5BZmtpZXsDUAbVtREqcT 4 | FL+BX9DpiJOsM1L8kWrh9C4eYPvw0ZGFzPmKsabI8Z1btcILrtCSttr2/WQVPMoi 5 | TJr1JBu5s/mcSbT3hz5uq+kSJ2KjTkM8CEa4RhbNdo7f7iMW8vcqfUFOSCD5EzQ/ 6 | j+yYFY/eNKGryg3GjhYkA27YOzqDQUa89kQtM+1Q0k4jXiGuXBeKus7BQqlmuaXR 7 | hEbyZhIkApyyRm9UDoNIgTm3lcxgE4lG7m98YwIDAQABAoIBAH6cFpWxJpO6hGSB 8 | 0wdTztYYZklxr8vaDdbZuIHBk8wbUUrQY49dsBbRhMZXTk0CHUgAoOuiIvpbxjzW 9 | VAbLT0jdRyKb3ud92HM5tzkO3pwk10HNirGAmRlREr3CRpla279OM7rkT4fobr/3 10 | OK3L24W2IYpe9y4ap0+l/eLafSLR9nURhz/Q8wTIjYV9mxAbTYgb/wvDeiDeVlom 11 | I03C2um6AAqmx9ltGFUGNV7r6zLwUG8tvaWJyFF1e8jHY+PVWhyRTP65H53tbEgk 12 | gNJrIdd4rjz3qqO9lzisBd/XImHX7HRPX7vvynokvqaNjAHrNeUb08mA7XrAEuAB 13 | 1PtTz2ECgYEA2Ip5AjhCRXUPmL66eQg7jzjTaXG8dThA8F6hJY0gQrmpBp4tMf3R 14 | tc8J60oZrpIukprbuH9OjrUPE5WxPZIg4ppItBf5qRWprvHIL3i/hekP4/59YdTQ 15 | D/7MK2a9fOuNNxd6dfSit96FoFNVcQt0Nnn9U9qv92CqXRragHJe39ECgYEAzJOb 16 | uPFp6PnG0E4E7Q7W2qZySSHsN5om2Ckqpsc6H6e0gvLN3KQtLFFaAElyr7/LUCQD 17 | ccBBc8RW4tYPqghyPixCByKk5SKJ1voV7GSXdevmtfccVB2pORCg0RJn3F94EJ/j 18 | /86ezrwFyTRpGCgaEMKSXm/PznFFc9PYv7gzufMCgYEAv/EeimUr+T1mcdK+oAI4 19 | KSAJ5fG3R4Bxr59x4ENUUVEZDpCvJx0CAtJezH2GfkN9nN4/3S6bh8vebVHHJfid 20 | xb9Uqq6F0ucs3bHb7JhvzFdmioZOxaVKOKN2fxI27MAvEKJzHpOWmL1aXV8A4Y9x 21 | l8hSUT4LtI+u85CWFj1K88ECgYEArvmZeYfSpFfu+n+gqvnEPuOaYH7JQY1xp/Ud 22 | 6+P/DNAuDsqJ1Sv/DybNqe0oULXkubjz0Tk1QkUuY3nfj/kFbbQBDYVOMEVoTB0+ 23 | 3x/yhAOvIvgmnLN557sXMXtiphRp5x46rrMVFZGwCTXwpZ63HJqvAmL0BIjRdI4/ 24 | l0t/wo0CgYEA1beM5dxv6RrqJxY8RyA/qECuNtrXcCMrjCud96irpew3RFj1+H6C 25 | 17NDkbfzZZIl75JFEy7ncbRQeo8QRA1wqxkb0J0yAn9l8cHVV/6WBRVFeIt4mBP7 26 | oHRLc68+Qn+RGlR854CTQVjYxNYUiEosI1u0yRIO6erIKHMohsy9FyY= 27 | -----END RSA PRIVATE KEY----- 28 | -------------------------------------------------------------------------------- /tests/nikita.hs: -------------------------------------------------------------------------------- 1 | import Prelude hiding (div, id) 2 | import Transient.Base 3 | import Transient.Move 4 | import GHCJS.HPlay.View 5 | import Control.Applicative 6 | import Data.String 7 | import Control.Monad.IO.Class 8 | import Data.IORef 9 | import Data.Typeable 10 | 11 | fs= fromString 12 | 13 | data AppState = AppState 14 | { appStateMessage :: Int } 15 | deriving (Read, Show) 16 | 17 | data Action 18 | = ButtonClicked 19 | | Stop 20 | deriving (Read, Show, Eq) 21 | 22 | (|>) = flip ($) 23 | 24 | initialAppState :: AppState 25 | initialAppState = AppState 0 26 | 27 | 28 | main= keep $ initNode $ onBrowser $ do 29 | local . render . rawHtml $ div ! id (fs "appdiv") $ noHtml 30 | displayState 31 | app 32 | 33 | app :: Cloud () 34 | 35 | app = do 36 | action <- displayButton 37 | updateState action 38 | displayState 39 | 40 | 41 | 42 | displayButton :: Cloud Action 43 | displayButton = local $ render $ wbutton ButtonClicked (fromString "Click me") 44 | 45 | displayState= local $ do 46 | appState <- getAppState 47 | render $ at (fs "#appdiv") Insert $ do 48 | rawHtml (appStateMessage appState |> show |> h1) 49 | 50 | updateState ButtonClicked = local $ do 51 | AppState v <- getAppState 52 | setAppState (AppState $ v+1) 53 | 54 | getAppState :: TransIO AppState 55 | getAppState= getRData <|> (setRData initialAppState >> return initialAppState) 56 | 57 | setAppState :: AppState -> TransIO () 58 | setAppState= setRData 59 | 60 | 61 | --------------------------------------------- State References in the TransIO monad ------------ 62 | newtype Ref a = Ref (IORef a) 63 | 64 | -- | An state reference that can be updated (similar to STRef in the state monad) 65 | -- 66 | -- Initialized the first time it is set. 67 | setRData:: Typeable a => a -> TransIO () 68 | setRData x= do 69 | Ref ref <- getSData 70 | liftIO $ atomicModifyIORef ref $ const (x,()) 71 | <|> do 72 | ref <- liftIO (newIORef x) 73 | setData $ Ref ref 74 | 75 | getRData :: Typeable a => TransIO a 76 | getRData= do 77 | Ref ref <- getSData 78 | liftIO $ readIORef ref 79 | -------------------------------------------------------------------------------- /tests/raft.hs: -------------------------------------------------------------------------------- 1 | module Transient.Raft where 2 | 3 | import Control.Applicative 4 | import Data.Monoid 5 | import Control.Monad.IO.Class 6 | import Transient.Internals 7 | import Transient.Indeterminism 8 | import Transient.Move 9 | import Transient.Move.Services 10 | import System.IO.Unsafe 11 | import Data.IORef 12 | import Control.Concurrent(threadDelay) 13 | import Data.Maybe 14 | import System.Random 15 | 16 | rmaster = unsafePerformIO $ newIORef Nothing 17 | 18 | heartbeatTimeout= 10000000 :: Int 19 | 20 | 21 | cunique= local . unique . runCloud 22 | 23 | heartBeat raftNodes = cunique $ do 24 | localIO $ do 25 | threadDelay heartbeatTimeout 26 | atomicModifyIORef rmaster $ const (Nothing,()) 27 | election raftNodes 28 | 29 | raft raftNodes request= do 30 | master <- localIO $ readIORef rmaster 31 | if isNothing master 32 | then election raftNodes >> raft raftNodes request 33 | else do 34 | node <- local getMyNode 35 | if master== Just node then process raftNodes request >>= return . Right 36 | else return $ Left master 37 | 38 | process raftNodes request= do 39 | let half= length raftNodes` div` 2 :: Int 40 | resps <- local $ collect' half 0.1 (fromIntegral heartbeatTimeout) 41 | $ runCloud $ cluster raftNodes request 42 | 43 | if length resps > half then return resps else empty 44 | 45 | election raftNodes= cunique $ do 46 | 47 | sentVote <- onAll . liftIO $ newIORef False !> "election" 48 | 49 | timeoutElection <- localIO $ randomRIO (150, 300) 50 | localIO $ threadDelay timeoutElection 51 | 52 | votes <- mcluster raftNodes . localIO $ atomicModifyIORef sentVote $ \v -> (not v, [v]) 53 | 54 | let nvotes = length $ filter (==True) votes 55 | if nvotes > length raftNodes `div` 2 56 | then do 57 | node <- local getMyNode 58 | cluster raftNodes . localIO $ atomicModifyIORef rmaster $ const (Just node,()) 59 | heartBeat raftNodes 60 | else do 61 | localIO $ atomicModifyIORef sentVote $ const (False,()) 62 | election raftNodes 63 | 64 | cluster nodes proc= callNodes' (<|>) empty nodes proc 65 | mcluster nodes proc= callNodes' (<>) mempty nodes proc 66 | 67 | callNodes' op init nodes proc= foldr op init $ map (\node -> runAt node proc) nodes 68 | 69 | runRaftNodes ports= do 70 | nodes <- onAll $ mapM (\p -> liftIO $ createNodeServ "localhost" p [("raft","raft")]) ports 71 | foldl (<|>) empty (map listen nodes) <|> return() 72 | 73 | 74 | 75 | main= keep $ runCloud $ do 76 | runRaftNodes [4000..4005] 77 | raftNodes <- local getNodes 78 | local $ option "input" "input" 79 | msg <- local $ input (const True) "enter a message >" 80 | r <- raft raftNodes . local $ do 81 | node <- getMyNode 82 | liftIO $ do 83 | putStr "request EXECUTED at node: " 84 | print node 85 | print msg 86 | return msg 87 | :: Cloud (Either (Maybe Node) [String]) 88 | localIO $ do putStr "response from the cluster: "; print r 89 | 90 | 91 | -------------------------------------------------------------------------------- /tests/rundevel.sh: -------------------------------------------------------------------------------- 1 | runghc -i../transient/src -i../transient-universe/src -i../axiom/src -i../ghcjs-perch/src $1 $2 $3 2 | -------------------------------------------------------------------------------- /tests/snippet: -------------------------------------------------------------------------------- 1 | :l tests/Test3.hs 2 | :l examples\Atm.hs 3 | :l examples\webapp.hs 4 | :set -i../ghcjs-hplay/src -i../ghcjs-perch/src 5 | :l examples\DistrbDataSets.hs 6 | :l examples\MainSamples.hs 7 | :l ..\..\stuff\skynet\skynetTrans.hs 8 | 9 | :step main 10 | 11 | 12 | -------------------------------------------------------------------------------- /tests/streamMonad.hs: -------------------------------------------------------------------------------- 1 | import Control.Concurrent.Async 2 | import Control.Concurrent 3 | 4 | newtype Stream a = Stream{ runStream :: IO [Async a]} 5 | 6 | instance Functor Stream where 7 | fmap f (Stream mxs) = Stream $ do 8 | xs <- mxs 9 | return [fmap f x | x <- xs] 10 | 11 | instance Applicative Stream where 12 | pure x= Stream $ do 13 | z <- async $ return x 14 | return [z] 15 | 16 | (Stream mfs) <*> (Stream mas) = Stream $do 17 | as <- mas 18 | fs <- mfs 19 | sequence [ 20 | async $ ( wait f) <*> ( wait a) 21 | | f <- fs, a <- as] 22 | 23 | instance Monad Stream where 24 | return = pure 25 | (Stream mxs) >>= f = Stream $ do 26 | xs <- mxs 27 | rs <- mapM wait xs 28 | rr <- sequence [ runStream $ f r | r <- rs] 29 | return $ concat rr 30 | 31 | 32 | 33 | stream :: [IO a] -> Stream a 34 | stream ioa= Stream $ mapM async ioa 35 | 36 | waitStream :: Stream a -> IO [a] 37 | waitStream (Stream mxs)= do 38 | xs <- mxs 39 | mapM wait xs 40 | 41 | 42 | main= do 43 | r <- waitStream $ stream $ map return [1..10] 44 | print r 45 | r <- waitStream $ do 46 | x <- stream $ map (\x -> do threadDelay 1000000; return x) [1..100] 47 | return $ 2 * x 48 | print r 49 | 50 | where 51 | fact 0 = 1 52 | fact n= n * fact (n -1) 53 | 54 | -------------------------------------------------------------------------------- /tests/test5.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Transient.Base 4 | import Transient.Move 5 | import Transient.Internals 6 | import GHCJS.HPlay.View 7 | import Transient.Move.Utils 8 | import Control.Applicative 9 | import Control.Monad.IO.Class 10 | import Data.String 11 | import Control.Monad.State 12 | 13 | -- to be executed with two or more nodes 14 | main = keep $ initNode $ test 15 | 16 | alert1 x = liftIO $ do alert $ fromString $ show x ; return x 17 | 18 | test= onBrowser $ local $ do 19 | 20 | r <- render $ 21 | (,) <$> getString Nothing `fire` OnChange 22 | <*> getString Nothing `fire` OnChange 23 | <** (inputSubmit "click" `fire` OnClick) 24 | 25 | liftIO $ alert $ fromString $ show r 26 | 27 | (<*|) a b= do 28 | (x,_) <- (,) <$> a <*> b 29 | return x 30 | 31 | --return1 l= do 32 | -- IDNUM id <- getSData <|> error "error" 33 | -- id1 <- gets mfSequence 34 | -- liftIO $ alert $ fromString $ show (id,id1) 35 | -- return l 36 | 37 | 38 | -------------------------------------------------------------------------------- /tests/testIRC.hs: -------------------------------------------------------------------------------- 1 | 2 | import Transient.Base 3 | import Network 4 | import System.IO 5 | import Control.Monad.IO.Class 6 | import Control.Applicative 7 | 8 | -- taken from Pipes example 9 | -- https://www.reddit.com/r/haskell/comments/2jvc78/simple_haskell_irc_client_in_two_lines_of_code/?st=iqj5yxg1&sh=0cb8cc11 10 | -- Simple Haskell IRC client in "two lines of code" 11 | -- 12 | --main = withSocketsDo $ connect "irc.freenode.net" "6667" $ \(s, _) -> 13 | -- forkIO (runEffect $ PBS.stdin >-> toSocket s) >> runEffect (fromSocket s 4096 >-> PBS.stdout) 14 | 15 | 16 | main = do 17 | h <- withSocketsDo $ connectTo "irc.freenode.net" $ PortNumber $ fromIntegral 6667 18 | keep' $ (waitEvents getLine >>= liftIO . hPutStrLn h) <|> ( threads 1 $ waitEvents (hGetLine h) >>= liftIO . putStrLn ) 19 | -------------------------------------------------------------------------------- /tests/testRestService.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env execthirdlinedocker.sh 2 | -- info: use sed -i 's/\r//g' file if report "/usr/bin/env: ‘execthirdlinedocker.sh\r’: No such file or directory" 3 | -- runghc -DDEBUG -i../transient/src -i../transient-universe/src -i../axiom/src tests/testRestService.hs -p start/localhost/8000 4 | 5 | {-# LANGUAGE ScopedTypeVariables, OverloadedStrings, DeriveGeneric #-} 6 | module Main where 7 | 8 | import Transient.Base 9 | import Transient.Move.Internals 10 | import Transient.Move.Services 11 | import Transient.EVars 12 | import Transient.Indeterminism 13 | import Transient.Internals 14 | import Transient.Move.Utils 15 | import Transient.Parse 16 | import Control.Applicative 17 | import Data.Monoid 18 | import Control.Concurrent 19 | 20 | import Data.String 21 | import Control.Monad.State 22 | import System.IO 23 | import Control.Exception 24 | import Data.Char 25 | import Data.Aeson 26 | 27 | import qualified Data.ByteString as BS 28 | import qualified Data.ByteString.Lazy.Char8 as BSL 29 | import GHC.Generics 30 | 31 | 32 | 33 | 34 | getRESTReq= "GET /todos/$1 HTTP/1.1\r\n" 35 | <> "Host: $hostnode\r\n" 36 | <> "\r\n" :: String 37 | 38 | 39 | postRESTReq= "POST /todos HTTP/1.1\r\n" 40 | <> "HOST: $hostnode\r\n" 41 | <> "Content-Type: application/json\r\n\r\n" 42 | <>"{\"id\": $1,\"userId\": $2,\"completed\": $3,\"title\":$4}" 43 | 44 | 45 | postRestService= [("type","HTTP") 46 | ,("nodehost","jsonplaceholder.typicode.com") 47 | ,("nodeport","80"),("HTTPstr",postRESTReq)] 48 | getRestService = [("type","HTTP") 49 | ,("nodehost","jsonplaceholder.typicode.com") 50 | ,("nodeport","80"),("HTTPstr",getRESTReq)] 51 | 52 | 53 | 54 | type Literal = BS.ByteString -- appears with " " 55 | type Symbol= String -- no " when translated 56 | 57 | main= keep $ initNode $ inputNodes <|> do 58 | local $ option ("go" ::String) "go" 59 | 60 | 61 | 62 | 63 | callService postRestService (10 :: Int,4 :: Int, "true" :: Symbol , "title alberto" :: Literal) :: Cloud () 64 | local $ do 65 | headers <- getState <|> return (HTTPHeaders []) 66 | liftIO $ print headers 67 | 68 | r <- callService getRestService (10::Int) 69 | local $ do 70 | headers <- getState <|> return (HTTPHeaders []) 71 | liftIO $ print headers 72 | localIO $ print (r :: Value) 73 | 74 | 75 | -------------------------------------------------------------------------------- /tests/testService.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env execthirdlinedocker.sh 2 | 3 | -- cd /projects/transient && cabal install -f debug --force-reinstalls && cd ../transient-universe && cabal install --force-reinstalls && ghc $1 && exec=`dirname $1`/`basename $1 .hs` && cp $exec /opt/cabal/bin/ && echo $exec $2 $3 $4 && $exec $2 $3 $4 4 | 5 | {-# LANGUAGE CPP, ScopedTypeVariables #-} 6 | 7 | 8 | import Transient.Internals 9 | import Transient.Move.Internals 10 | import Transient.Indeterminism 11 | import Transient.Move.Utils 12 | import Transient.Logged 13 | import Transient.Move.Services 14 | import Transient.Move.Services.Executor 15 | import Control.Applicative 16 | import Control.Monad 17 | 18 | import Data.Typeable 19 | import Data.IORef 20 | import Control.Concurrent (threadDelay) 21 | import Control.Monad.State 22 | import Control.Exception hiding (onException) 23 | import System.IO.Unsafe 24 | import Data.Maybe 25 | 26 | 27 | import System.IO 28 | import System.Process 29 | import Control.Concurrent 30 | {- 31 | 32 | 33 | example record updates, distributed database? 34 | connect. Un servicio para conectar añadir instancias? 35 | 36 | 37 | connect created instances 38 | connectNode as service. 39 | 40 | 41 | a transient service as REST service: in the http treatment in listen: /a/b/c/d -> (a,b,c,d) 42 | 43 | option to discover the types of service parameters: 44 | get the services 45 | return the types 46 | 47 | -} 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | main = keep $ runService [("executable","testService")] 8000 [serve selfService] $ do 63 | control2 <|> examples 64 | 65 | 66 | examples= do 67 | local $ option "examples" "some examples and test of service usage" 68 | ping1 <|> ping2 <|> singleExec <|> stream <|> 69 | failThreeTimes <|> many1 <|> fail3requestNew <|> 70 | requestAtHost <|> self <|> distrib 71 | 72 | distrib= do 73 | local $ option "dis" "request another instance of this program and call it" 74 | this <- local getMyNode 75 | localIO $ print this 76 | [node] <- requestInstance (nodeServices this) 1 77 | local $ option "launch" "launch" 78 | r <- runAt node $ return "hello world" 79 | localIO $ print r 80 | 81 | 82 | control2 = control <|> spawn1 83 | 84 | spawn1= do 85 | local $ option "spawn" "spawn a bash shell and a loop that can be visited/controlled" 86 | networkExecuteStream' "bash" 87 | networkExecuteStream' "./loop.sh 'hello'" 88 | localIO $ putStrLn "SPAWNED\n\nUse \"control\" to manage the processes" 89 | empty 90 | 91 | control= do 92 | local $ option "control" "control a node or process initiated by previous examples" 93 | cloudControl 94 | 95 | 96 | cloudControl= do 97 | localIO $ putStrLn "\n...........VISIBLE NODES AND PROCESSES............" 98 | 99 | callService monitorService () :: Cloud () -- start/ping monitor if not started 100 | 101 | localIO $ do 102 | 103 | putStr $ nodeHost monitorNode 104 | putChar ':' 105 | putStr $ show $ nodePort monitorNode 106 | putChar '/' 107 | putStrLn $ fromJust $ lookup "service" $ nodeServices monitorNode 108 | squeezeMonitor 4 monitorNode 109 | where 110 | 111 | squeezeMonitor tab nod= do 112 | nodes <- callService' nod GetNodes :: Cloud [Node] 113 | 114 | 115 | vis <- local $ do 116 | visited <- getState <|> return [] 117 | let vis = nod `elem` visited 118 | when (not vis) $ setState $ nod:visited 119 | return vis 120 | when (not vis) $ spawn $ controlMonitor nod 121 | 122 | mapM_ squeeze $ tail nodes 123 | where 124 | 125 | squeeze node= do 126 | vis <- local $ do 127 | visited <- getState <|> return [] 128 | let vis= node `elem` visited 129 | when (not vis) $ setState $ node:visited 130 | return vis 131 | when (not vis) $ do 132 | localIO $ do 133 | putStr $ take tab $ repeat ' ' 134 | putStr $ nodeHost node 135 | putChar ':' 136 | putStr $ show $ nodePort node 137 | putChar '/' 138 | putStrLn $ fromJust $ lookup "service" $ nodeServices node 139 | 140 | 141 | 142 | case lookup "service" $ nodeServices node of 143 | 144 | Just "monitor" -> do 145 | spawn $ controlMonitor node 146 | visited <- local $ getState <|> return [] 147 | when (not $ node `elem` visited) $ do 148 | local $ setState $ node:visited 149 | 150 | localIO $ do 151 | putStr $ take tab $ repeat ' ' 152 | putStr " " 153 | putStrLn "Services:" 154 | squeezeMonitor (tab+4) node 155 | 156 | Just "executor" -> do 157 | spawn $ controlService node 158 | procs <- callService' node GetProcesses :: Cloud [String] 159 | 160 | 161 | when (not $ null procs) $ do 162 | localIO $ do 163 | putStr $ take tab $ repeat ' ' 164 | putStrLn " Running processes:" 165 | mapM_ ( spawn . controlProcess) procs 166 | 167 | _ -> return () 168 | 169 | controlMonitor node= do 170 | local $ do 171 | n <- getState <|> return (0 :: Int) 172 | setState $ n +1 173 | liftIO $ putStr "\t\t" 174 | option1 n "control this node\n" 175 | abduce 176 | controlNode node 177 | 178 | controlService node= do 179 | local $ do 180 | n <- getState <|> return (0 :: Int) 181 | setState $ n +1 182 | liftIO $ putStr "\t\t" 183 | option1 n "control this node\n" 184 | abduce 185 | 186 | controlNodeService node 187 | 188 | spawn f= (f >> empty) <|> return () 189 | 190 | controlProcess str= do 191 | local $ do 192 | n <- getState <|> return (0 :: Int) 193 | setState $ n +1 194 | liftIO $ do 195 | putStr $ take tab $ repeat ' ' 196 | putStr " " 197 | putStrLn str 198 | putStr "\t\t" 199 | option1 n "control this process\n" 200 | abduce 201 | controlNodeProcess str 202 | 203 | 204 | 205 | 206 | {- 207 | registerUpdate= do 208 | local $ option "reg" "simulate a two way reactive database update service" 209 | reg <- input (const True) "enter register content " 210 | reg' <- updateDistributedDatabase reg 211 | localIO $ putStr "new register changed: " >> putStrLn reg' 212 | 213 | in the service, made by the same service executable running in different machines and connected among them: 214 | 215 | updateDistributedDatabaseIt= clustered $ do 216 | update reg 217 | return reg 218 | -} 219 | 220 | self= do 221 | local $ option "own" "call a service of my own program" 222 | 223 | nod <- local $ getMyNode 224 | 225 | r <- callService' nod "Alberto" :: Cloud String 226 | localIO $ print r 227 | 228 | selfService str = localIO $ return $ "hello " ++ str 229 | 230 | ping1 = do 231 | local $ option "ping1" "ping monitor (must have been started)" 232 | r <- callService' monitorNode () 233 | localIO $ print (r :: ()) 234 | 235 | 236 | ping2 = do 237 | local $ option "ping" "ping two executors, must return: [((),())]" 238 | 239 | ns <- requestInstance executorService 2 240 | r <- mapM ping ns 241 | localIO $ print r 242 | 243 | 244 | 245 | singleExec= do 246 | local $ option "single" "execution of \"ls -al\" in a executor process" 247 | r <- networkExecute "ls -al" "" 248 | localIO $ print ("RESULT",r) 249 | 250 | 251 | 252 | 253 | stream= do 254 | local $ setRState False 255 | local $ option "stream" "start a remote shell with the executor, then executes different command inputs and stream results" 256 | r <- networkExecuteStream "bash" 257 | s <- local getRState 258 | if s then localIO $ putStr "[bash]" >> print r 259 | else do 260 | local $ setRState True 261 | inputs r -- the first output of the command is the process identifier 262 | where 263 | inputs idproc= do 264 | command <- local $ do 265 | option "send" "send to the remote shell" 266 | input (const True) "command" 267 | sendExecuteStream idproc command 268 | empty 269 | 270 | 271 | fail3requestNew= do 272 | local $ option "fail6" "try a new instance" 273 | 274 | retries <- onAll $ liftIO $ newIORef (0 :: Int) 275 | 276 | local $ onException $ retry6 retries 277 | 278 | r <- networkExecute "UNKNOWN COMMAND" "" 279 | 280 | localIO $ print ("LINE=",r :: String ) 281 | 282 | where 283 | retry6 retries (CloudException node _ _ )= runCloud $ do 284 | localIO $ print ("tried to execute in", node) 285 | n <- onAll $ liftIO $ atomicModifyIORef retries $ \n -> (n+1,n+1) 286 | localIO $ print ("NUMBER OF RETRIES",n) 287 | 288 | if n == 3 then do 289 | localIO $ putStrLn "failed after three retries, reclaiming new instance" 290 | local continue 291 | [node'] <- requestInstanceFail node 1 292 | localIO $ print ("NEW NODE FOR SERVICE", node') 293 | 294 | else if n < 6 then local continue 295 | 296 | else localIO $ print "failed after six retries with two instances, aborting" 297 | 298 | 299 | failThreeTimes= do 300 | local $ option "fail" "fail after three retries" 301 | 302 | 303 | retries <- onAll $ liftIO $ newIORef (0 :: Int) 304 | 305 | let retry3 e= do 306 | liftIO $ print e 307 | n <- liftIO $ atomicModifyIORef retries $ \n -> (n+1,n+1) 308 | liftIO $ print ("NUMBER OF RETRIES",n) 309 | if n < 3 then continue else do 310 | liftIO $ print "failed after three retries" 311 | empty 312 | 313 | local $ onException $ \(e :: CloudException) -> retry3 e 314 | 315 | r <- networkExecute "UNKNOWN COMMAND" "" 316 | 317 | localIO $ print ("LINE=",r :: String ) 318 | 319 | many1= do 320 | local $ option "many" "show how a command is tried to be executed in different executor instances" 321 | requestInstance executorService 5 322 | retries <- onAll $ liftIO $ newIORef (0 :: Int) 323 | 324 | local $ onException $ \e -> retry1 5 retries e 325 | 326 | networkExecute "unknow command" "" 327 | 328 | return () 329 | 330 | where 331 | retry1 n' retries (CloudException node _ _ )= do 332 | liftIO $ print ("tried to execute in", node) 333 | n <- liftIO $ atomicModifyIORef retries $ \n -> (n+1,n+1) 334 | liftIO $ print ("NUMBER OF RETRIES",n) 335 | if n < n' then continue else do 336 | liftIO $ putStr "stop after " >> putStr (show n) >> putStrLn "retries" 337 | empty 338 | 339 | requestAtHost= do 340 | local $ option "host" "request the execution of a shell process at a given machine" 341 | hostname <- local $ input (const True) "enter the hostname (the machine should have monitorService running at port 3000) " 342 | process <- local $ input (const True) "enter the process to run (for example: bash) " 343 | line <- atHost hostname process <|> inputCommands process 344 | localIO $ print ("LINE", line) 345 | where 346 | inputCommands process= do 347 | 348 | local $ option "inp" "enter input for the process created" 349 | inp <- local $ input (const True) "input string: " :: Cloud String 350 | callService executorService (process, inp) :: Cloud() 351 | empty 352 | 353 | atHost :: String -> String -> Cloud String 354 | atHost hostname process = do 355 | executor <- requestInstanceHost hostname executorService 356 | callService' executor process 357 | 358 | 359 | 360 | 361 | -------------------------------------------------------------------------------- /tests/teststream.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, ScopedTypeVariables #-} 2 | 3 | module Main where 4 | 5 | import Network 6 | import qualified Network.Socket as NS 7 | import qualified Network.BSD as BSD 8 | 9 | 10 | import System.IO hiding (hPutBufNonBlocking) 11 | import Control.Concurrent 12 | import Control.Monad 13 | import Control.Exception 14 | import Control.Monad.IO.Class 15 | import qualified Data.ByteString.Char8 as BS 16 | import Foreign.Ptr 17 | import Foreign.Storable 18 | import Data.ByteString.Internal 19 | import Foreign.ForeignPtr.Safe 20 | 21 | import GHC.IO.Handle.Types 22 | import GHC.IO.Handle.Internals 23 | import GHC.IO.Buffer 24 | import GHC.IO.BufferedIO as Buffered 25 | import GHC.IO.Device as RawIO 26 | import GHC.IO.FD 27 | import GHC.Word 28 | import Data.IORef 29 | import Data.Typeable 30 | import System.IO.Unsafe 31 | import Data.Monoid 32 | 33 | main = do 34 | 35 | let port= PortNumber 2000 36 | 37 | forkIO $ listen' port 38 | h <- connectTo' "localhost" port 39 | liftIO $ hSetBuffering h $ BlockBuffering Nothing 40 | loop h 0 41 | getChar 42 | where 43 | loop h x = hPutStrLn' h (show x) >> loop h (x +1) 44 | 45 | hPutStrLn' h str= do 46 | let bs@(PS ps s l) = BS.pack $ str ++ "\n" 47 | n <- withForeignPtr ps $ \p-> hPutBufNonBlocking h (p `plusPtr` s) l 48 | when( n < l) $ do 49 | print (n,l) 50 | print "BUFFER FULLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL" 51 | hFlush h 52 | print "AFTER BUFFER FLUSHHHH" 53 | withForeignPtr ps $ \p -> hPutBuf h ( p `plusPtr` (n * sizeOf 'x' ) ) (l - n) 54 | print "AFTER HPUTBUF" 55 | return () 56 | 57 | connectTo' hostname (PortNumber port) = do 58 | proto <- BSD.getProtocolNumber "tcp" 59 | bracketOnError 60 | (NS.socket NS.AF_INET NS.Stream proto) 61 | (sClose) -- only done if there's an error 62 | (\sock -> do 63 | NS.setSocketOption sock NS.SendBuffer 300 64 | he <- BSD.getHostByName hostname 65 | NS.connect sock (NS.SockAddrInet port (BSD.hostAddress he)) 66 | 67 | NS.socketToHandle sock ReadWriteMode 68 | ) 69 | 70 | hPutBufNonBlocking handle ptr count 71 | | count == 0 = return 0 72 | | count < 0 = error "negative chunk size" 73 | | otherwise = 74 | wantWritableHandle "hPutBuf" handle $ 75 | \ h_@Handle__{..} -> bufWriteNonBlocking h_ (castPtr ptr) count False 76 | 77 | 78 | 79 | bufWriteNonBlocking :: Handle__-> Ptr Word8 -> Int -> Bool -> IO Int 80 | bufWriteNonBlocking h_@Handle__{..} ptr count can_block = 81 | seq count $ do -- strictness hack 82 | old_buf@Buffer{ bufR=w, bufSize=size } <- readIORef haByteBuffer 83 | -- print (size,w, count) 84 | old_buf'@Buffer{ bufR=w', bufSize = size' } <- 85 | if size - w <= count 86 | then do 87 | (written,old_buf') <- Buffered.flushWriteBuffer0 haDevice old_buf 88 | writeIORef haByteBuffer old_buf' 89 | print (size , written,w, count) 90 | print (bufSize old_buf', bufR old_buf') 91 | return old_buf' 92 | else return old_buf 93 | 94 | let count'= if size' - w' > count then count else size' - w' 95 | writeChunkNonBlocking h_ (castPtr ptr) count' 96 | writeIORef haByteBuffer old_buf'{ bufR = w' + count' } 97 | 98 | return count' 99 | 100 | 101 | 102 | writeChunkNonBlocking h_@Handle__{..} ptr bytes 103 | | Just fd <- cast haDevice = RawIO.writeNonBlocking (fd::FD) ptr bytes 104 | | otherwise = error "Todo: hPutBuf" 105 | 106 | 107 | 108 | 109 | listen' port = do 110 | sock <- withSocketsDo $ listenOn port 111 | (h,host,port1) <- accept sock 112 | hSetBuffering h $ BlockBuffering Nothing 113 | repeatRead h 114 | where 115 | repeatRead h= do 116 | forkIO $ doit h 117 | return() 118 | where 119 | doit h= do 120 | s <- hGetLine h 121 | -- print s 122 | --threadDelay 10 123 | doit h 124 | 125 | 126 | 127 | 128 | -------------------------------------------------------------------------------- /tests/teststreamsocket.hs: -------------------------------------------------------------------------------- 1 | test.hs{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-} 2 | 3 | module Main where 4 | 5 | import Network 6 | import qualified Network.Socket as NS hiding (send, sendTo, recv, recvFrom) 7 | import Network.Socket.ByteString 8 | import qualified Network.BSD as BSD 9 | 10 | 11 | import System.IO hiding (hPutBufNonBlocking) 12 | import Control.Concurrent 13 | import Control.Monad 14 | import Control.Exception 15 | import Control.Monad.IO.Class 16 | import qualified Data.ByteString.Char8 as BS 17 | import Foreign.Ptr 18 | import Foreign.Storable 19 | import Data.ByteString.Internal 20 | import Foreign.ForeignPtr.Safe 21 | 22 | 23 | 24 | main = do 25 | 26 | 27 | let host= "localhost"; port= 2000 28 | forkIO $ listen' $ PortNumber port 29 | proto <- BSD.getProtocolNumber "tcp" 30 | bracketOnError 31 | (NS.socket NS.AF_INET NS.Stream proto) 32 | (sClose) -- only done if there's an error 33 | (\sock -> do 34 | NS.setSocketOption sock NS.RecvBuffer 3000 35 | he <- BSD.getHostByName "localhost" 36 | NS.connect sock (NS.SockAddrInet port (BSD.hostAddress he)) 37 | loop sock 0 38 | getChar) 39 | where 40 | loop sock x = do 41 | 42 | let msg = BS.pack $ show x ++ "\n" 43 | let l = BS.length msg 44 | n <- send sock msg 45 | when (n < l) $ do 46 | print $ "CONGESTION "++ show (l-n) 47 | sendAll sock $ BS.drop n msg 48 | 49 | loop sock (x +1) 50 | 51 | 52 | 53 | 54 | 55 | 56 | listen' port = do 57 | sock <- listenOn port 58 | (h,host,port1) <- accept sock 59 | hSetBuffering h $ BlockBuffering Nothing 60 | repeatRead h 61 | where 62 | repeatRead h= do 63 | forkIO $ doit h 64 | return() 65 | where 66 | doit h= do 67 | s <- hGetLine h 68 | print s 69 | threadDelay 1000000 70 | doit h 71 | 72 | 73 | 74 | 75 | -------------------------------------------------------------------------------- /tests/testtls.hs: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/transient-haskell/transient-universe/7cfbbdfa8eefbea79f48ccb69bc1823ba9abc7ea/tests/testtls.hs -------------------------------------------------------------------------------- /transient-universe.cabal: -------------------------------------------------------------------------------- 1 | name: transient-universe 2 | version: 0.5.2 3 | cabal-version: >=1.10 4 | build-type: Simple 5 | license: MIT 6 | license-file: LICENSE 7 | maintainer: agocorona@gmail.com 8 | homepage: https://github.com/transient-haskell/transient-universe 9 | bug-reports: https://github.com/transient-haskell/transient-universe/issues 10 | synopsis: Remote execution and map-reduce: distributed computing for Transient 11 | description: 12 | See . 13 | category: Control, Distributed Computing 14 | author: Alberto G. Corona 15 | extra-source-files: 16 | ChangeLog.md README.md 17 | app/client/Transient/Move/Services/void.hs 18 | app/server/Transient/Move/Services/MonitorService.hs 19 | app/server/Transient/Move/Services/executor.hs 20 | 21 | source-repository head 22 | type: git 23 | location: https://github.com/transient-haskell/transient-universe 24 | 25 | library 26 | 27 | if !impl(ghcjs >=0.1) 28 | exposed-modules: 29 | Transient.Move.Services.Executor 30 | 31 | if impl(ghcjs >=0.1) 32 | build-depends: 33 | -- ghcjs-base should be installed with 34 | -- > git clone https://github.com/ghcjs/ghcjs-base 35 | -- > cabal install --ghcjs --constraint 'primitive < 0.6.4' 36 | ghcjs-base -any, 37 | ghcjs-prim -any, 38 | random -any 39 | else 40 | build-depends: 41 | HTTP -any, 42 | TCache >= 0.12, 43 | case-insensitive -any, 44 | directory -any, 45 | filepath -any, 46 | hashable -any, 47 | iproute -any, 48 | network < 3, 49 | network-info -any, 50 | network-uri -any, 51 | vector -any, 52 | websockets -any, 53 | process == 1.6.5.0, 54 | random -any, 55 | text -any, 56 | aeson -any, 57 | primitive < 0.6.4.0, 58 | entropy <= 0.3.6 59 | -- new versions forces the installation of a new cabal version. Tired of that. 60 | 61 | exposed-modules: 62 | Transient.Move 63 | Transient.MapReduce 64 | Transient.Move.Internals 65 | Transient.Move.Utils 66 | Transient.Move.Services 67 | build-depends: 68 | base >4 && <5, 69 | bytestring -any, 70 | containers, 71 | mtl -any, 72 | stm -any, 73 | time -any, 74 | transformers -any, 75 | transient >= 0.6.0.0 76 | default-language: Haskell2010 77 | hs-source-dirs: src . 78 | 79 | executable monitorService 80 | 81 | if !impl(ghcjs >=0.1) 82 | build-depends: 83 | transformers -any, 84 | containers, 85 | transient >= 0.6.0.0, 86 | transient-universe, 87 | process, 88 | directory, 89 | bytestring 90 | hs-source-dirs: app/server/Transient/Move/Services 91 | main-is: MonitorService.hs 92 | else 93 | hs-source-dirs: app/client/Transient/Move/Services 94 | main-is: void.hs 95 | build-depends: 96 | base >4 && <5 97 | 98 | 99 | default-language: Haskell2010 100 | ghc-options: -threaded -rtsopts 101 | 102 | 103 | executable executor 104 | if !impl(ghcjs >=0.1) 105 | build-depends: 106 | containers, 107 | transformers -any, 108 | transient >= 0.6.2, 109 | transient-universe, 110 | process, 111 | directory, 112 | bytestring, 113 | aeson, 114 | time 115 | hs-source-dirs: app/server/Transient/Move/Services 116 | main-is: executor.hs 117 | else 118 | hs-source-dirs: app/client/Transient/Move/Services 119 | main-is: void.hs 120 | build-depends: 121 | base >4 && <5 122 | 123 | 124 | default-language: Haskell2010 125 | ghc-options: -threaded -rtsopts 126 | 127 | executable controlServices 128 | if !impl(ghcjs >=0.1) 129 | build-depends: 130 | containers, 131 | transformers -any, 132 | transient >= 0.6.2, 133 | transient-universe, 134 | process, 135 | directory, 136 | bytestring, 137 | aeson, 138 | time 139 | hs-source-dirs: app/server/Transient/Move/Services 140 | main-is: controlServices.hs 141 | else 142 | hs-source-dirs: app/client/Transient/Move/Services 143 | main-is: void.hs 144 | build-depends: 145 | base >4 && <5 146 | 147 | 148 | default-language: Haskell2010 149 | ghc-options: -threaded -rtsopts 150 | 151 | executable test-transient1 152 | 153 | if !impl(ghcjs >=0.1) 154 | build-depends: 155 | mtl -any, 156 | transient >= 0.5.9.2, 157 | random -any, 158 | text -any, 159 | containers -any, 160 | directory -any, 161 | filepath -any, 162 | stm -any, 163 | HTTP -any, 164 | network -any, 165 | transformers -any, 166 | process -any, 167 | network -any, 168 | network-info -any, 169 | bytestring -any, 170 | time -any, 171 | vector -any, 172 | TCache >= 0.12, 173 | websockets -any, 174 | network-uri -any, 175 | case-insensitive -any, 176 | hashable -any, 177 | aeson 178 | 179 | main-is: TestSuite.hs 180 | build-depends: 181 | base >4 182 | default-language: Haskell2010 183 | hs-source-dirs: tests src . 184 | ghc-options: -threaded -rtsopts -fno-ignore-asserts 185 | 186 | 187 | test-suite test-transient 188 | 189 | if !impl(ghcjs >=0.1) 190 | build-depends: 191 | mtl -any, 192 | transient >= 0.5.9.2, 193 | random -any, 194 | text -any, 195 | containers -any, 196 | directory -any, 197 | filepath -any, 198 | stm -any, 199 | HTTP -any, 200 | network -any, 201 | transformers -any, 202 | process -any, 203 | network -any, 204 | network-info -any, 205 | bytestring -any, 206 | time -any, 207 | vector -any, 208 | TCache >= 0.12, 209 | websockets -any, 210 | network-uri -any, 211 | case-insensitive -any, 212 | hashable -any, 213 | aeson 214 | type: exitcode-stdio-1.0 215 | main-is: TestSuite.hs 216 | build-depends: 217 | base >4 218 | default-language: Haskell2010 219 | hs-source-dirs: tests src . 220 | ghc-options: -threaded -rtsopts -fno-ignore-asserts 221 | -------------------------------------------------------------------------------- /universe.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/transient-haskell/transient-universe/7cfbbdfa8eefbea79f48ccb69bc1823ba9abc7ea/universe.png --------------------------------------------------------------------------------