├── .devcontainer ├── Dockerfile └── devcontainer.json ├── .gitignore ├── README.md ├── axiom ├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── Setup.lhs ├── axiom.cabal ├── axiom.png ├── circle.yml ├── src │ └── GHCJS │ │ └── HPlay │ │ ├── Cell.hs │ │ └── View.hs ├── stack-ghcjs.yaml ├── stack.yaml ├── tests │ └── test.hs └── wrong.html ├── transient-universe-tls ├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── Setup.hs ├── src │ └── Transient │ │ └── TLS.hs ├── stack.yaml ├── tests │ ├── DistrbDataSets.hs │ ├── Test2.hs │ ├── api.hs │ ├── certificate.csr │ ├── certificate.pem │ ├── distributedApps.hs │ ├── execthirdline.sh │ └── key.pem └── transient-universe-tls.cabal ├── transient-universe ├── .gitignore ├── .travis.yml ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── app │ ├── client │ │ └── Transient │ │ │ └── Move │ │ │ └── Services │ │ │ └── void.hs │ └── server │ │ └── Transient │ │ └── Move │ │ └── Services │ │ ├── MonitorService.hs │ │ ├── MonitorService.hsvoid.hs │ │ ├── controlServices.hs │ │ ├── controlServices.hsvoid.hs │ │ ├── executor.hs │ │ └── executor.hsvoid.hs ├── buildrun.sh ├── circle.yml ├── examples │ ├── distributedApps.hs │ └── runweb2.sh ├── hasrocket.prof ├── loop.sh ├── src │ └── Transient │ │ ├── MapReduce.hs │ │ ├── Move.hs │ │ └── Move │ │ ├── Internals.hs │ │ ├── PubSub.hs │ │ ├── Services.hs │ │ ├── Services │ │ └── Executor.hs │ │ └── Utils.hs ├── stack-ghcjs.yaml ├── stack.yaml ├── tests │ ├── Dockerfile │ ├── Parameters.hs │ ├── Stream.hs │ ├── Test.hs │ ├── Test3.hs │ ├── TestSuite.hs │ ├── Testspark.hs │ ├── api.hs │ ├── build.sh │ ├── builder.hs │ ├── buildrun.sh │ ├── cell.hs │ ├── cert.pem │ ├── chen.hs │ ├── distributedApps.hs │ ├── dockerclean.sh │ ├── execcluster.sh │ ├── execthirdline.sh │ ├── ghcjs-websockets.hs │ ├── hasrocket.hs │ ├── hasrocket.prof │ ├── hasrocket1 │ │ ├── ChangeLog.md │ │ ├── LICENSE │ │ ├── Main.hs │ │ ├── Setup.hs │ │ ├── app │ │ │ └── Main.hs │ │ ├── hasrocket-benchmark-transient.cabal │ │ └── hasrocket.hs │ ├── https.hs │ ├── iterate.sh │ ├── job │ │ └── Job.hs │ ├── key.pem │ ├── language.hs │ ├── nikita.hs │ ├── raft.hs │ ├── rundevel.sh │ ├── snippet │ ├── streamMonad.hs │ ├── test22.hs │ ├── test5.hs │ ├── testIRC.hs │ ├── testRestService.hs │ ├── testService.hs │ ├── teststream.hs │ ├── teststreamsocket.hs │ ├── teststruct.hs │ └── testtls.hs ├── transient-universe.cabal ├── transient-universe.cabal.new └── universe.png └── transient ├── .gitignore ├── .travis.yml ├── CONTRIBUTING.md ├── ChangeLog.md ├── Dockerfile ├── LICENSE ├── README.md ├── Setup.hs ├── circle.yml ├── logo.png ├── src └── Transient │ ├── Backtrack.hs │ ├── Base.hs │ ├── EVars.hs │ ├── EVars.old.hs │ ├── Indeterminism.hs │ ├── Internals.hs │ ├── Logged.hs │ ├── Mailboxes.hs │ └── Parse.hs ├── stack-ghcjs.yaml ├── stack.yaml ├── tests ├── Test.hs ├── Test2.hs ├── Test3.hs ├── TestSuite.hs ├── Testspark.hs ├── ghcjs-websockets.hs ├── labelthreads.hs ├── puzzle.hs ├── test5.hs ├── teststream.hs └── teststreamsocket.hs └── transient.cabal /.devcontainer/Dockerfile: -------------------------------------------------------------------------------- 1 | # [Choice] Ubuntu version: jammy, focal, bionic 2 | ARG VARIANT="focal" 3 | FROM buildpack-deps:${VARIANT}-curl 4 | 5 | LABEL dev.containers.features="common" 6 | 7 | # Actualizar sistema y dependencias necesarias 8 | RUN apt-get update && export DEBIAN_FRONTEND=noninteractive \ 9 | && apt-get -y install --no-install-recommends \ 10 | build-essential \ 11 | curl \ 12 | libffi-dev libgmp-dev libncurses-dev pkg-config \ 13 | && apt-get clean && rm -rf /var/lib/apt/lists/* 14 | 15 | # Instalar GHCup y Haskell Language Server (HLS) 16 | RUN curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh -s -- --yes \ 17 | && . "/root/.ghcup/env" \ 18 | && ghcup install hls -y 19 | # && ghcup upgrade 20 | 21 | # Configurar PATH de GHCup para Haskell 22 | ENV PATH="/root/.ghcup/bin:${PATH}" 23 | -------------------------------------------------------------------------------- /.devcontainer/devcontainer.json: -------------------------------------------------------------------------------- 1 | { 2 | "image": "codeany/templates-base-ubuntu", 3 | "features": { 4 | "ghcr.io/devcontainers/features/common-utils:1": { 5 | "installZsh": "true", 6 | "username": "vscode", 7 | "uid": "1000", 8 | "gid": "1000", 9 | "upgradePackages": "true" 10 | } 11 | }, 12 | // Use 'forwardPorts' to make a list of ports inside the container available locally. 13 | // "forwardPorts": [], 14 | 15 | // Use 'postCreateCommand' to run commands after the container is created. 16 | // "postCreateCommand": "uname -a", 17 | 18 | // Comment out to connect as root instead. More info: https://aka.ms/vscode-remote/containers/non-root. 19 | "remoteUser": "vscode" 20 | } -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Ignore all 2 | * 3 | 4 | # Unignore all with extensions 5 | !*.* 6 | 7 | # Unignore all dirs 8 | !*/ 9 | 10 | Demos/old-trash 11 | Demos/db 12 | Test 13 | log 14 | *.log 15 | errlog 16 | .tcachedata 17 | .cabal-sandbox 18 | cabal.sandbox* 19 | favicon 20 | IDE.session 21 | MFlow.lkshf 22 | notes.txt 23 | notes.lhs 24 | dist 25 | *.js* 26 | *.o 27 | *.hi 28 | .cabal-sandbox 29 | cabal.sanbox.config 30 | .stack* 31 | # emacs stuff 32 | *~ 33 | \#*\# 34 | /.emacs.desktop 35 | /.emacs.desktop.lock 36 | *.elc 37 | auto-save-list 38 | tramp 39 | .\#* 40 | 41 | # Org-mode 42 | .org-id-locations 43 | *_archive 44 | 45 | # flymake-mode 46 | *_flymake.* 47 | 48 | # eshell files 49 | /eshell/history 50 | /eshell/lastdir 51 | 52 | # elpa packages 53 | /elpa/ 54 | 55 | # vim stuff 56 | *.swp 57 | *.swo 58 | 59 | *.key 60 | _darcs 61 | darcs* 62 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | This new repo contains all the transient libraries 2 | 3 | A new release of transient with a lot of improvements to strenghten the execution model is coming. 4 | 5 | ## What is Transient? 6 | 7 | One of the dreams of software engineering is unrestricted composability. 8 | 9 | This may be put in these terms: 10 | 11 | let `ap1` and `ap2` two applications with arbitrary complexity, with all effects including multiple threads, asynchronous IO, indeterminism, events and perhaps, distributed computing. 12 | 13 | Then the combinations: 14 | 15 | - ap1 <|> ap2 -- Alternative expression 16 | - ap1 >>= \x -> ap2 -- monadic sequence 17 | - ap1 <> ap2 -- monoidal expression 18 | - (,) <$> ap1 <*> ap2 -- Applicative expression 19 | 20 | are possible if the types match, and generate new applications that are composable as well. 21 | 22 | Transient does exactly that. 23 | 24 | The operators `<$>` `<*>` and `<>` express concurrency, the operator `<|>` express parallelism and `>>=` for sequencing of threads, distributed processes or web widgets. So even in the presence of these effects and others, everything is composable. 25 | 26 | For this purpose transient is an extensible effects monad with all major effects and primitives for parallelism, events, asynchronous IO, early termination, non-determinism logging and distributed computing. Since it is possible to extend it with more effects without adding monad transformers, the composability is assured. 27 | 28 | Motivating example 29 | ================== 30 | This program, will stream "hello world" from all the nodes connected if you enter "fire" in the console 31 | 32 | ```Haskell 33 | main= keep $ initNode $ inputNodes <|> distribStream 34 | 35 | distribStream= do 36 | local $ option "fire" "fire" 37 | r <- clustered . local . choose $ repeat "hello world" 38 | localIO $ print r 39 | ``` 40 | Read the tutorial to know how to compile and invoke it. 41 | 42 | This program will present a link in the browser and stream fibonnacci numbers to the browser when 43 | yo click it. (if you have Docker, you can run it straigh from the console; See [this](https://github.com/transient-haskell/axiom#how-to-install--run-fast) 44 | 45 | ```Haskell 46 | main= keep . initNode $ webFib 47 | 48 | webFib= onBrowser $ do 49 | local . render $ wlink () (h1 "hello fibonacci numbers") 50 | 51 | r <- atRemote $ do 52 | r <- local . threads 1 . choose $ take 10 fibs 53 | localIO $ print r 54 | localIO $ threadDelay 1000000 55 | return r 56 | 57 | local . render . rawHtml $ (h2 r) 58 | where 59 | fibs = 0 : 1 : zipWith (+) fibs (tail fibs) :: [Int] 60 | ``` 61 | 62 | This program combines both functionalities: 63 | 64 | ```haskell 65 | main= keep . initNode $ inputNodes <|> webFib <|> distribStream 66 | ``` 67 | 68 | Documentation 69 | ============= 70 | 71 | The [Wiki](https://github.com/agocorona/transient/wiki) is more user oriented 72 | 73 | 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. 74 | 75 | The articles are more technical: 76 | 77 | - [Philosophy, async, parallelism, thread control, events, Session state](https://www.fpcomplete.com/user/agocorona/EDSL-for-hard-working-IT-programmers?show=tutorials) 78 | - [Backtracking and undoing IO transactions](https://www.fpcomplete.com/user/agocorona/the-hardworking-programmer-ii-practical-backtracking-to-undo-actions?show=tutorials) 79 | - [Non-deterministic list like processing, multithreading](https://www.fpcomplete.com/user/agocorona/beautiful-parallel-non-determinism-transient-effects-iii?show=tutorials) 80 | - [Distributed computing](https://www.fpcomplete.com/user/agocorona/moving-haskell-processes-between-nodes-transient-effects-iv?show=tutorials) 81 | - [Publish-Subscribe variables](https://www.schoolofhaskell.com/user/agocorona/publish-subscribe-variables-transient-effects-v) 82 | - [Distributed streaming, map-reduce](https://www.schoolofhaskell.com/user/agocorona/estimation-of-using-distributed-computing-streaming-transient-effects-vi-1) 83 | 84 | These articles contain executable examples (not now, since the site no longer support the execution of haskell snippets). 85 | 86 | 87 | Plans 88 | ===== 89 | Once composability in the large is possible, there are a infinite quantity of ideas that may be realized. There are short term and long term goals. An status of development is regularly published in [![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). 90 | 91 | Among the most crazy ones is the possibility of extending this framework to other languages and make them interoperable. treating whole packaged applications as components, and docking them as lego pieces in a new layer of the Operating system where the shell allows such kind of type safe docking. this composable docker allows all kinds of composability, while the current docker platform is just a form of degraded monoid that do not compute. 92 | 93 | 94 | Once you learn something interesting, you can [contribute to the wiki](https://github.com/transient-haskell/transient/wiki) 95 | 96 | [You can also donate](https://agocorona.github.io/donation.html) 97 | 98 | -------------------------------------------------------------------------------- /axiom/.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 | .cabal-sandbox 16 | cabal.sanbox.config 17 | .stack* 18 | # emacs stuff 19 | *~ 20 | \#*\# 21 | /.emacs.desktop 22 | /.emacs.desktop.lock 23 | *.elc 24 | auto-save-list 25 | tramp 26 | .\#* 27 | 28 | # Org-mode 29 | .org-id-locations 30 | *_archive 31 | 32 | # flymake-mode 33 | *_flymake.* 34 | 35 | # eshell files 36 | /eshell/history 37 | /eshell/lastdir 38 | 39 | # elpa packages 40 | /elpa/ 41 | 42 | # vim stuff 43 | *.swp 44 | *.swo 45 | 46 | *.key 47 | _darcs 48 | darcs* 49 | -------------------------------------------------------------------------------- /axiom/.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 | timeout: 1000 10 | directories: 11 | - $HOME/.ghc 12 | - $HOME/.cabal 13 | - $HOME/.stack 14 | - $HOME/.local/bin 15 | - $HOME/.ghcjs 16 | 17 | 18 | # The different configurations we want to test. We have BUILD=cabal which uses 19 | # cabal-install, and BUILD=stack which uses Stack. More documentation on each 20 | # of those below. 21 | # 22 | # We set the compiler values here to tell Travis to use a different 23 | # cache file per set of arguments. 24 | # 25 | # If you need to have different apt packages for each combination in the 26 | # matrix, you can use a line such as: 27 | # addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}} 28 | matrix: 29 | # Run longest jobs first. 30 | include: 31 | # Build on OS X in addition to Linux 32 | - env: BUILD=stack ARGS="--resolver lts-7" 33 | compiler: ": #stack 8.0.1 LTS 7 (OS X)" 34 | os: osx 35 | 36 | # The Stack builds. We can pass in arbitrary Stack arguments via the ARGS 37 | # variable, such as using --stack-yaml to point to a different file. 38 | - env: BUILD=stack ARGS="--resolver lts-7" 39 | compiler: ": #stack 8.0.1 LTS 7" 40 | addons: {apt: {packages: [ghc-8.0.1], sources: [hvr-ghc]}} 41 | - env: BUILD=stack ARGS="--resolver lts-6" 42 | compiler: ": #stack 7.10.3 LTS 6" 43 | addons: {apt: {packages: [ghc-7.10.3], sources: [hvr-ghc]}} 44 | - env: BUILD=stack ARGS="--resolver lts-5" 45 | compiler: ": #stack 7.10.3 LTS 5" 46 | addons: {apt: {packages: [ghc-7.10.3], sources: [hvr-ghc]}} 47 | - env: BUILD=stack ARGS="--resolver lts-3" 48 | compiler: ": #stack 7.10.2 LTS 3" 49 | addons: {apt: {packages: [ghc-7.10.2], sources: [hvr-ghc]}} 50 | 51 | # Nightly builds are allowed to fail 52 | - env: BUILD=stack ARGS="--resolver nightly" 53 | compiler: ": #stack nightly" 54 | addons: {apt: {packages: [libgmp-dev]}} 55 | 56 | # GHCJS build via stack 57 | - env: BUILD=ghcjs ARGS="--stack-yaml=stack-ghcjs.yaml" 58 | compiler: ": #stack GHCJS" 59 | addons: {apt: {packages: [ghc-8.0.1], sources: [hvr-ghc]}} 60 | 61 | # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See: 62 | # https://github.com/hvr/multi-ghc-travis 63 | - env: BUILD=cabal GHC=8.0.1 CABAL=1.24 64 | compiler: ": #GHC 8.0.1" 65 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}} 66 | - env: BUILD=cabal GHC=7.10.3 CABAL=1.22 67 | compiler: ": #GHC 7.10.3" 68 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}} 69 | - env: BUILD=cabal GHC=7.10.2 CABAL=1.22 70 | compiler: ": #GHC 7.10.2" 71 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2], sources: [hvr-ghc]}} 72 | # Build with the newest GHC and cabal-install. This is an accepted failure, 73 | # see below. 74 | - env: BUILD=cabal GHCVER=head CABALVER=head 75 | compiler: ": #GHC HEAD" 76 | addons: {apt: {packages: [cabal-install-head,ghc-head], sources: [hvr-ghc]}} 77 | 78 | allow_failures: 79 | - env: BUILD=ghcjs ARGS="--stack-yaml=stack-ghcjs.yaml" 80 | - env: BUILD=cabal GHCVER=head CABALVER=head 81 | - env: BUILD=stack ARGS="--resolver nightly" 82 | 83 | before_install: 84 | # Using compiler above sets CC to an invalid value, so unset it 85 | - unset CC 86 | 87 | # We want to always allow newer versions of packages when building on GHC HEAD 88 | - CABALARGS="" 89 | - if [[ "x$GHC" = "xhead" ]]; then CABALARGS=--allow-newer; fi 90 | 91 | # Download and unpack the stack executable 92 | - export PATH=/opt/ghc/$GHC/bin:$HOME/.local/bin:/opt/cabal/$CABAL/bin:$PATH 93 | - mkdir -p $HOME/.local/bin 94 | 95 | # GHC itself is being installed as apt addon already. 96 | - | 97 | case "$BUILD" in 98 | stack) 99 | # Stack Installation 100 | echo "Installing Stack." 101 | if [[ `uname` = "Darwin" ]]; then 102 | curl --insecure -L https://www.stackage.org/stack/osx-x86_64 \ 103 | | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 104 | else 105 | curl -L https://www.stackage.org/stack/linux-x86_64 \ 106 | | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 107 | fi 108 | ;; 109 | cabal) 110 | # Update Cabal packages data 111 | echo "Updating Cabal index" 112 | cabal --version 113 | travis_retry cabal update 114 | ;; 115 | esac 116 | 117 | 118 | 119 | 120 | install: 121 | - | 122 | echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 123 | if [[ -f configure.ac ]]; then autoreconf -i; fi 124 | 125 | - | 126 | echo "Building dependencies." 127 | case "$BUILD" in 128 | stack) 129 | stack --no-terminal $ARGS test --install-ghc --only-dependencies 130 | ;; 131 | cabal) 132 | cabal install --only-dependencies --enable-benchmarks \ 133 | --force-reinstalls --ghc-options=-O0 --reorder-goals \ 134 | --max-backjumps=-1 $CABALARGS 135 | ;; 136 | esac 137 | 138 | script: 139 | - | 140 | case "$BUILD" in 141 | stack) 142 | stack --no-terminal test $ARGS 143 | stack --no-terminal haddock --no-haddock-deps $ARGS 144 | ;; 145 | cabal) 146 | cabal configure --enable-benchmarks -v2 --ghc-options="-O0 -Werror" 147 | cabal build 148 | cabal check || [[ "$CABAL" == "1.16" ]] 149 | cabal test 150 | cabal sdist 151 | cabal copy 152 | SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && \ 153 | (cd dist && cabal install --force-reinstalls "$SRC_TGZ") 154 | ;; 155 | esac 156 | -------------------------------------------------------------------------------- /axiom/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright © 2008-2016 Alberto G. Corona 2 | 2016 Arthur S. Fayzrakhmanov 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy of 5 | this software and associated documentation files (the "Software"), to deal in 6 | the Software without restriction, including without limitation the rights to 7 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 8 | the Software, and to permit persons to whom the Software is furnished to do so, 9 | subject to the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included in all 12 | copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 16 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 17 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 18 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 19 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -------------------------------------------------------------------------------- /axiom/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/runhaskell 2 | > module Main where 3 | > import Distribution.Simple 4 | > main :: IO () 5 | > main = defaultMain 6 | 7 | -------------------------------------------------------------------------------- /axiom/axiom.cabal: -------------------------------------------------------------------------------- 1 | name: axiom 2 | 3 | version: 0.4.7 4 | cabal-version: >=1.10 5 | build-type: Simple 6 | 7 | license: MIT 8 | license-file: LICENSE 9 | author: Alberto Gómez Corona 10 | maintainer: agocorona@gmail.com 11 | 12 | homepage: https://github.com/transient-haskell/axiom 13 | bug-reports: https://github.com/transient-haskell/axiom/issues 14 | synopsis: Web EDSL for running in browsers and server nodes using transient 15 | description: Client-and Server-side Haskell framework that compiles to javascript with the GHCJS compiler and run over Transient. See homepage 16 | category: Web 17 | stability: experimental 18 | 19 | data-dir: "" 20 | extra-source-files: README.md 21 | 22 | source-repository head 23 | type: git 24 | location: http://github.com/agocorona/axiom 25 | 26 | library 27 | build-depends: base > 4.0 && <6.0 28 | , transformers -any 29 | , containers -any 30 | , transient >= 0.6.0.1 31 | , transient-universe >= 0.5.0.0 32 | 33 | , mtl -any 34 | , ghcjs-perch >= 0.3.3 35 | 36 | if impl(ghcjs >=0.1) 37 | build-depends: ghcjs-base -any 38 | else 39 | build-depends: bytestring, directory 40 | 41 | exposed-modules: GHCJS.HPlay.View 42 | GHCJS.HPlay.Cell 43 | exposed: True 44 | buildable: True 45 | default-language: Haskell2010 46 | hs-source-dirs: src . 47 | -------------------------------------------------------------------------------- /axiom/axiom.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/transient-haskell/transient-stack/8bcadfa817551cbe46be17bc6a8a21e1a1ed097e/axiom/axiom.png -------------------------------------------------------------------------------- /axiom/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 | -------------------------------------------------------------------------------- /axiom/stack-ghcjs.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-8.3 2 | 3 | packages: 4 | - . 5 | - location: 6 | git: https://github.com/geraldus/ghcjs-perch.git 7 | commit: 050dbd7c3d9ff5df92b33026127c390e9751d935 8 | extra-dep: true 9 | - '.' 10 | - location: 11 | git: https://github.com/agocorona/transient.git 12 | commit: d3a96df9ecaf0f09f756fb0fc28901e74c894360 13 | extra-dep: true 14 | - location: 15 | git: https://github.com/agocorona/transient-universe.git 16 | commit: 5133ee2707df3203ccdded97bdbeeacdff1888c5 17 | 18 | extra-dep: true 19 | extra-package-dbs: [] 20 | flags: {} 21 | 22 | compiler: ghcjs-0.2.1.9007019_ghc-8.0.1 23 | compiler-check: match-exact 24 | setup-info: 25 | ghcjs: 26 | source: 27 | ghcjs-0.2.1.9007019_ghc-8.0.1: 28 | url: http://ghcjs.tolysz.org/ghc-8.0-2017-02-05-lts-7.19-9007019.tar.gz 29 | sha1: d2cfc25f9cda32a25a87d9af68891b2186ee52f9 30 | allow-newer: true 31 | -------------------------------------------------------------------------------- /axiom/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-8.3 2 | 3 | packages: 4 | - . 5 | - location: 6 | git: https://github.com/geraldus/ghcjs-perch.git 7 | commit: 050dbd7c3d9ff5df92b33026127c390e9751d935 8 | extra-dep: true 9 | - '.' 10 | - location: 11 | git: https://github.com/agocorona/transient.git 12 | commit: b15972a71634efe3b85a1480cecc35b50d424e5d 13 | extra-dep: true 14 | - location: 15 | git: https://github.com/agocorona/transient-universe.git 16 | commit: bf588bde37423b9122a99f0927bb26d8aace8a34 17 | 18 | extra-dep: true 19 | extra-package-dbs: [] 20 | flags: {} 21 | -------------------------------------------------------------------------------- /axiom/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 | -- LIB="/projects/transient-stack" && mkdir -p static && ghcjs -DDEBUG --make -i${LIB}/transient/src -i${LIB}/transient-universe/src -i${LIB}/axiom/src $1 -o static/out && runghc -DDEBUG -w -i${LIB}/transient/src -i${LIB}/transient-universe/src -i${LIB}/axiom/src $1 && `dirname $1`/`basenane $1` $2 $3 4 | 5 | 6 | {-# LANGUAGE CPP #-} 7 | import GHCJS.HPlay.View 8 | import Control.Applicative 9 | import Transient.Base 10 | import Transient.Move.Internals 11 | import Control.Monad.IO.Class 12 | #ifndef ghcjs_HOST_OS 13 | import qualified Network.WebSockets.Connection as WS 14 | import Data.IORef 15 | import qualified Data.ByteString.Lazy.Char8 as BS 16 | #endif 17 | 18 | main = keep $ initNode $ do 19 | local $ setRState (0::Int) 20 | 21 | local $ render $ wbutton "hello" (toJSString "try this") 22 | 23 | 24 | r <- local $ getRState <|> return 0 25 | local $ setRState $ r + 1 26 | atRemote $ localIO $ print r 27 | 28 | local $ render $ wraw (h1 (r :: Int)) 29 | 30 | 31 | 32 | -------------------------------------------------------------------------------- /axiom/wrong.html: -------------------------------------------------------------------------------- 1 | Something went wrong... -------------------------------------------------------------------------------- /transient-universe-tls/.gitignore: -------------------------------------------------------------------------------- 1 | # Ignore all 2 | * 3 | 4 | # Unignore all with extensions 5 | !*.* 6 | 7 | # Unignore all dirs 8 | !*/ 9 | 10 | Demos/old-trash 11 | Demos/db 12 | Test 13 | errlog 14 | .tcachedata 15 | .cabal-sandbox 16 | cabal.sandbox* 17 | favicon 18 | IDE.session 19 | MFlow.lkshf 20 | notes.txt 21 | notes.lhs 22 | dist 23 | *.js* 24 | *.o 25 | *.hi 26 | *.exe 27 | *.lk* 28 | .cabal-sandbox 29 | cabal.sanbox.config 30 | .stack* 31 | # emacs stuff 32 | *~ 33 | \#*\# 34 | /.emacs.desktop 35 | /.emacs.desktop.lock 36 | *.elc 37 | auto-save-list 38 | tramp 39 | .\#* 40 | 41 | # Org-mode 42 | .org-id-locations 43 | *_archive 44 | 45 | # flymake-mode 46 | *_flymake.* 47 | 48 | # eshell files 49 | /eshell/history 50 | /eshell/lastdir 51 | 52 | # elpa packages 53 | /elpa/ 54 | 55 | # vim stuff 56 | *.swp 57 | *.swo 58 | 59 | *.key 60 | _darcs 61 | darcs* 62 | /src/style.css 63 | *.back 64 | -------------------------------------------------------------------------------- /transient-universe-tls/.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 | - env: BUILD=ghcjs ARGS="--stack-yaml=stack-ghcjs.yaml" 76 | - env: BUILD=cabal GHCVER=head CABALVER=head 77 | - env: BUILD=stack ARGS="--resolver nightly" 78 | 79 | before_install: 80 | # Using compiler above sets CC to an invalid value, so unset it 81 | - unset CC 82 | - export CASHER_TIME_OUT=600 83 | 84 | # We want to always allow newer versions of packages when building on GHC HEAD 85 | - CABALARGS="" 86 | - if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi 87 | 88 | # Download and unpack the stack executable 89 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:$PATH 90 | - mkdir -p ~/.local/bin 91 | - | 92 | if [ `uname` = "Darwin" ] 93 | then 94 | curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 95 | else 96 | curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 97 | fi 98 | 99 | install: 100 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 101 | - if [ -f configure.ac ]; then autoreconf -i; fi 102 | - | 103 | case "$BUILD" in 104 | stack) 105 | stack --no-terminal --install-ghc $ARGS test --only-dependencies 106 | ;; 107 | cabal) 108 | cabal --version 109 | travis_retry cabal update 110 | cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS 111 | ;; 112 | ghcjs) 113 | stack --no-terminal setup $ARGS 114 | stack --no-terminal --install-ghc $ARGS test --only-dependencies 115 | ;; 116 | esac 117 | 118 | script: 119 | - | 120 | case "$BUILD" in 121 | cabal) 122 | cabal configure --enable-tests --enable-benchmarks -v2 --ghc-options="-O0 -Werror" 123 | cabal build 124 | cabal check || [ "$CABALVER" == "1.16" ] 125 | cabal test 126 | cabal sdist 127 | cabal copy 128 | SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && \ 129 | (cd dist && cabal install --force-reinstalls "$SRC_TGZ") 130 | ;; 131 | *) 132 | stack --no-terminal $ARGS test --haddock --no-haddock-deps 133 | ;; 134 | esac 135 | -------------------------------------------------------------------------------- /transient-universe-tls/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 | -------------------------------------------------------------------------------- /transient-universe-tls/README.md: -------------------------------------------------------------------------------- 1 | # transient-universe-tls 2 | Secure communications for transient-universe. 3 | 4 | `initTLS` must be called before using any communication. Then any connection with other nodes is atempted to be secure. It is necessary a certificate and a key for the node at the folder where it is executed. Certificate verification from calling nodes is disabled in this version, so encription of messages among nodes, and not verification is the goal initially. 5 | 6 | upon initTLS has been called, any `connect` will try to establish a secure connection or will fail. 7 | 8 | Connection from web nodes accept `https` requests. If a connection is secure, socket communications are encripted too. 9 | 10 | In order to generate a self-signed certificate for testing, try the following: 11 | 12 | openssl genrsa -out key.pem 2048 13 | openssl req -new -key key.pem -out certificate.csr 14 | openssl x509 -req -in certificate.csr -signkey key.pem -out certificate.pem 15 | -------------------------------------------------------------------------------- /transient-universe-tls/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /transient-universe-tls/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-8.3 2 | -------------------------------------------------------------------------------- /transient-universe-tls/tests/Test2.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ./execthirdline.sh 2 | 3 | -- set -e && port=`echo ${3} | awk -F/ '{print $(3)}'` && docker run -it -p ${port}:${port} -v /c/Users/magocoal/OneDrive/Haskell/devel:/devel testtls bash -c "cd /devel/transient-universe-tls/tests/; runghc -j2 -isrc -i/devel/transient/src -i/devel/transient-universe/src -i/devel/transient-universe-tls/src -i/devel/ghcjs-hplay/src -i/devel/ghcjs-perch/src $1 $2 $3 $4" 4 | 5 | {-# LANGUAGE CPP,NoMonomorphismRestriction #-} 6 | 7 | module Main where 8 | 9 | import Prelude hiding (div,id) 10 | import Transient.Base 11 | 12 | 13 | 14 | --import GHCJS.HPlay.Cell 15 | --import GHCJS.HPlay.View 16 | #ifdef ghcjs_HOST_OS 17 | hiding (map, input,option) 18 | #else 19 | hiding (map, option,input) 20 | #endif 21 | 22 | import Transient.Base 23 | import Transient.Move 24 | import Transient.Move.Utils 25 | import Transient.EVars 26 | import Transient.Indeterminism 27 | import Transient.TLS 28 | 29 | import Control.Applicative 30 | import qualified Data.Vector as V 31 | import qualified Data.Map as M 32 | import Transient.MapReduce 33 | import Control.Monad.IO.Class 34 | import Data.String 35 | import Data.Monoid 36 | import qualified Data.Text as T 37 | #ifdef ghcjs_HOST_OS 38 | import qualified Data.JSString as JS hiding (span,empty,strip,words) 39 | #endif 40 | 41 | import Control.Concurrent.MVar 42 | import System.IO.Unsafe 43 | 44 | main= do 45 | let numNodes = 3 46 | keep' . runCloud $ do 47 | runTestNodes [2000 .. 2000 + numNodes - 1] 48 | r <- mclustered $ local $ do 49 | ev <- newEVar 50 | readEVar ev <|> (writeEVar ev "hello" >> empty) 51 | localIO $ print r 52 | 53 | main2= do 54 | -- initTLS 55 | node1 <- createNode "192.168.99.100" 8080 56 | -- keep $ initNode $ do 57 | -- local $ option "s" "start" 58 | node2 <- createNode "localhost" 2001 59 | runCloudIO $ do 60 | 61 | listen node1 <|> listen node2 <|> return () 62 | my <- local getMyNode 63 | r <- runAt my (local (return "hello")) <|> runAt node1 (local (return "world")) 64 | localIO $ print r 65 | 66 | 67 | test :: Cloud () 68 | test= onServer $ do 69 | local $ option "t" "do test" 70 | 71 | r <- wormhole (Node "localhost" 8080 (unsafePerformIO $ newMVar []) []) $ do 72 | teleport 73 | p <- localIO $ print "ping" >> return "pong" 74 | teleport 75 | return p 76 | localIO $ print r 77 | 78 | -------------------------------------------------------------------------------- /transient-universe-tls/tests/api.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ./execthirdline.sh 2 | 3 | -- set -e && port=`echo ${3} | awk -F/ '{print $(3)}'` && docker run -it -p ${port}:${port} -v /c/Users/magocoal/OneDrive/Haskell/devel:/devel testtls bash -c "cd /devel/transient-universe-tls/tests/; runghc -j2 -isrc -i/devel/transient/src -i/devel/transient-universe/src -i/devel/transient-universe-tls/src -i/devel/ghcjs-hplay/src -i/devel/ghcjs-perch/src $1 $2 $3 $4" 4 | 5 | -- compile it with ghcjs and execute it with runghc 6 | -- 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 "runghc /work/${1} ${2} ${3}" 7 | 8 | {- execute as ./api.hs -p start// 9 | 10 | invoque: curl http:////api/hello/john 11 | curl http:////api/hellos/john 12 | curl --data "birthyear=1905&press=%20OK%20" http://1 13 | 92.168.99.100:8080/api/ 14 | -} 15 | {-# LANGUAGE ScopedTypeVariables #-} 16 | import Transient.Internals 17 | import Transient.TLS 18 | import Transient.Move 19 | import Transient.Move.Utils 20 | import Transient.Logged 21 | import Transient.Indeterminism 22 | import Control.Applicative 23 | import Control.Concurrent(threadDelay) 24 | import Control.Monad.IO.Class 25 | import qualified Data.ByteString.Lazy.Char8 as BS 26 | import Control.Exception hiding (onException) 27 | 28 | main = do 29 | initTLS 30 | keep' $ initNode apisample 31 | 32 | apisample= api $ gets <|> posts -- <|> err 33 | where 34 | posts= do 35 | received POST 36 | postParams <- param 37 | liftIO $ print (postParams :: PostParams) 38 | let msg= "received" ++ show postParams 39 | len= length msg 40 | return $ BS.pack $ "HTTP/1.0 200 OK\nContent-Type: text/plain\nContent-Length: "++ show len 41 | ++ "\nConnection: close\n\n" ++ msg 42 | 43 | gets= received GET >> hello <|> hellostream 44 | 45 | hello= do 46 | received "hello" 47 | name <- param 48 | let msg= "hello " ++ name ++ "\n" 49 | len= length msg 50 | return $ BS.pack $ "HTTP/1.0 200 OK\nContent-Type: text/plain\nContent-Length: "++ show len 51 | ++ "\nConnection: close\n\n" ++ msg 52 | 53 | hellostream = do 54 | received "hellos" 55 | name <- param 56 | 57 | threads 0 $ header <|> stream name 58 | where 59 | header=async $ return $ BS.pack $ 60 | "HTTP/1.0 200 OK\nContent-Type: text/plain\nConnection: close\n\n"++ 61 | "here follows a stream\n" 62 | stream name= do 63 | i <- choose [1 ..] 64 | liftIO $ threadDelay 1000000 65 | return . BS.pack $ " hello " ++ name ++ " "++ show i 66 | 67 | -- err= return $ BS.pack $ "HTTP/1.0 404 Not Founds\nContent-Length: 0\nConnection: close\n\n" 68 | 69 | 70 | -------------------------------------------------------------------------------- /transient-universe-tls/tests/certificate.csr: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE REQUEST----- 2 | MIICqDCCAZACAQAwYzELMAkGA1UEBhMCU1AxDzANBgNVBAgMBk1hZHJpZDEPMA0G 3 | A1UEBwwGTWFkcmlkMQ4wDAYDVQQKDAVBeGlvbTEiMCAGCSqGSIb3DQEJARYTYWdv 4 | Y29yb25hQGdtYWlsLmNvbTCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEB 5 | AMoiYhAB9vgvsHrDh82xUCih5ZULS2JZn2TFxT7ORqxWysLBa/wIW61Iv7RlPnQo 6 | UgT3LdrwsxRC6OjNzEZ2y4YOcNl8s4CjKwcvtNF1q4/I2FIYv0JG3LEdZ4gJnVK5 7 | WrphXIA9+Qd4lus6jxr59/YdrgjD0nN4CuFwjufN4awthNg2rjMuA1bmIB6AvMMD 8 | XhXunzJdEEsLzmU4MTS81F8zP9Ei9jHHwadr4iiWVwX8fQjgJA0QbxU8faGd271W 9 | FZLd1s5ib/QVir+6eEkWv6x75UqGFUFegt4R73rhupufhCGNSvfw53ybRpqfaeON 10 | 2oNYNAUwBiNd6qPk9UqqWuECAwEAAaAAMA0GCSqGSIb3DQEBCwUAA4IBAQBiNS+L 11 | i6zzMENWmyJDrq5TkfiRnmk9rmzLZEf53eCUwzGkumKS6+nkhVFKpl5YyPMolvwa 12 | NK+zYSHAGjVCYJaSg/amrIfJBL6NkjrL5lT0As+4rgKMlhBsnASNReKO8iyvGgst 13 | pUfAAI9wQN364A0gW9qe43zapZ+KdIrYaNG2A0fY1qYVgNiAi0qimikUSHlt1TeV 14 | gQRN4sPB1e5IEOmMSaTUMHMrrbAEJO4uIOOEevuyjSeH3Nkt9VcqlVfYpIE4mIB5 15 | Coe6lbPnM7op9aOu2MXIhrSjqBz8p5P+KNP5I0Ur/Xuf8YHXNj8SmX9R155M16df 16 | zo3sLmS2juJnRx2u 17 | -----END CERTIFICATE REQUEST----- 18 | -------------------------------------------------------------------------------- /transient-universe-tls/tests/certificate.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE----- 2 | MIIDQjCCAioCCQDNTwj9TUvxOTANBgkqhkiG9w0BAQsFADBjMQswCQYDVQQGEwJT 3 | UDEPMA0GA1UECAwGTWFkcmlkMQ8wDQYDVQQHDAZNYWRyaWQxDjAMBgNVBAoMBUF4 4 | aW9tMSIwIAYJKoZIhvcNAQkBFhNhZ29jb3JvbmFAZ21haWwuY29tMB4XDTE3MDIx 5 | NTE3NTkwNVoXDTE3MDMxNzE3NTkwNVowYzELMAkGA1UEBhMCU1AxDzANBgNVBAgM 6 | Bk1hZHJpZDEPMA0GA1UEBwwGTWFkcmlkMQ4wDAYDVQQKDAVBeGlvbTEiMCAGCSqG 7 | SIb3DQEJARYTYWdvY29yb25hQGdtYWlsLmNvbTCCASIwDQYJKoZIhvcNAQEBBQAD 8 | ggEPADCCAQoCggEBAMoiYhAB9vgvsHrDh82xUCih5ZULS2JZn2TFxT7ORqxWysLB 9 | a/wIW61Iv7RlPnQoUgT3LdrwsxRC6OjNzEZ2y4YOcNl8s4CjKwcvtNF1q4/I2FIY 10 | v0JG3LEdZ4gJnVK5WrphXIA9+Qd4lus6jxr59/YdrgjD0nN4CuFwjufN4awthNg2 11 | rjMuA1bmIB6AvMMDXhXunzJdEEsLzmU4MTS81F8zP9Ei9jHHwadr4iiWVwX8fQjg 12 | JA0QbxU8faGd271WFZLd1s5ib/QVir+6eEkWv6x75UqGFUFegt4R73rhupufhCGN 13 | Svfw53ybRpqfaeON2oNYNAUwBiNd6qPk9UqqWuECAwEAATANBgkqhkiG9w0BAQsF 14 | AAOCAQEAgWyR93TXNeJzdOd35Xg+3PDQDBSCf+0CeEbWdKDAbWb+5NoklLrRpSmI 15 | 7jhdxFyL8FqHJDk0IN192cMRg2oBmTcDTIaFdQHD6IxdVDLNP08ZLXBRpAOEL6zx 16 | 1vsFwcykp95cJtOuZmLqXJ1yviLezReBlx+CmgBX7c2sBGqG3J8VmhC7fnc5flQ0 17 | Oy5CVlgED/fHG+E6YhGJG8+zpGc+57q9Qu9beufVe1BLxMiwNkLrX8nGvSk4eb8S 18 | MZQqxprXhjxgMzpYrutg7MxtPCQrQMyI3bt4SOZxIz59YNJWBmWb+hcZEO6wBoPb 19 | 3GCpksvb5Avrv0Vntd/qwmyhT1XGRQ== 20 | -----END CERTIFICATE----- 21 | -------------------------------------------------------------------------------- /transient-universe-tls/tests/execthirdline.sh: -------------------------------------------------------------------------------- 1 | command=`sed -n '3p' ${1} | sed 's/-- //'` 2 | eval $command $1 $2 $3 3 | -------------------------------------------------------------------------------- /transient-universe-tls/tests/key.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN RSA PRIVATE KEY----- 2 | MIIEogIBAAKCAQEAyiJiEAH2+C+wesOHzbFQKKHllQtLYlmfZMXFPs5GrFbKwsFr 3 | /AhbrUi/tGU+dChSBPct2vCzFELo6M3MRnbLhg5w2XyzgKMrBy+00XWrj8jYUhi/ 4 | QkbcsR1niAmdUrlaumFcgD35B3iW6zqPGvn39h2uCMPSc3gK4XCO583hrC2E2Dau 5 | My4DVuYgHoC8wwNeFe6fMl0QSwvOZTgxNLzUXzM/0SL2McfBp2viKJZXBfx9COAk 6 | DRBvFTx9oZ3bvVYVkt3WzmJv9BWKv7p4SRa/rHvlSoYVQV6C3hHveuG6m5+EIY1K 7 | 9/DnfJtGmp9p443ag1g0BTAGI13qo+T1Sqpa4QIDAQABAoIBADW7+jGjNBI6K0IX 8 | ZKyrrFGA6FU80Wdtx8+0O4E8uNDrqa8oWBqB5k0kf8HnADlE1rj3NLt1LUX/m4b3 9 | 3owE3IngoONQIS/bMH8SkZD1JQxuKgN5DK8Dw3taA8HIPIhXOeU+KKb20pLH3ebe 10 | hFh5hw9oSHGQDQwhJ1NS5sp8kreAUUR88M0eTqEhFNDz3F+xJ4q6bhiNSXp6YXw6 11 | PtUCUxmg1tiWSFs6UAbaHD31Y0bol4M0E19bQfJKtK7qY9L91XeexHKcczd17tUF 12 | v3btomYvpmBKVuCxXTkBoTF5bKYAQJHdr4b3k7dfCIl3v/z0eU7W+0pHFV/L9t8Q 13 | naZMQLkCgYEA6uaGHXz4CD5CzngLeGzg+l0RKKXFfboXvwYmBR9HW5Pl0LziQ+Lg 14 | b75eat0gH5umDf3IhxJ1+qgMW1IjU3AL/HF5g83tvWT95oZ4ZxcCIg2BjUmYlIaK 15 | pgAuul2lxYBLZSJAYN3sZQzmJb8Gn7A9YEsqChGTbzNv9aaosRLYsB8CgYEA3Epo 16 | z1ZFj20pmBfT2QwGPzlKqEJs7g4PidonBa863s0REE+SHf5XRTKUZnRRFMMuDFxq 17 | TY0YCl8Sd5IshoSw66VISXWziCc3wif4Jhwrk+Vrp/g35XyM81BXfk3GOg9LraVA 18 | X+i3rcyfLUCR+tPTVsIQr4gTNIhnpLcQaKzflP8CgYANICByWV9Kpp/5BYAulHbl 19 | xnmE+e5VHibhh6hsNNk55sO6rDNAc9byp4KDGiQHYB0hPwMLeR6aiPVXzPkoWmRx 20 | EK4njUQxhwkg7naf3AtEd9i7WldqRTJOIEh8JWtz471Sw10xjHT/GH9rsIbgOWrU 21 | jJ6mvWCtoAQrh8p5SoJNJQKBgC12Ob0YS9C2sY/O0wyG+78OfsbMtphGVJSZbdYx 22 | fI/AeFYKZdhExhPkxVWDibwkL5ujctjAVobFahU9GG1GcxCekpV+ceeWWF58Syzq 23 | QWALR7Vpd3enxZrtKLFLMa6Hu5GBehCRAV8fzHXVTosaLhJIiJMBHR2JTQJkOUGw 24 | 849XAoGARGAu8SyZnpSlGwoaIdcfBkixkcyvoJSgixure4NG3DXc+zY/4bCEe8IE 25 | MstmP+20I47Yw0zdW4h4y/Rhwf5GsPEB92yRVpJq8moQJ6ZBmtP0j9t98YNFMuAH 26 | 7YJiDp3aEydKEvGk7ienYD2iFwn6UKtirQ76llgFxhQkOj7J6ZQ= 27 | -----END RSA PRIVATE KEY----- 28 | -------------------------------------------------------------------------------- /transient-universe-tls/transient-universe-tls.cabal: -------------------------------------------------------------------------------- 1 | name: transient-universe-tls 2 | description: Secure communications for transient 3 | version: 0.3.0.0 4 | cabal-version: >=1.10 5 | build-type: Simple 6 | license: BSD3 7 | license-file: LICENSE 8 | maintainer: agocorona@gmail.com 9 | homepage: http://github.com/transient-haskell/transient-universe-tls 10 | synopsis: transient with secure communications 11 | category: Network 12 | author: Alberto G. Corona 13 | extra-source-files: 14 | ChangeLog.md, README.md 15 | 16 | source-repository head 17 | type: git 18 | location: http://github.com/transient-haskell/transient-universe-tls 19 | 20 | 21 | library 22 | 23 | default-language: Haskell2010 24 | hs-source-dirs: src 25 | exposed-modules: 26 | Transient.TLS 27 | if !impl(ghcjs >=0.1) 28 | build-depends: 29 | base >=4.8 && <5.9, tls, cprng-aes, transient , transient-universe >= 0.6.0.0, 30 | bytestring, data-default, network, x509-store, x509-system, mtl, directory 31 | if impl(ghcjs >=0.1) 32 | build-depends: 33 | base >=4.8 34 | -------------------------------------------------------------------------------- /transient-universe/.gitignore: -------------------------------------------------------------------------------- 1 | # Ignore all 2 | * 3 | 4 | # Unignore all with extensions 5 | !*.* 6 | 7 | # Unignore all dirs 8 | !*/ 9 | 10 | Demos/old-trash 11 | Demos/db 12 | Test 13 | errlog 14 | .tcachedata 15 | .cabal-sandbox 16 | cabal.sandbox* 17 | favicon 18 | IDE.session 19 | MFlow.lkshf 20 | notes.txt 21 | notes.lhs 22 | dist 23 | *.js* 24 | *.o 25 | *.hi 26 | *.exe 27 | *.lk* 28 | .cabal-sandbox 29 | cabal.sanbox.config 30 | .stack* 31 | # emacs stuff 32 | *~ 33 | \#*\# 34 | /.emacs.desktop 35 | /.emacs.desktop.lock 36 | *.elc 37 | auto-save-list 38 | tramp 39 | .\#* 40 | 41 | # Org-mode 42 | .org-id-locations 43 | *_archive 44 | 45 | # flymake-mode 46 | *_flymake.* 47 | 48 | # eshell files 49 | /eshell/history 50 | /eshell/lastdir 51 | 52 | # elpa packages 53 | /elpa/ 54 | 55 | # vim stuff 56 | *.swp 57 | *.swo 58 | 59 | *.key 60 | _darcs 61 | darcs* 62 | /src/style.css 63 | *.back 64 | a.out 65 | *.log 66 | -------------------------------------------------------------------------------- /transient-universe/.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 | -------------------------------------------------------------------------------- /transient-universe/ChangeLog.md: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/transient-haskell/transient-stack/8bcadfa817551cbe46be17bc6a8a21e1a1ed097e/transient-universe/ChangeLog.md -------------------------------------------------------------------------------- /transient-universe/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 | -------------------------------------------------------------------------------- /transient-universe/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /transient-universe/app/client/Transient/Move/Services/void.hs: -------------------------------------------------------------------------------- 1 | main= return () 2 | -------------------------------------------------------------------------------- /transient-universe/app/server/Transient/Move/Services/MonitorService.hsvoid.hs: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/transient-haskell/transient-stack/8bcadfa817551cbe46be17bc6a8a21e1a1ed097e/transient-universe/app/server/Transient/Move/Services/MonitorService.hsvoid.hs -------------------------------------------------------------------------------- /transient-universe/app/server/Transient/Move/Services/controlServices.hsvoid.hs: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/transient-haskell/transient-stack/8bcadfa817551cbe46be17bc6a8a21e1a1ed097e/transient-universe/app/server/Transient/Move/Services/controlServices.hsvoid.hs -------------------------------------------------------------------------------- /transient-universe/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 | --f 11 | -- | 12 | -- 13 | ----------------------------------------------------------------------------- 14 | {-# LANGUAGE ScopedTypeVariables #-} 15 | module Main where 16 | 17 | import Transient.Internals 18 | import Transient.Mailboxes 19 | import Transient.Move.Services.Executor 20 | import Transient.Move.Internals 21 | import Transient.Move.Utils 22 | -- import Transient.Logged(maybeFromIDyn) 23 | import Transient.Move.Services 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 | (return ()) 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 -------------------------------------------------------------------------------- /transient-universe/app/server/Transient/Move/Services/executor.hsvoid.hs: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/transient-haskell/transient-stack/8bcadfa817551cbe46be17bc6a8a21e1a1ed097e/transient-universe/app/server/Transient/Move/Services/executor.hsvoid.hs -------------------------------------------------------------------------------- /transient-universe/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 | -------------------------------------------------------------------------------- /transient-universe/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 | -------------------------------------------------------------------------------- /transient-universe/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 | -------------------------------------------------------------------------------- /transient-universe/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 | -------------------------------------------------------------------------------- /transient-universe/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 | -------------------------------------------------------------------------------- /transient-universe/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, getEqualNodes, 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, callNodes', foldNet, exploreNet, exploreNetUntil, 79 | 80 | -- * Messaging 81 | putMailbox, putMailbox',getMailbox,getMailbox',deleteMailbox,deleteMailbox', 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(..), HTTPHeaders(..), PostParams, noHTTP 94 | #endif 95 | ) where 96 | 97 | import Transient.Move.Internals 98 | import Transient.Mailboxes 99 | 100 | -- $cluster 101 | -- 102 | -- To join the cluster a node 'connect's to a well known node already part of 103 | -- the cluster. 104 | -- 105 | -- @ 106 | -- import Transient.Move (runCloudIO, lliftIO, createNode, connect, getNodes, onAll) 107 | -- 108 | -- main = runCloudIO $ do 109 | -- this <- lliftIO (createNode "192.168.1.2" 8000) 110 | -- master <- lliftIO (createNode "192.168.1.1" 8000) 111 | -- connect this master 112 | -- onAll getNodes >>= lliftIO . putStrLn . show 113 | -- @ 114 | -- 115 | -------------------------------------------------------------------------------- /transient-universe/src/Transient/Move/PubSub.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, TypeSynonymInstances,FlexibleInstances #-} 2 | module Transient.Move.PubSub where 3 | import Transient.Base 4 | import Transient.Internals ((!>)) 5 | import Transient.Move 6 | import Transient.Move.Utils 7 | import qualified Data.Map as M 8 | import Control.Applicative 9 | import Control.Monad 10 | import Data.List 11 | import Data.Maybe 12 | import Data.IORef 13 | import System.IO.Unsafe 14 | import Control.Monad.IO.Class (liftIO) 15 | import Data.ByteString.Lazy.Char8 (pack, unpack) 16 | import Data.Typeable 17 | #ifndef ghcjs_HOST_OS 18 | import Data.TCache 19 | import Data.TCache.DefaultPersistence 20 | #endif 21 | 22 | 23 | 24 | 25 | type Suscribed = M.Map String [Node] 26 | 27 | #ifndef ghcjs_HOST_OS 28 | 29 | instance Indexable Suscribed where 30 | key _= "#suscribed" 31 | 32 | 33 | instance Serializable Suscribed where 34 | serialize= pack . show 35 | deserialize= read . unpack 36 | 37 | 38 | 39 | 40 | suscribed= getDBRef "#suscribed" :: DBRef Suscribed 41 | 42 | atomicModifyDBRef :: DBRef Suscribed -> (Suscribed -> (Suscribed,a)) -> IO a 43 | atomicModifyDBRef ref proc= atomically $ do 44 | x <- readDBRef ref `onNothing` return M.empty 45 | let (r,y) = proc x 46 | writeDBRef ref r 47 | return y 48 | 49 | 50 | 51 | #else 52 | 53 | suscribed= undefined 54 | 55 | atomicModifyDBRef a b= return () 56 | 57 | 58 | 59 | #endif 60 | 61 | suscribe :: (Typeable a,Loggable a) => String -> Cloud a 62 | suscribe key= do 63 | node <- local getMyNode 64 | local (getMailbox' key) <|> notifySuscribe key node 65 | 66 | 67 | notifySuscribe key node = atServer (do 68 | localIO $ atomicModifyDBRef suscribed $ \ss -> (insert key [ node] ss,()) 69 | susc node) 70 | where 71 | susc node=do 72 | exploreNet $ localIO $ liftIO $ atomicModifyDBRef suscribed $ \ss -> (insert key [node] ss,()) 73 | 74 | 75 | empty 76 | 77 | insert h node susc= 78 | let ns = fromMaybe [] $ M.lookup h susc 79 | in M.insert h (union node ns) susc 80 | 81 | 82 | 83 | 84 | unsuscribe key withness= do 85 | node <- local getMyNode 86 | local $ deleteMailbox' key withness 87 | atServer $ exploreNet $ localIO $ atomicModifyDBRef suscribed $ \ss -> (delete key [node] ss,()) 88 | 89 | 90 | where 91 | delete h nodes susc= 92 | let ns = fromMaybe [] $ M.lookup h susc 93 | in M.insert h (ns \\ nodes) susc 94 | 95 | 96 | 97 | publish :: (Typeable a, Loggable a) => String -> a -> Cloud () 98 | publish key dat= do 99 | n <- local getMyNode 100 | publishExclude [n] key dat 101 | where 102 | -- publishExclude :: Loggable a => [Node] -> String -> a -> Cloud () 103 | publishExclude excnodes key dat= foldPublish (<|>) empty excnodes key $ local $ do 104 | putMailbox' key dat 105 | return () !> "PUTMAILBOX" 106 | empty 107 | return() 108 | 109 | -- | executes `proc` in all the nodes suscribed to `key` 110 | foldPublish op init excnodes key proc= atServer $ do 111 | #ifndef ghcjs_HOST_OS 112 | nodes <- localIO $ atomically ((readDBRef suscribed) `onNothing` return M.empty) 113 | >>= return . fromMaybe [] . M.lookup key 114 | #else 115 | nodes <- localIO empty 116 | #endif 117 | let unodes= union nodes excnodes 118 | return() !> ("NODES PUB",nodes \\ excnodes) 119 | foldr op init $ map pub (nodes \\ excnodes) 120 | empty 121 | 122 | where 123 | 124 | pub node= runAt node $ proc 125 | 126 | 127 | 128 | {- 129 | examples 130 | main = keep $ initNode $ inputNodes <|> (onBrowser $ do 131 | 132 | --addWebNode 133 | 134 | --local $ optionn ("f" :: String) "fire" 135 | -- crawl the cloud to list all the nodes connected 136 | --r <- exploreNet $ local $ return <$> getMyNode :: Cloud [Node] 137 | --localIO $ print r 138 | --empty 139 | 140 | wnode <- local getMyNode 141 | atRemote $ local $ updateConnectionInfo wnode "" >> return () 142 | 143 | 144 | r <- suscribe "hello" <|> do 145 | local $ optionn ("f" :: String) "fire" 146 | publish ("hello" ::String) ("world" :: String) 147 | empty 148 | 149 | local $ render $ rawHtml $ p (r :: String) ) 150 | 151 | 152 | -} -------------------------------------------------------------------------------- /transient-universe/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 | -------------------------------------------------------------------------------- /transient-universe/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 | -------------------------------------------------------------------------------- /transient-universe/tests/Dockerfile: -------------------------------------------------------------------------------- 1 | from test 2 | CMD cd /bin && ./distributedApps -p start/localhost/8080 3 | -------------------------------------------------------------------------------- /transient-universe/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 | -------------------------------------------------------------------------------- /transient-universe/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 | -------------------------------------------------------------------------------- /transient-universe/tests/Test3.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 -i../ghcjs-perch/src $1 -o static/out && runghc -i../transient/src -i../transient-universe/src -i../axiom/src $1 ${2} ${3} 6 | 7 | 8 | module Main where 9 | 10 | import Control.Monad 11 | import Control.Monad.IO.Class 12 | import System.Environment 13 | import System.IO 14 | import Transient.Base 15 | import Transient.Indeterminism 16 | import Transient.Logged 17 | import Transient.Move 18 | import Transient.Move.Utils 19 | import GHCJS.HPlay.View hiding (input) 20 | import Control.Applicative 21 | import System.Info 22 | import Control.Concurrent 23 | 24 | main = keep $ rerun "config" $ do 25 | logged $ liftIO $ do 26 | putStrLn "configuring the program" 27 | putStrLn "The program will not ask again in further executions within this folder" 28 | 29 | host <- logged $ input (const True) "host? " 30 | port <- logged $ input (const True) "port? " 31 | checkpoint 32 | 33 | liftIO $ putStrLn $ "Running server at " ++ host ++ ":" ++ show port 34 | node <- liftIO $ createNode host port 35 | initWebApp node $ do 36 | 37 | local $ render $ rawHtml $ p "Hello world" 38 | -------------------------------------------------------------------------------- /transient-universe/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 | 26 | 27 | #define SHOULDRUNIN(x) (local $ do p <-getMyNode; liftIO $ print (p,x) ;assert ( p == (x)) (liftIO $ print p)) 28 | 29 | -- #define _UPK_(x) {-# UNPACK #-} !(x) 30 | 31 | -- SHOULDRUNIN x= local $ getMyNode >>= \p -> assert ( p == (x)) (liftIO $ print p) 32 | 33 | service= [("service","test suite") 34 | ,("executable", "test-transient1") 35 | ,("package","https://github.com/agocorona/transient-universe")] 36 | 37 | main= do 38 | mr <- keep test 39 | endMonitor 40 | 41 | case mr of 42 | Nothing -> print "NO RESULT, NO THREADS RUNNING" >> exitFailure 43 | Just Nothing -> print "SUCCESS" >> exitSuccess 44 | Just (Just e) -> putStr "FAIL: " >> print e >> exitFailure 45 | 46 | 47 | 48 | 49 | 50 | test= initNodeServ service "localhost" 8080 $ do 51 | node0 <- local getMyNode 52 | 53 | local $ guard (nodePort node0== 8080) -- only executes locally in node 8080 54 | 55 | [node1, node2] <- requestInstance service 2 56 | 57 | 58 | local ( option "f" "fire") <|> return "" -- to repeat the tests, remove the "exit" at the end 59 | 60 | 61 | 62 | localIO $ putStrLn "------checking empty in remote node when the remote call back to the caller #46 --------" 63 | 64 | r <- runAt node1 $ do 65 | SHOULDRUNIN(node1) 66 | runAt node2 $ (runAt node1 $ SHOULDRUNIN(node1) >> empty ) <|> (SHOULDRUNIN(node2) >> return "world") 67 | localIO $ print r 68 | 69 | 70 | localIO $ putStrLn "------checking Alternative distributed--------" 71 | r <- local $ collect 3 $ 72 | runCloud $ (runAt node0 (SHOULDRUNIN( node0) >> return "hello" )) 73 | <|> (runAt node1 (SHOULDRUNIN( node1) >> return "world" )) 74 | <|> (runAt node2 (SHOULDRUNIN( node2) >> return "world2" )) 75 | 76 | assert(sort r== ["hello", "world","world2"]) $ localIO $ print r 77 | 78 | localIO $ putStrLn "--------------checking Applicative distributed--------" 79 | r <- loggedc $(runAt node0 (SHOULDRUNIN( node0) >> return "hello ")) 80 | <> (runAt node1 (SHOULDRUNIN( node1) >> return "world " )) 81 | <> (runAt node2 (SHOULDRUNIN( node2) >> return "world2" )) 82 | 83 | assert(r== "hello world world2") $ localIO $ print r 84 | 85 | localIO $ putStrLn "----------------checking monadic, distributed-------------" 86 | r <- runAt node0 (SHOULDRUNIN(node0) 87 | >> runAt node1 (SHOULDRUNIN(node1) 88 | >> runAt node2 (SHOULDRUNIN(node2) >> (return "HELLO" )))) 89 | 90 | assert(r== "HELLO") $ localIO $ print r 91 | 92 | localIO $ putStrLn "----------------checking map-reduce -------------" 93 | 94 | r <- reduce (+) . mapKeyB (\w -> (w, 1 :: Int)) $ getText words "hello world hello" 95 | localIO $ print r 96 | assert (sort (M.toList r) == sort [("hello",2::Int),("world",1)]) $ return r 97 | 98 | 99 | onAll $ exit (Nothing :: Maybe SomeException) -- remove this to repeat the test 100 | 101 | 102 | 103 | 104 | #else 105 | main= return () 106 | #endif 107 | -------------------------------------------------------------------------------- /transient-universe/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 | -------------------------------------------------------------------------------- /transient-universe/tests/api.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env execthirdlinedocker.sh 2 | 3 | -- runghc -i../transient/src -i../transient-universe/src $1 ${2} ${3} 4 | 5 | 6 | {- execute as ./tests/api.hs -p start// 7 | 8 | invoque: GET: curl http:////api/hello/john 9 | curl http:////api/hellos/john 10 | POST: curl http://localhost:8000/api -d "name=Hugh&age=30" 11 | -} 12 | 13 | import Transient.Internals 14 | import Transient.Move 15 | import Transient.Move.Utils 16 | import Transient.Indeterminism 17 | import Control.Applicative 18 | import Transient.Logged 19 | import Control.Concurrent(threadDelay) 20 | import Control.Monad.IO.Class 21 | import qualified Data.ByteString.Lazy.Char8 as BS 22 | import qualified Data.ByteString as BSS 23 | import Data.Aeson 24 | 25 | main = keep $ initNode apisample 26 | 27 | apisample= api $ do 28 | 29 | gets <|> posts <|> badRequest 30 | where 31 | posts= postParams <|> postJSON 32 | postJSON= try $ do 33 | received POST -- both postParams and PostJSON check for POST, so both need `try`, to backtrack 34 | -- not necessary if POST is checked once. 35 | liftIO $ print "AFTER POST" 36 | 37 | received "json" 38 | liftIO $ print "AFTER JSON" 39 | json <- param 40 | liftIO $ print ("JSON received:",json :: Value) 41 | let msg= "received\n" 42 | return $ BS.pack $ "HTTP/1.1 200 OK\nContent-Type: text/plain\nContent-Length: "++ show (length msg) 43 | ++ "\n\n" ++ msg -- "\nConnection: close\n\n" ++ msg 44 | 45 | postParams= try $ do 46 | received POST 47 | received "params" 48 | postParams <- param 49 | liftIO $ print (postParams :: PostParams) 50 | let msg= "received\n" 51 | return $ BS.pack $ "HTTP/1.1 200 OK\nContent-Type: text/plain\nContent-Length: "++ show (length msg) 52 | ++ "\n\n" ++ msg -- "\nConnection: close\n\n" ++ msg 53 | 54 | gets= do 55 | received GET -- "GET" is checked once, so no try necessary. 56 | hello <|> hellostream 57 | hello= do 58 | received "hello" 59 | name <- param 60 | let msg= "hello " ++ name ++ "\n" 61 | len= length msg 62 | return $ BS.pack $ "HTTP/1.1 200 OK\nContent-Type: text/plain\nContent-Length: "++ show len 63 | ++ "\n\n" ++ msg -- "\nConnection: close\n\n" ++ msg 64 | 65 | 66 | hellostream = do 67 | received "hellos" 68 | name <- param 69 | header <|> stream name 70 | 71 | where 72 | 73 | header=async $ return $ BS.pack $ 74 | "HTTP/1.0 200 OK\nContent-Type: text/plain\nConnection: close\n\n"++ 75 | "here follows a stream\n" 76 | stream name= do 77 | i <- threads 0 $ choose [1 ..] 78 | liftIO $ threadDelay 100000 79 | return . BS.pack $ " hello " ++ name ++ " "++ show i 80 | 81 | badRequest = return $ BS.pack $ 82 | let resp="Bad Request\n\ 83 | \Usage: GET: http//host:port/api/hello/, http://host:port/api/hellos/\n\ 84 | \ POST: http://host:port/api\n" 85 | in "HTTP/1.0 400 Bad Request\nContent-Length: " ++ show(length resp) 86 | ++"\nConnection: close\n\n"++ resp 87 | 88 | -------------------------------------------------------------------------------- /transient-universe/tests/build.sh: -------------------------------------------------------------------------------- 1 | ghc -i../transient/src -i../transient-universe/src -i../axiom/src -i../ghcjs-perch/src $1 2 | -------------------------------------------------------------------------------- /transient-universe/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 | -------------------------------------------------------------------------------- /transient-universe/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 | -------------------------------------------------------------------------------- /transient-universe/tests/cert.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE----- 2 | MIIDQjCCAioCCQDNTwj9TUvxOTANBgkqhkiG9w0BAQsFADBjMQswCQYDVQQGEwJT 3 | UDEPMA0GA1UECAwGTWFkcmlkMQ8wDQYDVQQHDAZNYWRyaWQxDjAMBgNVBAoMBUF4 4 | aW9tMSIwIAYJKoZIhvcNAQkBFhNhZ29jb3JvbmFAZ21haWwuY29tMB4XDTE3MDIx 5 | NTE3NTkwNVoXDTE3MDMxNzE3NTkwNVowYzELMAkGA1UEBhMCU1AxDzANBgNVBAgM 6 | Bk1hZHJpZDEPMA0GA1UEBwwGTWFkcmlkMQ4wDAYDVQQKDAVBeGlvbTEiMCAGCSqG 7 | SIb3DQEJARYTYWdvY29yb25hQGdtYWlsLmNvbTCCASIwDQYJKoZIhvcNAQEBBQAD 8 | ggEPADCCAQoCggEBAMoiYhAB9vgvsHrDh82xUCih5ZULS2JZn2TFxT7ORqxWysLB 9 | a/wIW61Iv7RlPnQoUgT3LdrwsxRC6OjNzEZ2y4YOcNl8s4CjKwcvtNF1q4/I2FIY 10 | v0JG3LEdZ4gJnVK5WrphXIA9+Qd4lus6jxr59/YdrgjD0nN4CuFwjufN4awthNg2 11 | rjMuA1bmIB6AvMMDXhXunzJdEEsLzmU4MTS81F8zP9Ei9jHHwadr4iiWVwX8fQjg 12 | JA0QbxU8faGd271WFZLd1s5ib/QVir+6eEkWv6x75UqGFUFegt4R73rhupufhCGN 13 | Svfw53ybRpqfaeON2oNYNAUwBiNd6qPk9UqqWuECAwEAATANBgkqhkiG9w0BAQsF 14 | AAOCAQEAgWyR93TXNeJzdOd35Xg+3PDQDBSCf+0CeEbWdKDAbWb+5NoklLrRpSmI 15 | 7jhdxFyL8FqHJDk0IN192cMRg2oBmTcDTIaFdQHD6IxdVDLNP08ZLXBRpAOEL6zx 16 | 1vsFwcykp95cJtOuZmLqXJ1yviLezReBlx+CmgBX7c2sBGqG3J8VmhC7fnc5flQ0 17 | Oy5CVlgED/fHG+E6YhGJG8+zpGc+57q9Qu9beufVe1BLxMiwNkLrX8nGvSk4eb8S 18 | MZQqxprXhjxgMzpYrutg7MxtPCQrQMyI3bt4SOZxIz59YNJWBmWb+hcZEO6wBoPb 19 | 3GCpksvb5Avrv0Vntd/qwmyhT1XGRQ== 20 | -----END CERTIFICATE----- 21 | -------------------------------------------------------------------------------- /transient-universe/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 | -} -------------------------------------------------------------------------------- /transient-universe/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 | -------------------------------------------------------------------------------- /transient-universe/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 | -------------------------------------------------------------------------------- /transient-universe/tests/execthirdline.sh: -------------------------------------------------------------------------------- 1 | command=`sed -n '3p' ${1} | sed 's/-- //'` 2 | eval $command $1 $2 $3 3 | -------------------------------------------------------------------------------- /transient-universe/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 | -------------------------------------------------------------------------------- /transient-universe/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 | 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 | 106 | 107 | -------------------------------------------------------------------------------- /transient-universe/tests/hasrocket1/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for hasrocket-benchmark-transient 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /transient-universe/tests/hasrocket1/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019, Alberto Gömez Corona 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Alberto Gömez Corona nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /transient-universe/tests/hasrocket1/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | import Transient.Internals 5 | import Transient.Move.Internals 6 | import Transient.EVars 7 | import Transient.Logged 8 | import Transient.Move.Utils 9 | import Data.Aeson as Aeson 10 | import Data.Containers as H 11 | import Control.Applicative 12 | 13 | main= keep' $ do 14 | broad <- newEVar 15 | initNodeDef "localhost" 3000 $ apisample broad 16 | return () 17 | 18 | apisample broad= api $ 19 | do msg <- param 20 | processMessage broad msg 21 | 22 | <|> watchBroadcast broad 23 | 24 | 25 | 26 | processMessage broad msg= do 27 | Aeson.Object obj <- emptyIfNothing $ Aeson.decode msg 28 | Aeson.String typ <- emptyIfNothing $ H.lookup "type" obj 29 | case typ of 30 | "echo" -> return msg 31 | "broadcast" -> do 32 | let res = Aeson.encode $ insertMap "type" "broadcastResult" obj 33 | writeEVar broad msg 34 | return res 35 | 36 | 37 | watchBroadcast broad= threads 0 $ readEVar broad 38 | 39 | -------------------------------------------------------------------------------- /transient-universe/tests/hasrocket1/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /transient-universe/tests/hasrocket1/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | main :: IO () 4 | main = putStrLn "Hello, Haskell!" 5 | -------------------------------------------------------------------------------- /transient-universe/tests/hasrocket1/hasrocket-benchmark-transient.cabal: -------------------------------------------------------------------------------- 1 | -- Initial hasrocket-benchmark-transient.cabal generated by cabal init. 2 | -- For further documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: hasrocket-benchmark-transient 5 | version: 0.1.0.0 6 | synopsis: version using haskell transient libraries for the hasrocket websockets shootout 7 | -- description: 8 | homepage: https://github.com/hashrocket/websocket-shootout 9 | license: BSD3 10 | license-file: LICENSE 11 | author: Alberto Gömez Corona 12 | maintainer: agocorona@gmail.com 13 | -- copyright: 14 | category: Math 15 | build-type: Simple 16 | extra-source-files: ChangeLog.md 17 | cabal-version: >=1.10 18 | 19 | executable hasrocket-benchmark-transient 20 | main-is: Main.hs 21 | -- other-modules: 22 | -- other-extensions: 23 | build-depends: base >=2 && <5, transient, transient-universe, containers, aeson 24 | hs-source-dirs: app 25 | default-language: Haskell2010 26 | -------------------------------------------------------------------------------- /transient-universe/tests/hasrocket1/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 | 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 | 106 | 107 | -------------------------------------------------------------------------------- /transient-universe/tests/https.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env execthirdlinedocker.sh 2 | -- info: use "sed -i 's/\r//g' yourfile" if report "/usr/bin/env: ‘execthirdlinedocker.sh\r’: No such file or directory" 3 | -- LIB="/home/vsonline/workspace/transient-stack" && runghc -DDEBUG -i${LIB}/transient/src -i${LIB}/transient-universe/src -i${LIB}/transient-universe-tls/src -i${LIB}/axiom/src $1 ${2} ${3} 4 | 5 | 6 | {-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} 7 | module Main where 8 | 9 | import Transient.Base 10 | import Transient.Parse 11 | import Transient.Move.Internals 12 | import Transient.Move.Services 13 | import Transient.TLS 14 | import Data.List(nub,sort) 15 | import Data.Char(isNumber) 16 | import Data.Monoid 17 | import Control.Monad.State 18 | import qualified Data.ByteString.Lazy.Char8 as BS 19 | import Control.Applicative 20 | import Data.Typeable 21 | 22 | getGoogleService = [("service","google"),("type","HTTPS") 23 | ,("nodehost","www.google.com") 24 | ,("HTTPstr",getGoogle)] 25 | 26 | getGoogle= "GET / HTTP/1.1\r\n" 27 | <> "Host: $hostnode\r\n" 28 | <> "\r\n" :: String 29 | 30 | getGoogleSearchService = [("service","google"),("type","HTTP") 31 | ,("nodehost","www.google.com") 32 | ,("HTTPstr","GET /search?q=+$1+site:hackage.haskell.org HTTP/1.1\r\nHost: $hostnode\r\n\r\n" )] 33 | 34 | 35 | main=do 36 | initTLS 37 | 38 | keep' $ do 39 | Raw r <-runCloud $ callService getGoogleService () 40 | 41 | liftIO $ do putStr "100 chars of web page: "; print $ BS.take 100 r 42 | empty 43 | Pack packages <- runCloud $ callService getGoogleSearchService ("Control.Monad.State" :: BS.ByteString) 44 | 45 | liftIO $ do putStr "Search results: " ; print packages 46 | 47 | newtype Pack= Pack [BS.ByteString] deriving (Read,Show,Typeable) 48 | instance Loggable Pack where 49 | serialize (Pack p)= undefined 50 | 51 | deserialize= Pack . reverse . sort . nub <$> (many $ do 52 | tDropUntilToken "hackage.haskell.org/package/" 53 | r <- tTakeWhile (\c -> not (isNumber c) && c /= '&' && c /= '/') 54 | let l= BS.length r -1 55 | return $ if ( BS.index r l == '-') then BS.take l r else r) 56 | -------------------------------------------------------------------------------- /transient-universe/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 | -------------------------------------------------------------------------------- /transient-universe/tests/key.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN RSA PRIVATE KEY----- 2 | MIIEogIBAAKCAQEAyiJiEAH2+C+wesOHzbFQKKHllQtLYlmfZMXFPs5GrFbKwsFr 3 | /AhbrUi/tGU+dChSBPct2vCzFELo6M3MRnbLhg5w2XyzgKMrBy+00XWrj8jYUhi/ 4 | QkbcsR1niAmdUrlaumFcgD35B3iW6zqPGvn39h2uCMPSc3gK4XCO583hrC2E2Dau 5 | My4DVuYgHoC8wwNeFe6fMl0QSwvOZTgxNLzUXzM/0SL2McfBp2viKJZXBfx9COAk 6 | DRBvFTx9oZ3bvVYVkt3WzmJv9BWKv7p4SRa/rHvlSoYVQV6C3hHveuG6m5+EIY1K 7 | 9/DnfJtGmp9p443ag1g0BTAGI13qo+T1Sqpa4QIDAQABAoIBADW7+jGjNBI6K0IX 8 | ZKyrrFGA6FU80Wdtx8+0O4E8uNDrqa8oWBqB5k0kf8HnADlE1rj3NLt1LUX/m4b3 9 | 3owE3IngoONQIS/bMH8SkZD1JQxuKgN5DK8Dw3taA8HIPIhXOeU+KKb20pLH3ebe 10 | hFh5hw9oSHGQDQwhJ1NS5sp8kreAUUR88M0eTqEhFNDz3F+xJ4q6bhiNSXp6YXw6 11 | PtUCUxmg1tiWSFs6UAbaHD31Y0bol4M0E19bQfJKtK7qY9L91XeexHKcczd17tUF 12 | v3btomYvpmBKVuCxXTkBoTF5bKYAQJHdr4b3k7dfCIl3v/z0eU7W+0pHFV/L9t8Q 13 | naZMQLkCgYEA6uaGHXz4CD5CzngLeGzg+l0RKKXFfboXvwYmBR9HW5Pl0LziQ+Lg 14 | b75eat0gH5umDf3IhxJ1+qgMW1IjU3AL/HF5g83tvWT95oZ4ZxcCIg2BjUmYlIaK 15 | pgAuul2lxYBLZSJAYN3sZQzmJb8Gn7A9YEsqChGTbzNv9aaosRLYsB8CgYEA3Epo 16 | z1ZFj20pmBfT2QwGPzlKqEJs7g4PidonBa863s0REE+SHf5XRTKUZnRRFMMuDFxq 17 | TY0YCl8Sd5IshoSw66VISXWziCc3wif4Jhwrk+Vrp/g35XyM81BXfk3GOg9LraVA 18 | X+i3rcyfLUCR+tPTVsIQr4gTNIhnpLcQaKzflP8CgYANICByWV9Kpp/5BYAulHbl 19 | xnmE+e5VHibhh6hsNNk55sO6rDNAc9byp4KDGiQHYB0hPwMLeR6aiPVXzPkoWmRx 20 | EK4njUQxhwkg7naf3AtEd9i7WldqRTJOIEh8JWtz471Sw10xjHT/GH9rsIbgOWrU 21 | jJ6mvWCtoAQrh8p5SoJNJQKBgC12Ob0YS9C2sY/O0wyG+78OfsbMtphGVJSZbdYx 22 | fI/AeFYKZdhExhPkxVWDibwkL5ujctjAVobFahU9GG1GcxCekpV+ceeWWF58Syzq 23 | QWALR7Vpd3enxZrtKLFLMa6Hu5GBehCRAV8fzHXVTosaLhJIiJMBHR2JTQJkOUGw 24 | 849XAoGARGAu8SyZnpSlGwoaIdcfBkixkcyvoJSgixure4NG3DXc+zY/4bCEe8IE 25 | MstmP+20I47Yw0zdW4h4y/Rhwf5GsPEB92yRVpJq8moQJ6ZBmtP0j9t98YNFMuAH 26 | 7YJiDp3aEydKEvGk7ienYD2iFwn6UKtirQ76llgFxhQkOj7J6ZQ= 27 | -----END RSA PRIVATE KEY----- 28 | -------------------------------------------------------------------------------- /transient-universe/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 | -------------------------------------------------------------------------------- /transient-universe/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 | -------------------------------------------------------------------------------- /transient-universe/tests/rundevel.sh: -------------------------------------------------------------------------------- 1 | runghc -i../transient/src -i../transient-universe/src -i../axiom/src -i../ghcjs-perch/src $1 $2 $3 2 | -------------------------------------------------------------------------------- /transient-universe/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 | -------------------------------------------------------------------------------- /transient-universe/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 | -------------------------------------------------------------------------------- /transient-universe/tests/test22.hs: -------------------------------------------------------------------------------- 1 | import Transient.Base 2 | import Transient.Move 3 | import Transient.Move.Utils 4 | 5 | main = keep $ initNode $ 6 | localIO $ putStrLn "hello world" 7 | -------------------------------------------------------------------------------- /transient-universe/tests/test5.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 | -- LIB=/projects/transient-stack/ && ghc -DDEBUG -threaded -i${LIB}/transient/src -i${LIB}/transient-universe/src -i${LIB}/transient-universe-tls/src -i${LIB}/axiom/src $1 && ./`basename $1 .hs` ${2} ${3} 4 | 5 | -- mkdir -p ./static && ghcjs --make -i../transient/src -i../transient-universe/src -i../transient-universe-tls/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 | {-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-} 11 | module Main where 12 | 13 | import Transient.Base 14 | import Transient.Move.Internals 15 | import Transient.Internals 16 | import Transient.TLS 17 | import Transient.Move.Utils 18 | import Control.Applicative 19 | import Control.Monad.IO.Class 20 | import Control.Monad.State 21 | import qualified Data.Vector as V hiding (empty) 22 | import Transient.MapReduce 23 | import Control.Concurrent 24 | import Transient.EVars 25 | import Transient.Move.Services 26 | import Transient.Mailboxes 27 | import Transient.Indeterminism 28 | 29 | 30 | main2= keep $ do 31 | i <- threads 0 $ choose[0..] 32 | abduce 33 | liftIO $ threadDelay 1000000 34 | 35 | liftIO $ print (i :: Int) 36 | 37 | main5= keep' $ initNode $ do 38 | result <- local $ heavycomputation 39 | teleport 40 | str <- local $ return "firstparam" 41 | str2 <- local $ return "secondparam" 42 | showURL 43 | process result str str2 44 | teleport 45 | where 46 | heavycomputation= return "heavycompresult" 47 | process result str str2= local $ return $ result++ str++str2 48 | 49 | main3 = keep $ initNode $ hi "hello" <|> hi "world" 50 | where 51 | hi text= do 52 | showURL 53 | localIO $ putStrLn text 54 | teleport <** modify (\s -> s{execMode=Remote}) 55 | {- 56 | main4 = do initTLS; keep $ initNode $ inputNodes <|> hi 57 | where 58 | ps= onAll $ do 59 | conn <- getSData 60 | sdata <- liftIO $ readIORef $ connData conn 61 | case sdata of 62 | Just (HTTPS2Node _) -> liftIO$ print "SSL XXXXXXXXXXXXXXXXXXX" 63 | 64 | Just (TLSNode2Node _) -> liftIO$ print "SSL XXXXXXXXXXXXXXXXXXX" 65 | _ -> liftIO $ print "NOSSL YYYYYYYYYYYYYYYYYYY" 66 | hi = do 67 | ps 68 | showURL 69 | localIO $ putStrLn "hello" 70 | let x= "hello " 71 | ps 72 | teleport 73 | showURL 74 | localIO $ print $ x ++ "world" 75 | teleport 76 | 77 | -} 78 | 79 | 80 | 81 | 82 | 83 | test11= localIO $ print "hello world" 84 | test10= do 85 | localIO $ putStrLn "hello world" 86 | local $ return (42 :: Int) 87 | teleport 88 | 89 | main = do 90 | --initTLS 91 | keep $ initNode $ inputNodes <|> do 92 | void $ local $ option "r" "init" 93 | 94 | node <- otherNode 95 | 96 | wormhole node $ local $ do 97 | void $ local $ option "r" "run" 98 | i <- atRemote $ do 99 | showURL 100 | localIO $ print "hello" 101 | 102 | i <- local $ threads 0 $ choose[1:: Int ..] 103 | localIO $ threadDelay 1000000 104 | return i 105 | localIO $ print i 106 | where 107 | otherNode= local $ do 108 | nodes <- getNodes 109 | guard $ length nodes > 1 110 | return $ nodes !! 1 111 | atOtherNode doit= do 112 | node <- otherNode 113 | runAt node doit 114 | 115 | test8 = do 116 | --local $ option "r" "r" 117 | delData Serial 118 | n <- local getMyNode 119 | r <- (runAt n (local getMailbox) <> runAt n (local getMailbox) <> runAt n (local getMailbox)) <|> (local $ putMailbox "hello " >> empty) 120 | -- r <- (return [3] <> (async (do print "here";return [5]:: IO [Int]) >> empty)) <|> liftIO (do print "here2"; return [7]) 121 | localIO $ print (r :: String) 122 | 123 | --initNode $ inputNodes <|> test7 124 | 125 | 126 | service= [("service","test suite") 127 | ,("executable", "test-transient1") 128 | ,("package","https://github.com/agocorona/transient-universe")] 129 | 130 | 131 | test7= do 132 | ins <- requestInstance service 1 133 | localIO $ print ins 134 | 135 | test6= do 136 | -- setData Parallel 137 | ((async getLine >> return ())<> (liftIO $ print "world")) -- <|> liftIO (print "hello") 138 | 139 | test5= do 140 | -- option "r" "run" 141 | v1 <- liftIO $ newEmptyMVar 142 | 143 | setData Parallel 144 | (proc v1 <> proc2 ) <|> 145 | (do liftIO $ threadDelay 1000000 ; async $ putMVar v1 ("hello" :: String) ) 146 | -- liftIO $ print (r :: String) 147 | where 148 | proc2= liftIO $ print "world" 149 | proc v1=do 150 | --v <- liftIO . atomically $ dupTChan v1 151 | liftIO $ print "PROC" 152 | 153 | (async $ do (readMVar v1) >>= print) 154 | 155 | 156 | 157 | 158 | test3= do 159 | v <- newEVar 160 | -- option "r" "run" 161 | setData Parallel 162 | r <- (readEVar v <> readEVar v) <|> (do liftIO $ threadDelay 1000000; writeEVar v "hello" >> empty) 163 | liftIO $ print (r :: String) 164 | 165 | test2= do 166 | option "r" "run" 167 | setData Parallel 168 | r <- (async (return "1") ) <> (async (return "2")) <|> (do liftIO $ threadDelay 10000000;async (print "3") >> empty) 169 | 170 | --r <- (getMailbox <> getMailbox) <|> (do liftIO $ threadDelay 10000000; putMailbox (1 :: Int) >> empty) 171 | 172 | liftIO $ print (r :: String) 173 | 174 | test12= do 175 | local $ option "r" "run" 176 | ns <- local getNodes 177 | r <- runAt (ns !! 1) proc1 <> runAt (ns !! 2) proc2 178 | localIO $ print r 179 | where 180 | proc2= local $ return "hello from 3001" 181 | 182 | proc1= local $ do 183 | n <- getMyNode 184 | liftIO $ threadDelay 5000000 185 | return "hello from 3000" 186 | 187 | 188 | test1= do 189 | local $ option "r" "run" 190 | n <- local $ do ns <- getNodes; return $ ns !! 1 191 | localIO $ return () !> "RRRRRR" 192 | r <- (mclustered (local getMailbox)) <|> do 193 | local $ option "s" "run" 194 | localIO $ return () !> "SSSSSS" 195 | runAt n $ local $ do 196 | putMailbox $ "hello " 197 | empty 198 | 199 | localIO $ print (r :: String) 200 | 201 | test= do 202 | let content= "hello world hello" 203 | local $ option "r" "run" 204 | r <- reduce (+) $ mapKeyB (\w -> (w, 1 :: Int)) $ distribute $ V.fromList $ words content 205 | -- localIO $ print ("MAP RESULT=", dds) 206 | -- -- local $ option "red" "reduce" 207 | -- localIO $ getNodes >>= \n -> print ("NODES1", n) 208 | -- r <- reduce (+) $ DDS $ return dds 209 | localIO $ putStr "result:" >> print r 210 | 211 | localIO $ print "DONE" 212 | -------------------------------------------------------------------------------- /transient-universe/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 | -------------------------------------------------------------------------------- /transient-universe/tests/testRestService.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env execthirdlinedocker.sh 2 | -- info: use "sed -i 's/\r//g' yourfile" if report "/usr/bin/env: ‘execthirdlinedocker.sh\r’: No such file or directory" 3 | -- LIB="/home/vsonline/workspace/transient-stack" && runghc -i${LIB}/transient/src -i${LIB}/transient-universe/src -i${LIB}/transient/src -i${LIB}/transient-universe-tls/src -i${LIB}/axiom/src $1 ${2} ${3} 4 | 5 | -- LIB="/home/vsonline/workspace/transient-stack" && ghc -DDEBUG -i${LIB}/transient/src -i${LIB}/transient-universe/src $1 && ./`basename $1 .hs` ${2} ${3} 6 | 7 | 8 | {-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} 9 | module Main where 10 | 11 | import Transient.Base 12 | import Transient.TLS 13 | import Transient.Move.Internals 14 | import Transient.Move.Services 15 | import Transient.Move.Utils 16 | import Control.Applicative 17 | import Data.Monoid 18 | 19 | import Control.Monad.State 20 | 21 | import Data.Aeson 22 | 23 | import qualified Data.ByteString as BS 24 | 25 | 26 | 27 | 28 | getRESTReq= "GET /todos/$1 HTTP/1.1\r\n" 29 | <> "Host: $hostnode\r\n" 30 | <> "\r\n" :: String 31 | 32 | 33 | postRESTReq= "POST /todos HTTP/1.1\r\n" 34 | <> "HOST: $hostnode\r\n" 35 | <> "Content-Type: application/json\r\n\r\n" 36 | <>"{\"id\": $1,\"userId\": $2,\"completed\": $3,\"title\":$4}" 37 | 38 | 39 | postRestService= [("service","post"),("type","HTTPS") 40 | ,("nodehost","jsonplaceholder.typicode.com") 41 | ,("HTTPstr",postRESTReq)] 42 | 43 | getRestService = [("service","get"),("type","HTTPS") 44 | ,("nodehost","jsonplaceholder.typicode.com") 45 | ,("HTTPstr",getRESTReq)] 46 | 47 | 48 | 49 | 50 | 51 | type Literal = BS.ByteString -- appears with " " 52 | type Symbol= String -- no " when translated 53 | 54 | main= do 55 | initTLS 56 | keep $ initNode $ do 57 | local $ option ("go" ::String) "go" 58 | 59 | 60 | r <-callService postRestService (10 :: Int,4 :: Int, "true" :: Symbol , "title alberto" :: Literal) :: Cloud Value 61 | local $ do 62 | HTTPHeaders _ headers <- getState <|> error "no headers. That should not happen" 63 | liftIO $ print headers 64 | liftIO $ print ("POST RESPONSE:",r) 65 | 66 | 67 | r <- callService getRestService (1::Int) 68 | local $ do 69 | HTTPHeaders _ headers <- getState <|> error "no headers. That should not happen" 70 | liftIO $ do 71 | putStrLn "HEADERS" 72 | print headers 73 | putStrLn "RESULT" 74 | print ("GET RESPONSE:",r :: Value) 75 | 76 | 77 | r <- callService getRestService (2::Int) 78 | local $ do 79 | HTTPHeaders _ headers <- getState <|> error "no headers. That should not happen" 80 | liftIO $ do 81 | putStrLn "HEADERS" 82 | print headers 83 | putStrLn "RESULT" 84 | print ("GET RESPONSE:",r :: Value) -------------------------------------------------------------------------------- /transient-universe/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 | -------------------------------------------------------------------------------- /transient-universe/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 | -------------------------------------------------------------------------------- /transient-universe/tests/teststruct.hs: -------------------------------------------------------------------------------- 1 | -- probar diferencia de gasto entre una estructura granden y una pequeña.º 2 | 3 | 4 | entra stateT int IO y stateIO. 5 | 6 | gelisam/EffectSystemsBenchmark.hs 7 | https://gist.github.com/gelisam/be8ff8004cd701a084b6d64204a28bb6 8 | results: http://gelisam.com/files/effect-systems-benchmark/benchmark-ghc-8.6.4.html 9 | 10 | https://github.com/agocorona/freemonad-benchmark 11 | 12 | buscar -------------------------------------------------------------------------------- /transient-universe/tests/testtls.hs: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/transient-haskell/transient-stack/8bcadfa817551cbe46be17bc6a8a21e1a1ed097e/transient-universe/tests/testtls.hs -------------------------------------------------------------------------------- /transient-universe/transient-universe.cabal: -------------------------------------------------------------------------------- 1 | name: transient-universe 2 | version: 0.6.0.0 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: fully composable remote execution for the creation of distributed systems 11 | description: fully composable remote execution for the creation of distributed systems across Web clients and servers using sockets, websockets and HTTP. Web API compatible, map-reduce implementation. 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 | -- > cd ghcjs-base 36 | -- > cabal install --ghcjs --constraint 'primitive < 0.6.4' 37 | ghcjs-base -any, 38 | ghcjs-prim -any, 39 | random -any 40 | else 41 | build-depends: 42 | base64-bytestring, 43 | HTTP -any, 44 | TCache >= 0.12, 45 | case-insensitive -any, 46 | directory -any, 47 | filepath -any, 48 | hashable -any, 49 | iproute -any, 50 | network >=2.8.0.0 && < 3.0.0.0, 51 | network-info -any, 52 | network-uri -any, 53 | vector -any, 54 | websockets >= 0.12.7.1 , 55 | process -any, 56 | random -any, 57 | text -any, 58 | aeson -any 59 | --primitive < 0.6.4.0 60 | -- entropy <= 0.3.6, 61 | build-depends: 62 | old-time 63 | 64 | 65 | 66 | exposed-modules: 67 | Transient.Move 68 | Transient.MapReduce 69 | Transient.Move.Internals 70 | Transient.Move.Utils 71 | Transient.Move.Services 72 | Transient.Move.PubSub 73 | build-depends: 74 | base >4 && <5, 75 | bytestring -any, 76 | containers, 77 | mtl -any, 78 | stm -any, 79 | time -any, 80 | transformers -any, 81 | transient >= 0.7.0.0 82 | default-language: Haskell2010 83 | hs-source-dirs: src . 84 | ghc-options: 85 | 86 | executable monitorService 87 | 88 | if !impl(ghcjs >=0.1) 89 | build-depends: 90 | transformers -any, 91 | containers, 92 | transient >= 0.7.0.0, 93 | transient-universe, 94 | process, 95 | directory, 96 | bytestring 97 | 98 | hs-source-dirs: app/server/Transient/Move/Services 99 | main-is: MonitorService.hs 100 | else 101 | hs-source-dirs: app/client/Transient/Move/Services 102 | main-is: void.hs 103 | build-depends: 104 | base >4 && <5 105 | 106 | 107 | default-language: Haskell2010 108 | ghc-options: -threaded -rtsopts 109 | 110 | 111 | executable executor 112 | if !impl(ghcjs >=0.1) 113 | build-depends: 114 | containers, 115 | transformers -any, 116 | transient >= 0.7.0.0, 117 | transient-universe, 118 | process >= 1.6.4.0, 119 | directory, 120 | bytestring, 121 | aeson, 122 | time 123 | 124 | hs-source-dirs: app/server/Transient/Move/Services 125 | main-is: executor.hs 126 | else 127 | hs-source-dirs: app/client/Transient/Move/Services 128 | main-is: void.hs 129 | build-depends: 130 | base >4 && <5 131 | 132 | 133 | default-language: Haskell2010 134 | ghc-options: -threaded -rtsopts 135 | 136 | executable controlServices 137 | if !impl(ghcjs >=0.1) 138 | build-depends: 139 | containers, 140 | transformers -any, 141 | transient >= 0.7.0.0, 142 | transient-universe, 143 | process >= 1.6.4.0, 144 | directory, 145 | bytestring, 146 | aeson, 147 | time 148 | 149 | hs-source-dirs: app/server/Transient/Move/Services 150 | main-is: controlServices.hs 151 | else 152 | hs-source-dirs: app/client/Transient/Move/Services 153 | main-is: void.hs 154 | build-depends: 155 | base >4 && <5 156 | 157 | 158 | default-language: Haskell2010 159 | ghc-options: -threaded -rtsopts 160 | 161 | executable test-transient1 162 | 163 | if !impl(ghcjs >=0.1) 164 | build-depends: 165 | mtl -any, 166 | transient >= 0.7.0.0, 167 | random -any, 168 | text -any, 169 | containers -any, 170 | directory -any, 171 | filepath -any, 172 | stm -any, 173 | base64-bytestring, 174 | HTTP -any, 175 | network >=2.8.0.0 && < 3.0.0.0, 176 | transformers -any, 177 | process -any, 178 | network-info -any, 179 | bytestring -any, 180 | time -any, 181 | vector -any, 182 | TCache >= 0.12, 183 | websockets >= 0.12.7.1 , 184 | network-uri -any, 185 | case-insensitive -any, 186 | hashable -any, 187 | aeson, 188 | old-time 189 | 190 | 191 | main-is: TestSuite.hs 192 | build-depends: 193 | base >4 194 | default-language: Haskell2010 195 | hs-source-dirs: tests src . 196 | ghc-options: -threaded -rtsopts -fno-ignore-asserts 197 | 198 | 199 | test-suite test-transient 200 | 201 | if !impl(ghcjs >=0.1) 202 | build-depends: 203 | mtl -any, 204 | transient >= 0.7.0.0, 205 | random -any, 206 | text -any, 207 | containers -any, 208 | directory -any, 209 | filepath -any, 210 | stm -any, 211 | base64-bytestring, 212 | HTTP -any, 213 | network >=2.8.0.0 && < 3.0.0.0, 214 | transformers -any, 215 | process -any, 216 | network-info -any, 217 | bytestring -any, 218 | time -any, 219 | vector -any, 220 | TCache >= 0.12, 221 | websockets >= 0.12.7.1 , 222 | network-uri -any, 223 | case-insensitive -any, 224 | hashable -any, 225 | aeson, 226 | old-time 227 | type: exitcode-stdio-1.0 228 | main-is: TestSuite.hs 229 | build-depends: 230 | base >4 231 | default-language: Haskell2010 232 | hs-source-dirs: tests src . 233 | ghc-options: -threaded -rtsopts -fno-ignore-asserts 234 | -------------------------------------------------------------------------------- /transient-universe/transient-universe.cabal.new: -------------------------------------------------------------------------------- 1 | name: transient-universe 2 | version: 0.6.0.0 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: fully composable remote execution for the creation of distributed systems, map-reduce implementation 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-stack/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 | -- > cd ghcjs-base 36 | -- > cabal install --ghcjs --constraint 'primitive < 0.6.4' 37 | ghcjs-base -any, 38 | ghcjs-prim -any, 39 | random -any 40 | else 41 | build-depends: 42 | base64-bytestring, 43 | HTTP -any, 44 | TCache >= 0.12, 45 | case-insensitive -any, 46 | directory -any, 47 | filepath -any, 48 | hashable -any, 49 | iproute -any, 50 | network >=2.8.0.0 && < 3.0.0.0, 51 | network-info -any, 52 | network-uri -any, 53 | vector -any, 54 | websockets >= 0.12.7.1 , 55 | process -any, 56 | random -any, 57 | text -any, 58 | aeson -any 59 | --primitive < 0.6.4.0 60 | -- entropy <= 0.3.6, 61 | build-depends: 62 | old-time 63 | 64 | 65 | 66 | exposed-modules: 67 | Transient.Move 68 | Transient.MapReduce 69 | Transient.Move.Internals 70 | Transient.Move.Utils 71 | Transient.Move.Services 72 | Transient.Move.PubSub 73 | build-depends: 74 | base >4 && <5, 75 | bytestring -any, 76 | containers, 77 | mtl -any, 78 | stm -any, 79 | time -any, 80 | transformers -any, 81 | transient >= 0.7.0.0 82 | default-language: Haskell2010 83 | hs-source-dirs: src . 84 | ghc-options: 85 | 86 | 87 | executable monitorService 88 | if !impl(ghcjs >=0.1) 89 | build-depends: 90 | transformers -any, 91 | containers, 92 | transient >= 0.7.0.0, 93 | transient-universe, 94 | process, 95 | directory, 96 | bytestring 97 | 98 | hs-source-dirs: app/server/Transient/Move/Services 99 | main-is: MonitorService.hs 100 | default-language: Haskell2010 101 | ghc-options: -O -threaded -rtsopts 102 | 103 | 104 | executable executor 105 | if !impl(ghcjs >=0.1) 106 | build-depends: 107 | containers, 108 | transformers -any, 109 | transient >= 0.7.0.0, 110 | transient-universe, 111 | process >= 1.6.4.0, 112 | directory, 113 | bytestring, 114 | aeson, 115 | time 116 | 117 | hs-source-dirs: app/server/Transient/Move/Services 118 | main-is: executor.hs 119 | default-language: Haskell2010 120 | ghc-options: -O -threaded -rtsopts 121 | 122 | executable controlServices 123 | if !impl(ghcjs >=0.1) 124 | build-depends: 125 | containers, 126 | transformers -any, 127 | transient >= 0.7.0.0, 128 | transient-universe, 129 | process >= 1.6.4.0, 130 | directory, 131 | bytestring, 132 | aeson, 133 | time 134 | 135 | hs-source-dirs: app/server/Transient/Move/Services 136 | main-is: controlServices.hs 137 | default-language: Haskell2010 138 | ghc-options: -O -threaded -rtsopts 139 | 140 | executable test-transient1 141 | if !impl(ghcjs >=0.1) 142 | build-depends: 143 | mtl -any, 144 | transient >= 0.7.0.0, 145 | random -any, 146 | text -any, 147 | containers -any, 148 | directory -any, 149 | filepath -any, 150 | stm -any, 151 | base64-bytestring, 152 | HTTP -any, 153 | network >=2.8.0.0 && < 3.0.0.0, 154 | transformers -any, 155 | process -any, 156 | network-info -any, 157 | bytestring -any, 158 | time -any, 159 | vector -any, 160 | TCache >= 0.12, 161 | websockets >= 0.12.7.1 , 162 | network-uri -any, 163 | case-insensitive -any, 164 | hashable -any, 165 | aeson, 166 | old-time 167 | 168 | 169 | main-is: TestSuite.hs 170 | default-language: Haskell2010 171 | hs-source-dirs: tests src . 172 | ghc-options: -threaded -rtsopts -fno-ignore-asserts 173 | 174 | 175 | test-suite test-transient 176 | type: exitcode-stdio-1.0 177 | main-is: TestSuite.hs 178 | 179 | if !impl(ghcjs >=0.1) 180 | build-depends: 181 | mtl -any, 182 | transient >= 0.7.0.0, 183 | random -any, 184 | text -any, 185 | containers -any, 186 | directory -any, 187 | filepath -any, 188 | stm -any, 189 | base64-bytestring, 190 | HTTP -any, 191 | network >=2.8.0.0 && < 3.0.0.0, 192 | transformers -any, 193 | process -any, 194 | network-info -any, 195 | bytestring -any, 196 | time -any, 197 | vector -any, 198 | TCache >= 0.12, 199 | websockets >= 0.12.7.1 , 200 | network-uri -any, 201 | case-insensitive -any, 202 | hashable -any, 203 | aeson, 204 | old-time 205 | 206 | default-language: Haskell2010 207 | hs-source-dirs: tests src . 208 | ghc-options: -threaded -rtsopts -fno-ignore-asserts 209 | -------------------------------------------------------------------------------- /transient-universe/universe.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/transient-haskell/transient-stack/8bcadfa817551cbe46be17bc6a8a21e1a1ed097e/transient-universe/universe.png -------------------------------------------------------------------------------- /transient/.gitignore: -------------------------------------------------------------------------------- 1 | # Ignore all 2 | * 3 | 4 | # Unignore all with extensions 5 | !*.* 6 | 7 | # Unignore all dirs 8 | !*/ 9 | 10 | Demos/old-trash 11 | Demos/db 12 | Test 13 | errlog 14 | .tcachedata 15 | .cabal-sandbox 16 | cabal.sandbox* 17 | favicon 18 | IDE.session 19 | MFlow.lkshf 20 | notes.txt 21 | notes.lhs 22 | dist 23 | *.js* 24 | *.o 25 | *.hi 26 | .cabal-sandbox 27 | cabal.sanbox.config 28 | .stack* 29 | # emacs stuff 30 | *~ 31 | \#*\# 32 | /.emacs.desktop 33 | /.emacs.desktop.lock 34 | *.elc 35 | auto-save-list 36 | tramp 37 | .\#* 38 | 39 | # Org-mode 40 | .org-id-locations 41 | *_archive 42 | 43 | # flymake-mode 44 | *_flymake.* 45 | 46 | # eshell files 47 | /eshell/history 48 | /eshell/lastdir 49 | 50 | # elpa packages 51 | /elpa/ 52 | 53 | # vim stuff 54 | *.swp 55 | *.swo 56 | 57 | *.key 58 | _darcs 59 | darcs* 60 | -------------------------------------------------------------------------------- /transient/.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=8.0.1 CABALVER=1.24 30 | compiler: ": #GHC 8.0.1" 31 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], 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=7.10.2 CABALVER=1.22 36 | compiler: ": #GHC 7.10.2" 37 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2], 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-7" 48 | compiler: ": #stack 8.0.1 LTS 7" 49 | addons: {apt: {packages: [ghc-8.0.1], sources: [hvr-ghc]}} 50 | - env: BUILD=stack ARGS="--resolver lts-6" 51 | compiler: ": #stack 7.10.3 LTS 6" 52 | addons: {apt: {packages: [ghc-7.10.3], sources: [hvr-ghc]}} 53 | - env: BUILD=stack ARGS="--resolver lts-5" 54 | compiler: ": #stack 7.10.3 LTS 5" 55 | addons: {apt: {packages: [ghc-7.10.3], sources: [hvr-ghc]}} 56 | - env: BUILD=stack ARGS="--resolver lts-3" 57 | compiler: ": #stack 7.10.2 LTS 3" 58 | addons: {apt: {packages: [ghc-7.10.2], sources: [hvr-ghc]}} 59 | 60 | # Nightly builds are allowed to fail 61 | - env: BUILD=stack ARGS="--resolver nightly" 62 | compiler: ": #stack nightly" 63 | addons: {apt: {packages: [libgmp-dev]}} 64 | 65 | # GHCJS build via stack 66 | - env: BUILD=ghcjs ARGS="--stack-yaml=stack-ghcjs.yaml" 67 | compiler: ": #stack GHCJS" 68 | addons: {apt: {packages: [ghc-8.0.1], sources: [hvr-ghc]}} 69 | 70 | # Build on OS X in addition to Linux 71 | - env: BUILD=stack ARGS="--resolver lts-7" 72 | compiler: ": #stack 8.0.1 LTS 7 (OS X)" 73 | os: osx 74 | 75 | allow_failures: 76 | - env: BUILD=stack ARGS="--resolver lts-7" 77 | compiler: ": #stack 8.0.1 LTS 7 (OS X)" 78 | os: osx 79 | - env: BUILD=ghcjs ARGS="--stack-yaml=stack-ghcjs.yaml" 80 | - env: BUILD=cabal GHCVER=head CABALVER=head 81 | - env: BUILD=stack ARGS="--resolver nightly" 82 | 83 | before_install: 84 | # Using compiler above sets CC to an invalid value, so unset it 85 | - unset CC 86 | - export CASHER_TIME_OUT=600 87 | - if [ $BUILD = "ghcjs" ]; then nvm install 6; fi 88 | 89 | # We want to always allow newer versions of packages when building on GHC HEAD 90 | - CABALARGS="" 91 | - if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi 92 | 93 | # Download and unpack the stack executable 94 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:$PATH 95 | - mkdir -p ~/.local/bin 96 | - | 97 | if [ `uname` = "Darwin" ] 98 | then 99 | curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 100 | else 101 | curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 102 | fi 103 | 104 | install: 105 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 106 | - if [ -f configure.ac ]; then autoreconf -i; fi 107 | - | 108 | case "$BUILD" in 109 | stack) 110 | stack --no-terminal --install-ghc $ARGS test --only-dependencies 111 | ;; 112 | cabal) 113 | cabal --version 114 | travis_retry cabal update 115 | cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS 116 | ;; 117 | ghcjs) 118 | stack --no-terminal --install-ghc install hsc2hs 119 | stack --no-terminal setup $ARGS 120 | stack --no-terminal --install-ghc $ARGS test --only-dependencies 121 | ;; 122 | esac 123 | 124 | script: 125 | - | 126 | case "$BUILD" in 127 | cabal) 128 | cabal configure --enable-tests --enable-benchmarks -v2 --ghc-options="-O0 -Werror" 129 | cabal build 130 | cabal check || [ "$CABALVER" == "1.16" ] 131 | cabal test 132 | cabal sdist 133 | cabal copy 134 | SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && \ 135 | (cd dist && cabal install --force-reinstalls "$SRC_TGZ") 136 | ;; 137 | *) 138 | stack --no-terminal $ARGS test --haddock --no-haddock-deps 139 | ;; 140 | esac 141 | -------------------------------------------------------------------------------- /transient/CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to Transient 2 | 3 | # Getting Started 4 | * Create a [GitHub](https://github.com) account if you do not already have one 5 | * Check if a ticket for your issue exists, if not create one 6 | * Make sure your ticket details the issue and the steps to reproduce the bug 7 | * If your ticket proposes a new feature for Transient, please provide an explanation of the feature, what problem it solves, and possible use cases 8 | * Fork the repository on GitHub 9 | 10 | # Changing Transient 11 | * Create a branch from `master` to work on your feature with a descriptive name 12 | * Make commits frequently with descriptive comments (detailed below) 13 | * Add tests to ensure proper functionality 14 | * Please do not submit until all tests are passed 15 | 16 | Commit messages should stick to the following format: `(issue number) issue name description` 17 | 18 | E.g: 19 | 20 | ``` 21 | Example issue 22 | Steps to recreate: 23 | - Put toast in oven 24 | - Turn oven off 25 | - ???? 26 | 27 | An issue would then here go into detail describing the issue, and perhaps even suggesting a fix 28 | ``` 29 | 30 | # Making Small Changes 31 | When changing things like documentation, it is not always necessary to create a ticket. Instead simply add the documentation, and send a PR with a message of the following form: 32 | 33 | ``` 34 | (doc) Added documentation to 35 | lacked proper documentation on how works. 36 | 37 | This commit adds documentation describing , and provides various examples. 38 | ``` 39 | 40 | # Submitting Changes 41 | * Push your changes to the branch in your fork of the repository 42 | * Submit a pull request 43 | * The Transient team will review your PR as quickly and provide feedback 44 | * After receiving feedback, either make the required changes, or your branch will be merged 45 | 46 | Thanks for contributing to Transient, happy hacking! 47 | -------------------------------------------------------------------------------- /transient/ChangeLog.md: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/transient-haskell/transient-stack/8bcadfa817551cbe46be17bc6a8a21e1a1ed097e/transient/ChangeLog.md -------------------------------------------------------------------------------- /transient/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM agocorona/herokughcjs 2 | RUN git clone https://github.com/agocorona/transient transgit \ 3 | && cd transgit \ 4 | && git checkout ghcjs \ 5 | && cabal install 6 | 7 | RUN cd transgit && cabal install --ghcjs 8 | 9 | RUN git clone https://github.com/agocorona/ghcjs-perch \ 10 | && cd ghcjs-perch \ 11 | && cabal install \ 12 | && cabal install --ghcjs # 13 | 14 | RUN git clone https://github.com/agocorona/ghcjs-hplay \ 15 | && cd ghcjs-hplay \ 16 | && cabal install --ghcjs \ 17 | && cabal install 18 | 19 | ADD . /transient/ 20 | 21 | CMD cd /transient && chmod 777 buildrun.sh && ./buildrun.sh 22 | 23 | 24 | 25 | -------------------------------------------------------------------------------- /transient/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright © 2014-2016 Alberto G. Corona 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of 4 | this software and associated documentation files (the "Software"), to deal in 5 | the Software without restriction, including without limitation the rights to 6 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 7 | the Software, and to permit persons to whom the Software is furnished to do so, 8 | subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 15 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 16 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 17 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 18 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -------------------------------------------------------------------------------- /transient/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /transient/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 | -------------------------------------------------------------------------------- /transient/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/transient-haskell/transient-stack/8bcadfa817551cbe46be17bc6a8a21e1a1ed097e/transient/logo.png -------------------------------------------------------------------------------- /transient/src/Transient/Backtrack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | 4 | -- | Transient implements an event handling mechanism ("backtracking") which 5 | -- allows registration of one or more event handlers to be executed when an 6 | -- event occurs. This common underlying mechanism called is used to handle 7 | -- three different types of events: 8 | -- 9 | -- * User initiated actions to run undo and retry actions on failures 10 | -- * Finalization actions to run at the end of a task 11 | -- * Exception handlers to run when exceptions are raised 12 | -- 13 | -- Backtracking works seamlessly across thread boundaries. The freedom to put 14 | -- the undo, exception handling and finalization code where we want it allows 15 | -- us to write modular and composable code. 16 | -- 17 | -- Note that backtracking (undo, finalization or exception handling) does not 18 | -- roll back the user defined state in any way. It only 19 | -- executes the user-defined handlers. State changes are only caused via user 20 | -- defined actions. These actions also can change the state as it was when backtracking started. 21 | -- 22 | -- This example prints the final state as "world". 23 | -- 24 | -- @ 25 | -- import Transient.Base (keep, setState, getState) 26 | -- import Transient.Backtrack (onUndo, undo) 27 | -- import Control.Monad.IO.Class (liftIO) 28 | -- 29 | -- main = keep $ do 30 | -- setState "hello" 31 | -- oldState <- getState 32 | -- 33 | -- liftIO (putStrLn "Register undo") \`onUndo\` (do 34 | -- curState <- getState 35 | -- liftIO $ putStrLn $ "Final state: " ++ curState 36 | -- liftIO $ putStrLn $ "Old state: " ++ oldState) 37 | -- 38 | -- setState "world" >> undo >> return () 39 | -- @ 40 | -- 41 | -- See 42 | -- 43 | -- for more details. 44 | 45 | module Transient.Backtrack ( 46 | 47 | -- * Multi-track Undo 48 | -- $multitrack 49 | onBack, back, forward, backCut, 50 | 51 | -- * Default Track Undo 52 | -- $defaulttrack 53 | onUndo, undo, retry, undoCut, 54 | 55 | -- * Finalization Primitives 56 | -- $finalization 57 | onFinish, onFinish', finish, noFinish, initFinish 58 | ) where 59 | 60 | import Transient.Internals 61 | 62 | 63 | -- Code moved to Internals in order to manage exceptions in spawned threads. 64 | -------------------------------------------------------------------------------- /transient/src/Transient/EVars.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | module Transient.EVars where 3 | 4 | import Transient.Internals 5 | import Data.Typeable 6 | 7 | import Control.Applicative 8 | import Control.Concurrent.STM 9 | import Control.Monad.State 10 | 11 | 12 | 13 | 14 | 15 | data EVar a= EVar (TChan (StreamData a)) deriving Typeable 16 | 17 | 18 | -- | creates an EVar. 19 | -- 20 | -- Evars are event vars. `writeEVar` trigger the execution of all the continuations associated to the `readEVar` of this variable 21 | -- (the code that is after them). 22 | -- 23 | -- It is like the publish-subscribe pattern but without inversion of control, since a readEVar can be inserted at any place in the 24 | -- Transient flow. 25 | -- 26 | -- EVars are created upstream and can be used to communicate two sub-threads of the monad. Following the Transient philosophy they 27 | -- do not block his own thread if used with alternative operators, unlike the IORefs and TVars. And unlike STM vars, that are composable, 28 | -- they wait for their respective events, while TVars execute the whole expression when any variable is modified. 29 | -- 30 | -- The execution continues after the writeEVar when all subscribers have been executed. 31 | -- 32 | -- Now the continuations are executed in parallel. 33 | -- 34 | -- see https://www.fpcomplete.com/user/agocorona/publish-subscribe-variables-transient-effects-v 35 | -- 36 | 37 | newEVar :: TransIO (EVar a) 38 | newEVar = Transient $ do 39 | ref <-liftIO newBroadcastTChanIO 40 | return . Just $ EVar ref 41 | 42 | -- | delete al the subscriptions for an evar. 43 | cleanEVar :: EVar a -> TransIO () 44 | cleanEVar (EVar ref1)= liftIO $ atomically $ writeTChan ref1 SDone 45 | 46 | 47 | -- | read the EVar. It only succeed when the EVar is being updated 48 | -- The continuation gets registered to be executed whenever the variable is updated. 49 | -- 50 | -- if readEVar is re-executed in any kind of loop, since each continuation is different, this will register 51 | -- again. The effect is that the continuation will be executed multiple times 52 | -- To avoid multiple registrations, use `cleanEVar` 53 | readEVar :: EVar a -> TransIO a 54 | readEVar (EVar ref1)= do 55 | tchan <- liftIO . atomically $ dupTChan ref1 56 | r <- parallel $ atomically $ readTChan tchan 57 | case r of 58 | SDone -> empty 59 | SMore x -> return x 60 | SLast x -> return x 61 | SError e -> empty 62 | -- error $ "readEVar: "++ show e 63 | 64 | -- | update the EVar and execute all readEVar blocks with "last in-first out" priority 65 | -- 66 | writeEVar :: EVar a -> a -> TransIO () 67 | writeEVar (EVar ref1) x= liftIO $ atomically $ do 68 | writeTChan ref1 $ SMore x 69 | 70 | 71 | -- | write the EVar and drop all the `readEVar` handlers. 72 | -- 73 | -- It is like a combination of `writeEVar` and `cleanEVar` 74 | lastWriteEVar (EVar ref1) x= liftIO $ atomically $ do 75 | writeTChan ref1 $ SLast x 76 | 77 | 78 | 79 | -------------------------------------------------------------------------------- /transient/src/Transient/EVars.old.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | module Transient.EVars where 3 | 4 | import Transient.Base 5 | import Transient.Internals(runTransState,onNothing, EventF(..), killChildren) 6 | import qualified Data.Map as M 7 | import Data.Typeable 8 | 9 | import Control.Concurrent 10 | import Control.Applicative 11 | import Control.Concurrent.STM 12 | import Control.Monad.IO.Class 13 | import Control.Exception(SomeException) 14 | 15 | import Data.List(nub) 16 | import Control.Monad.State 17 | 18 | 19 | 20 | data EVar a= EVar Int (TVar (Int,Int)) (TChan (StreamData a)) deriving Typeable 21 | 22 | 23 | -- | creates an EVar. 24 | -- 25 | -- Evars are event vars. `writeEVar` trigger the execution of all the continuations associated to the `readEVar` of this variable 26 | -- (the code that is after them). 27 | -- 28 | -- It is like the publish-subscribe pattern but without inversion of control, since a readEVar can be inserted at any place in the 29 | -- Transient flow. 30 | -- 31 | -- EVars are created upstream and can be used to communicate two sub-threads of the monad. Following the Transient philosophy they 32 | -- do not block his own thread if used with alternative operators, unlike the IORefs and TVars. And unlike STM vars, that are composable, 33 | -- they wait for their respective events, while TVars execute the whole expression when any variable is modified. 34 | -- 35 | -- The execution continues after the writeEVar when all subscribers have been executed. 36 | -- 37 | -- Now the continuations are executed in parallel. 38 | -- 39 | -- see https://www.fpcomplete.com/user/agocorona/publish-subscribe-variables-transient-effects-v 40 | -- 41 | 42 | newEVar :: TransIO (EVar a) 43 | newEVar = Transient $ do 44 | id <- genId 45 | rn <- liftIO $ newTVarIO (0,0) 46 | ref <-liftIO newTChanIO 47 | return . Just $ EVar id rn ref 48 | 49 | -- | delete al the subscriptions for an evar. 50 | cleanEVar :: EVar a -> TransIO () 51 | cleanEVar (EVar id rn ref1)= liftIO $ atomically $ do 52 | writeTChan ref1 SDone 53 | writeTVar rn (0,0) 54 | 55 | -- | read the EVar. It only succeed when the EVar is being updated 56 | -- The continuation gets registered to be executed whenever the variable is updated. 57 | -- 58 | -- if readEVar is re-executed in any kind of loop, since each continuation is different, this will register 59 | -- again. The effect is that the continuation will be executed multiple times 60 | -- To avoid multiple registrations, use `cleanEVar` 61 | readEVar (EVar id rn ref1)= freeThreads $ do 62 | liftIO $ atomically $ readTVar rn >>= \(n,n') -> writeTVar rn $ (n+1,n'+1) 63 | r <- parallel $ atomically $ do 64 | r <- peekTChan ref1 65 | ---- return () !> "peekTChan executed" 66 | (n,n') <- readTVar rn -- !> "readtvar rn" 67 | -- return () !> ("rn",n) 68 | if n'> 1 then do 69 | writeTVar rn (n,n'-1) 70 | return r 71 | else do 72 | readTChan ref1 73 | writeTVar rn (n,n) 74 | return r 75 | 76 | case r of 77 | SDone -> empty 78 | SMore x -> return x 79 | SLast x -> return x 80 | SError e -> liftIO $ do 81 | atomically $ readTVar rn >>= \(n,n') -> writeTVar rn $ (n-1,n'-1) 82 | myThreadId >>= killThread 83 | error $ "readEVar: "++ show e 84 | 85 | -- | update the EVar and execute all readEVar blocks with "last in-first out" priority 86 | -- 87 | writeEVar (EVar id rn ref1) x= liftIO $ atomically $ do 88 | writeTChan ref1 $ SMore x 89 | 90 | 91 | -- | write the EVar and drop all the `readEVar` handlers. 92 | -- 93 | -- It is like a combination of `writeEVar` and `cleanEVar` 94 | lastWriteEVar (EVar id rn ref1) x= liftIO $ atomically $ do 95 | writeTChan ref1 $ SLast x 96 | 97 | 98 | -- Finalization 99 | 100 | 101 | type FinishReason= Maybe SomeException 102 | 103 | 104 | 105 | data Finish= Finish (EVar FinishReason) deriving Typeable 106 | 107 | -- | initialize the event variable for finalization. 108 | -- all the following computations in different threads will share it 109 | -- it also isolate this event from other branches that may have his own finish variable 110 | initFinish :: TransIO Finish 111 | initFinish= do 112 | fin <- newEVar 113 | let f = Finish fin 114 | setData f 115 | return f 116 | 117 | -- | set a computation to be called when the finish event happens 118 | onFinish :: (FinishReason ->TransIO ()) -> TransIO () 119 | onFinish close= do 120 | Finish finish <- getSData <|> initFinish 121 | e <- readEVar finish 122 | close e -- !!> "CLOSE" 123 | stop 124 | <|> 125 | return () 126 | 127 | 128 | 129 | -- | trigger the event, so this closes all the resources 130 | finish :: FinishReason -> TransIO () 131 | finish e= do 132 | liftIO $ putStr "finish: " >> print e 133 | Finish finish <- getSData <|> initFinish 134 | lastWriteEVar finish e 135 | 136 | -- | deregister all the finalization actions. 137 | -- A initFinish is needed to register actions again 138 | unFinish= do 139 | Finish fin <- getSData 140 | cleanEVar fin -- !!> "DELEVAR" 141 | <|> return () -- !!> "NOT DELEVAR" 142 | 143 | 144 | -- | kill all the processes generated by the parameter when finish event occurs 145 | killOnFinish comp= do 146 | 147 | chs <- liftIO $ newTVarIO [] 148 | onFinish $ const $ liftIO $ killChildren chs -- !> "killOnFinish event" 149 | r <- comp 150 | modify $ \ s -> s{children= chs} 151 | return r 152 | 153 | -- | trigger finish when the stream data return SDone 154 | checkFinalize v= 155 | case v of 156 | SDone -> finish Nothing >> stop 157 | SLast x -> return x 158 | SError e -> liftIO ( print e) >> finish Nothing >> stop 159 | SMore x -> return x 160 | 161 | -------------------------------------------------------------------------------- /transient/src/Transient/Indeterminism.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Transient.Indeterminism 4 | -- Copyright : 5 | -- License : MIT 6 | -- 7 | -- Maintainer : agocorona@gmail.com 8 | -- Stability : 9 | -- Portability : 10 | -- 11 | -- | see 12 | -- 13 | ----------------------------------------------------------------------------- 14 | {-# LANGUAGE ScopedTypeVariables, CPP #-} 15 | module Transient.Indeterminism ( 16 | choose, choose', chooseStream, collect, collect', group, groupByTime, burst 17 | ) where 18 | 19 | import Transient.Internals hiding (retry) 20 | 21 | import Data.IORef 22 | import Control.Applicative 23 | import Data.Monoid 24 | import Control.Concurrent 25 | import Control.Monad.State 26 | import Control.Exception 27 | import qualified Data.ByteString.Char8 as BS 28 | 29 | 30 | 31 | -- | Converts a list of pure values into a transient task set. You can use the 32 | -- 'threads' primitive to control the parallelism. 33 | -- 34 | choose :: [a] -> TransIO a 35 | choose []= empty 36 | choose xs = chooseStream xs >>= checkFinalize 37 | 38 | -- | transmit the end of stream 39 | chooseStream :: [a] -> TransIO (StreamData a) 40 | chooseStream []= empty 41 | chooseStream xs = do 42 | evs <- liftIO $ newIORef xs 43 | parallel $ do 44 | es <- atomicModifyIORef evs $ \es -> let tes= tail es in (tes,es) 45 | case es of 46 | [x] -> x `seq` return $ SLast x 47 | x:_ -> x `seq` return $ SMore x 48 | 49 | 50 | -- | Same as 'choose', slower in some cases 51 | -- 52 | choose' :: [a] -> TransIO a 53 | choose' xs = foldl (<|>) empty $ map (async . return) xs 54 | 55 | 56 | -- | Collect the results of a task set in groups of @n@ elements. 57 | -- 58 | group :: Int -> TransIO a -> TransIO [a] 59 | group num proc = do 60 | v <- liftIO $ newIORef (0,[]) 61 | x <- proc 62 | 63 | mn <- liftIO $ atomicModifyIORef v $ \(n,xs) -> 64 | let n'=n +1 65 | in if n'== num 66 | 67 | then ((0,[]), Just $ x:xs) 68 | else ((n', x:xs),Nothing) 69 | case mn of 70 | Nothing -> stop 71 | Just xs -> return xs 72 | 73 | 74 | -- | Collect the results of the first @n@ tasks. Synchronizes concurrent tasks 75 | -- to collect the results safely and kills all the non-free threads before 76 | -- returning the results. Results are returned in the thread where 'collect' 77 | -- is called. 78 | -- 79 | collect :: Int -> TransIO a -> TransIO [a] 80 | collect n = collect' n 0 81 | 82 | -- | Like 'collect' but with a timeout. When the timeout is zero it behaves 83 | -- exactly like 'collect'. If the timeout (second parameter) is non-zero, 84 | -- collection stops after the timeout and the results collected till now are 85 | -- returned. 86 | -- 87 | collect' :: Int -> Int -> TransIO a -> TransIO [a] 88 | collect' n t search= do 89 | 90 | 91 | rv <- liftIO $ newEmptyMVar -- !> "NEWMVAR" 92 | 93 | results <- liftIO $ newIORef (0,[]) 94 | 95 | let worker = do 96 | r <- abduce >> search 97 | liftIO $ putMVar rv $ Just r 98 | stop 99 | 100 | timer= do 101 | when (t > 0) $ do 102 | --addThreads 1 103 | async $ threadDelay t >> putMVar rv Nothing 104 | empty 105 | 106 | monitor= liftIO loop 107 | 108 | where 109 | loop = do 110 | mr <- takeMVar rv 111 | 112 | (n',rs) <- readIORef results 113 | case mr of 114 | Nothing -> return rs 115 | Just r -> do 116 | let n''= n' + 1 117 | let rs'= r:rs 118 | writeIORef results (n'',rs') 119 | 120 | if (n > 0 && n'' >= n) 121 | then return (rs') 122 | else loop 123 | `catch` \(_ :: BlockedIndefinitelyOnMVar) -> 124 | readIORef results >>= return . snd 125 | 126 | 127 | oneThread $ timer <|> worker <|> monitor 128 | 129 | 130 | -- | insert `SDone` response every time there is a timeout since the last response 131 | 132 | burst :: Int -> TransIO a -> TransIO (StreamData a) 133 | burst timeout comp= do 134 | r <- oneThread comp 135 | return (SMore r) <|> (async (threadDelay timeout) >> return SDone) 136 | 137 | -- | Collect the results of a task set, grouping all results received within 138 | -- every time interval specified by the first parameter as `diffUTCTime`. 139 | groupByTime :: Monoid a => Int -> TransIO a -> TransIO a 140 | groupByTime timeout comp= do 141 | v <- liftIO $ newIORef mempty 142 | gather v <|> run v 143 | where 144 | run v = do 145 | x <- comp 146 | liftIO $ atomicModifyIORef v $ \xs -> (xs <> x,()) 147 | empty 148 | 149 | gather v= waitEvents $ do 150 | threadDelay timeout 151 | atomicModifyIORef v $ \xs -> (mempty , xs) 152 | 153 | 154 | -------------------------------------------------------------------------------- /transient/src/Transient/Mailboxes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | module Transient.Mailboxes where 3 | 4 | import Transient.Internals 5 | import Transient.EVars 6 | import qualified Data.Map as M 7 | import Data.IORef 8 | import Data.Typeable 9 | import System.IO.Unsafe 10 | import Unsafe.Coerce 11 | import Control.Monad.IO.Class 12 | 13 | mailboxes :: IORef (M.Map MailboxId (EVar SData)) 14 | mailboxes= unsafePerformIO $ newIORef M.empty 15 | 16 | data MailboxId = forall a .(Typeable a, Ord a) => MailboxId a TypeRep 17 | --type SData= () 18 | instance Eq MailboxId where 19 | id1 == id2 = id1 `compare` id2== EQ 20 | 21 | instance Ord MailboxId where 22 | MailboxId n t `compare` MailboxId n' t'= 23 | case typeOf n `compare` typeOf n' of 24 | EQ -> case n `compare` unsafeCoerce n' of 25 | EQ -> t `compare` t' 26 | LT -> LT 27 | GT -> GT 28 | 29 | other -> other 30 | 31 | instance Show MailboxId where 32 | show ( MailboxId _ t) = show t 33 | 34 | -- | write to the mailbox 35 | -- Mailboxes are node-wide, for all processes that share the same connection data, that is, are under the 36 | -- same `listen` or `connect` 37 | -- while EVars are only visible by the process that initialized it and his children. 38 | -- Internally, the mailbox is in a well known EVar stored by `listen` in the `Connection` state. 39 | putMailbox :: Typeable val => val -> TransIO () 40 | putMailbox = putMailbox' (0::Int) 41 | 42 | -- | write to a mailbox identified by an identifier besides the type 43 | putMailbox' :: (Typeable key, Ord key, Typeable val) => key -> val -> TransIO () 44 | putMailbox' idbox dat= do 45 | let name= MailboxId idbox $ typeOf dat 46 | mbs <- liftIO $ readIORef mailboxes 47 | let mev = M.lookup name mbs 48 | case mev of 49 | Nothing -> newMailbox name >> putMailbox' idbox dat 50 | Just ev -> writeEVar ev $ unsafeCoerce dat 51 | 52 | 53 | newMailbox :: MailboxId -> TransIO () 54 | newMailbox name= do 55 | -- return () -- !> "newMailBox" 56 | ev <- newEVar 57 | liftIO $ atomicModifyIORef mailboxes $ \mv -> (M.insert name ev mv,()) 58 | 59 | 60 | 61 | -- | get messages from the mailbox that matches with the type expected. 62 | -- The order of reading is defined by `readTChan` 63 | -- This is reactive. it means that each new message trigger the execution of the continuation 64 | -- each message wake up all the `getMailbox` computations waiting for it. 65 | getMailbox :: Typeable val => TransIO val 66 | getMailbox = getMailbox' (0 :: Int) 67 | 68 | -- | read from a mailbox identified by an identifier besides the type 69 | getMailbox' :: (Typeable key, Ord key, Typeable val) => key -> TransIO val 70 | getMailbox' mboxid = x where 71 | x = do 72 | let name= MailboxId mboxid $ typeOf $ typeOfM x 73 | mbs <- liftIO $ readIORef mailboxes 74 | let mev = M.lookup name mbs 75 | case mev of 76 | Nothing ->newMailbox name >> getMailbox' mboxid 77 | Just ev ->unsafeCoerce $ readEVar ev 78 | 79 | typeOfM :: TransIO a -> a 80 | typeOfM = undefined 81 | 82 | -- | delete all subscriptions for that mailbox expecting this kind of data 83 | deleteMailbox :: Typeable a => a -> TransIO () 84 | deleteMailbox = deleteMailbox' (0 ::Int) 85 | 86 | -- | clean a mailbox identified by an Int and the type 87 | deleteMailbox' :: (Typeable key, Ord key, Typeable a) => key -> a -> TransIO () 88 | deleteMailbox' mboxid witness= do 89 | let name= MailboxId mboxid $ typeOf witness 90 | mbs <- liftIO $ readIORef mailboxes 91 | let mev = M.lookup name mbs 92 | case mev of 93 | Nothing -> return() 94 | Just ev -> do cleanEVar ev 95 | liftIO $ atomicModifyIORef mailboxes $ \bs -> (M.delete name bs,()) 96 | -------------------------------------------------------------------------------- /transient/stack-ghcjs.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-7.7 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | flags: {} 6 | extra-package-dbs: [] 7 | 8 | compiler: ghcjs-0.2.1.9007007_ghc-8.0.1 9 | compiler-check: match-exact 10 | setup-info: 11 | ghcjs: 12 | source: 13 | ghcjs-0.2.1.9007007_ghc-8.0.1: 14 | url: http://ghcjs.tolysz.org/ghc-8.0-2016-11-03-lts-7.7-9007007.tar.gz 15 | sha1: ce169f85f1c49ad613ae77fc494d5565452ff59a 16 | allow-newer: true 17 | -------------------------------------------------------------------------------- /transient/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-7.7 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | flags: {} 6 | extra-package-dbs: [] 7 | pvp-bounds: both 8 | -------------------------------------------------------------------------------- /transient/tests/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, OverloadedStrings,ScopedTypeVariables, DeriveDataTypeable, FlexibleInstances, UndecidableInstances #-} 2 | 3 | import Transient.Internals 4 | import Transient.EVars 5 | import Transient.Logged 6 | import Transient.Parse 7 | import Transient.Indeterminism 8 | import Data.Typeable 9 | import Control.Applicative 10 | import Data.Monoid 11 | 12 | import System.Directory 13 | import System.IO 14 | import System.Random 15 | import Control.Exception 16 | import Control.Concurrent.MVar 17 | import Control.Concurrent 18 | 19 | import qualified Data.ByteString.Char8 as BSS 20 | import qualified Data.ByteString.Lazy.Char8 as BS 21 | import Data.ByteString.Builder 22 | import Control.Monad.IO.Class 23 | import System.Time 24 | import Control.Monad 25 | -- import Data.Beamable hiding (serialize,deserialize) 26 | 27 | instance Loggable BS.ByteString 28 | instance Loggable Int where 29 | serialize = intDec -- byteString . toBSSign 30 | deserialize= withGetParseString $ \str -> 31 | case BS.readInt str of -- = int readInt 32 | Just x -> return x 33 | Nothing -> empty 34 | 35 | 36 | 37 | main= keep' $ test4 38 | 39 | test4= do 40 | sync (do (async $ do threadDelay 1000000; print "hello") ) <|> liftIO ( print "word") 41 | 42 | 43 | test3= noTrans $ do 44 | r <- runTrans $ collect 1 $ choose' ["hello","world" :: String] 45 | liftIO $ print r 46 | 47 | test1= do 48 | t1 <- liftIO $ getClockTime 49 | sum <- foldM (\sum i -> do 50 | setParseString $ toLazyByteString $ serialize (i:: Int) 51 | s <- deserialize 52 | return $ sum+ s) 53 | 0 [1..1000] 54 | t2 <- liftIO $ getClockTime 55 | liftIO $ print (sum :: Int) 56 | 57 | 58 | test2= do 59 | t1 <- liftIO $ getClockTime 60 | forM [1..1000] $ \i -> do 61 | logged $ return (i :: Int) 62 | Just(Log _ _ full _ _) <- getData 63 | -- liftIO $ print $ toLazyByteString full 64 | setData $ Log True full full 0 0 65 | setParseString $ toLazyByteString full 66 | sum <- foldM (\sum i -> do 67 | s <- logged $ return (0:: Int) 68 | -- liftIO $ print s 69 | return $ sum+ s) 70 | 0 [1..1000] 71 | 72 | t2 <- liftIO getClockTime 73 | liftIO $ print (sum :: Int) 74 | liftIO $ print $ diffClockTimes t2 t1 75 | 76 | -------------------------------------------------------------------------------- /transient/tests/Test2.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- The Computer Language Benchmarks Game 3 | -- http://benchmarksgame.alioth.debian.org/ 4 | -- 5 | -- Contributed by Don Stewart 6 | -- Parallelized by Louis Wasserman 7 | {-#LANGUAGE BangPatterns #-} 8 | 9 | import System.Environment 10 | import Control.Monad 11 | import System.Mem 12 | import Data.Bits 13 | import Text.Printf 14 | 15 | 16 | -- 17 | -- an artificially strict tree. 18 | -- 19 | -- normally you would ensure the branches are lazy, but this benchmark 20 | -- requires strict allocation. 21 | -- 22 | data Tree = Nil | Node !Int !Tree !Tree 23 | 24 | minN = 4 25 | 26 | io s n t = printf "%s of depth %d\t check: %d\n" s n t 27 | 28 | main = do 29 | n <- getArgs >>= readIO . head 30 | let maxN = max (minN + 2) n 31 | stretchN = maxN + 1 32 | -- stretch memory tree 33 | let c = {-# SCC "stretch" #-} check (make 0 stretchN) 34 | io "stretch tree" stretchN c 35 | 36 | -- allocate a long lived tree 37 | let !long = make 0 maxN 38 | 39 | -- allocate, walk, and deallocate many bottom-up binary trees 40 | let vs = depth minN maxN 41 | mapM_ (\((m,d,i)) -> io (show m ++ "\t trees") d i) vs 42 | 43 | -- confirm the the long-lived binary tree still exists 44 | io "long lived tree" maxN (check long) 45 | 46 | -- generate many trees 47 | depth :: Int -> Int -> [(Int,Int,Int)] 48 | depth d m 49 | | d <= m = let 50 | s = sumT d n 0 51 | rest = depth (d+2) m 52 | in s `par` ((2*n,d,s) : rest) 53 | | otherwise = [] 54 | where n = bit (m - d + minN) 55 | 56 | -- allocate and check lots of trees 57 | sumT :: Int -> Int -> Int -> Int 58 | sumT d 0 t = t 59 | sumT d i t = a `par` b `par` sumT d (i-1) ans 60 | where a = check (make i d) 61 | b = check (make (-i) d) 62 | ans = a + b + t 63 | 64 | check = check' True 0 65 | 66 | -- traverse the tree, counting up the nodes 67 | check' :: Bool -> Int -> Tree -> Int 68 | check' !b !z Nil = z 69 | check' b z (Node i l r) = check' (not b) (check' b (if b then z+i else z-i) l) r 70 | 71 | -- build a tree 72 | make :: Int -> Int -> Tree 73 | make i 0 = Node i Nil Nil 74 | make i d = Node i (make (i2-1) d2) (make i2 d2) 75 | where i2 = 2*i; d2 = d-1-- 76 | -------------------------------------------------------------------------------- /transient/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 | -------------------------------------------------------------------------------- /transient/tests/TestSuite.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ./execthirdlinedocker.sh 2 | -- development 3 | -- set -e && docker run -it -v /c/Users/magocoal/OneDrive/Haskell/devel:/devel agocorona/transient:05-02-2017 bash -c "runghc -j2 -isrc -i/devel/transient/src /devel/transient/tests/$1 $2 $3 $4" 4 | 5 | -- compile and run within a docker image 6 | -- set -e && executable=`basename -s .hs ${1}` && docker run -it -v $(pwd):/work agocorona/transient:05-02-2017 bash -c "ghc /work/${1} && /work/${executable} ${2} ${3}" 7 | 8 | 9 | import qualified Prelude as Pr(return) 10 | import Prelude hiding ((>>=),(>>),return) 11 | 12 | import Transient.Base 13 | import Transient.EVars 14 | import Transient.Indeterminism 15 | 16 | import System.Exit 17 | import Data.Monoid 18 | import Control.Applicative 19 | import Control.Monad.State 20 | import System.Random 21 | import Control.Concurrent 22 | import Control.Exception.Base 23 | import Data.List 24 | 25 | 26 | --instance Monoid Int where 27 | -- mempty = 0 28 | -- mappend = (+) 29 | 30 | main= do 31 | keep' $ do 32 | let -- genElem :: a -> TransIO a 33 | genElem x= do -- generates synchronous and asynchronous results with various delays 34 | isasync <- liftIO randomIO 35 | delay <- liftIO $ randomRIO (1, 1000) 36 | liftIO $ threadDelay delay 37 | if isasync then async $ return x else return x 38 | 39 | liftIO $ putStrLn "--Testing thread control + Monoid + Applicative + async + indetermism---" 40 | 41 | collect 100 $ do -- gather the result of 100 iterations 42 | i <- threads 0 $ choose [1..100] -- test 100 times. 'loop' for 100 times 43 | nelems <- liftIO $ randomRIO (1, 100) -- :: TransIO Int 44 | nthreads <- liftIO $ randomRIO (0,nelems) -- different numbers of threads 45 | r <- threads nthreads $ foldr (+) 0 $ map genElem [1..nelems] -- sum sync and async results using applicative 46 | assert (r == sum[1..nelems]) $ return () 47 | 48 | liftIO $ putStrLn "--------------checking parallel execution, Alternative, events --------" 49 | ev <- newEVar 50 | r <- collect 3 $ readEVar ev <|> ((choose [1..3] >>= writeEVar ev) >> stop) 51 | assert (sort r== [1,2,3]) $ return () 52 | 53 | liftIO $ print "SUCCESS" 54 | exit () 55 | 56 | exitSuccess 57 | -------------------------------------------------------------------------------- /transient/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 | -------------------------------------------------------------------------------- /transient/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 | -------------------------------------------------------------------------------- /transient/tests/labelthreads.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | main2 = keep' $ do 6 | top <- topState 7 | r <- group 9 $ do 8 | x <- choose [1,2,3] 9 | labelState "async1" 10 | 11 | showThreads top 12 | liftIO $ threadDelay 1000000 13 | liftIO $ print x 14 | 15 | y <- choose ['a','b','c'] 16 | labelState "async2" 17 | showThreads top 18 | -- liftIO $ threadDelay 3000000 19 | id <- liftIO myThreadId 20 | liftIO $ print (x,y,id) 21 | liftIO $ print r 22 | -- liftIO $ threadDelay 1000000 23 | showThreads top 24 | 25 | 26 | 27 | main3= keep $ do 28 | top <- topState 29 | -- oneThread $ option "main" "to kill previous spawned processes and return to the main menu" <|> return "" 30 | -- liftIO $ putStrLn "MAIN MENU" 31 | showThreads top 32 | oneThread op1 33 | st <- getCont 34 | onFinish $ const $ do 35 | 36 | liftIO $ killChildren $ children st 37 | 38 | option "3" "3" 39 | liftIO $ print 3 40 | finish Nothing 41 | return () 42 | 43 | where 44 | op1= do 45 | 46 | option "1" "1" 47 | labelState "1" 48 | liftIO $ print 1 49 | op2= do 50 | 51 | option "2" "2" 52 | labelState "2" 53 | liftIO $ print 2 54 | 55 | -------------------------------------------------------------------------------- /transient/tests/puzzle.hs: -------------------------------------------------------------------------------- 1 | -- https://adventofcode.com/2019/day/4 2 | 3 | module Main where 4 | 5 | import Transient.Base 6 | import Transient.Indeterminism 7 | import Control.Monad.IO.Class 8 | import Control.Monad (guard) 9 | 10 | 11 | 12 | main= keep' $ freeThreads $ threads 4 $ do 13 | ns <- collect 0 $ puzzle 108457 562041 14 | liftIO $ print $ length ns 15 | 16 | puzzle n1 n2= do 17 | 18 | a <- choose [n1 `div` 100000..n2 `div` 100000] 19 | b <- choose [0..9] 20 | c <- choose [0..9] 21 | d <- choose [0..9] 22 | e <- choose [0..9] 23 | f <- choose [0..9] 24 | let sn= [a, b, c, d, e, f] 25 | let n= atoi sn 26 | guard $ n < n2 && n > n1 27 | guard $ a==b || b == c || c ==d || d==e || e==f 28 | guard $ a <= b && b <= c && c <= d && d <=e && e <= f 29 | 30 | 31 | where 32 | atoi n= foldl (\x y-> x*10+y) 0 n 33 | 34 | -------------------------------------------------------------------------------- /transient/tests/test5.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 | -- LIB="./" && runghc -DDEBUG -i${LIB}/transient/src -i${LIB}/transient-universe/src -i${LIB}/axiom/src $1 ${2} ${3} 4 | 5 | {-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} 6 | module Main where 7 | 8 | --import Transient.Move 9 | --import Transient.Move.Utils 10 | --import Transient.Logged 11 | import Transient.Internals 12 | import Transient.Indeterminism 13 | --import Transient.EVars 14 | --import Network 15 | import Control.Applicative 16 | import Control.Concurrent 17 | import Control.Monad.IO.Class 18 | import System.Environment 19 | import System.IO.Unsafe 20 | import Data.Monoid 21 | import System.IO 22 | import Control.Monad 23 | import Data.Maybe 24 | import Control.Exception hiding (onException) 25 | import Data.Typeable 26 | import Data.IORef 27 | import Data.List((\\)) 28 | 29 | import Transient.Logged 30 | import Transient.Move 31 | import Data.Aeson 32 | import Transient.Parse 33 | import qualified Data.ByteString.Lazy.Char8 as BS 34 | 35 | 36 | -- async exceptions 37 | main1 = keep $ job <|> killer 38 | 39 | job= do 40 | abduce 41 | labelState "JOB" 42 | onException $ \(e :: SomeException) -> do 43 | th <- liftIO myThreadId 44 | liftIO $ print ("JOB", e,th) 45 | empty 46 | tmask $ liftIO $ print (sum [0..10000000 :: Int]) 47 | 48 | liftIO $ Main.loop [0..] "JOB" 49 | 50 | loop [] _ = return() 51 | loop xs msg = do 52 | threadDelay 1000000 53 | print msg 54 | Main.loop (tail xs) msg 55 | 56 | killer = do 57 | abduce 58 | liftIO $ threadDelay 1000000 59 | th <- threadState "JOB" 60 | liftIO $ throwTo th $ ErrorCall "sent async exception to JOB" 61 | 62 | 63 | killer2 = do 64 | abduce 65 | labelState "KILLER" 66 | 67 | onException $ \(e :: SomeException) -> do 68 | th <- liftIO myThreadId 69 | liftIO $ print ("KILLER", e,th) 70 | empty 71 | 72 | liftIO $ threadDelay 1000000 73 | st <- getCont 74 | 75 | liftIO $ killChildren $ children $ fromJust $ parent st 76 | liftIO $ Main.loop [0..] "KILLER" 77 | return () 78 | 79 | 80 | tmask :: TransIO a -> TransIO a 81 | tmask proc = do 82 | (mr,_) <- liftIO $ mask_ $ runTransient proc 83 | if isJust mr then return $ fromJust mr else empty 84 | 85 | --------------------------------------------------------- 86 | 87 | 88 | withResource adquire release f= do 89 | 90 | r <- mask_ adquire 91 | f r 92 | release r 93 | 94 | tbracket adquire release = react (bracket adquire release) (return ()) 95 | 96 | useResources rs= collect 2 rs -- <|> liftIO (forever (threadDelay maxBound) ) 97 | 98 | main2= keep $ job1 99 | 100 | job1= do 101 | onException $ \(e :: SomeException) -> do 102 | th <- liftIO myThreadId 103 | liftIO $ print ("JOB", e,th) 104 | empty 105 | r <- tbracket adquire release 106 | --labelState "JOB" 107 | w <- useResources $ do 108 | i <- choose[1,2] 109 | liftIO $ print "after adquire, managing resource" 110 | return $ r ++ " processed " ++ show i 111 | 112 | liftIO $ print w 113 | where 114 | adquire = do 115 | print "adquire" 116 | return "Resource" 117 | release _ = print "release" 118 | 119 | 120 | main= keep $ do 121 | setParseString "{\"username\":\"xyz\",\"password\":\"xyz\"}" 122 | r <- param 123 | liftIO $ print ("value=",r :: Value) 124 | where 125 | string= do 126 | d <- isDone 127 | if d then empty !> "empty" else tTakeWhile (\c -> c /= '}' && c /= ']' ) 128 | 129 | 130 | 131 | -------------------------------------------------------------------------------- /transient/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 | -------------------------------------------------------------------------------- /transient/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 | -------------------------------------------------------------------------------- /transient/transient.cabal: -------------------------------------------------------------------------------- 1 | name: transient 2 | version: 0.7.0.0 3 | author: Alberto G. Corona 4 | extra-source-files: 5 | ChangeLog.md README.md 6 | maintainer: agocorona@gmail.com 7 | cabal-version: >=1.10 8 | build-type: Simple 9 | license: MIT 10 | license-file: LICENSE 11 | homepage: https://github.com/transient-haskell/transient 12 | bug-reports: https://github.com/transient-haskell/transient/issues 13 | synopsis: composing programs with multithreading, events and distributed computing 14 | description: See 15 | Distributed primitives are in the transient-universe package. Web primitives are in the axiom package. 16 | category: Control, Concurrency 17 | data-dir: "" 18 | 19 | flag debug 20 | description: Enable debugging outputs 21 | default: False 22 | manual: True 23 | 24 | library 25 | -- if impl(ghcjs >=0.1) 26 | -- build-depends: 27 | -- ghcjs-base -any 28 | 29 | 30 | build-depends: base >= 4.8.0 && < 5 31 | , containers >= 0.5.6 32 | , transformers >= 0.4.2 33 | , time >= 1.5 34 | , directory >= 1.2.2 35 | , bytestring >= 0.10.6 36 | 37 | 38 | -- libraries not bundled w/ GHC 39 | , mtl 40 | , stm 41 | , random 42 | 43 | 44 | exposed-modules: Transient.Backtrack 45 | Transient.Base 46 | Transient.EVars 47 | Transient.Mailboxes 48 | Transient.Indeterminism 49 | Transient.Internals 50 | Transient.Logged 51 | Transient.Parse 52 | 53 | 54 | 55 | exposed: True 56 | buildable: True 57 | default-language: Haskell2010 58 | hs-source-dirs: src . 59 | 60 | ghc-options: 61 | 62 | if flag(debug) 63 | cpp-options: -DDEBUG 64 | 65 | source-repository head 66 | type: git 67 | location: https://github.com/agocorona/transient-stack/transient 68 | 69 | test-suite test-transient 70 | 71 | if !impl(ghcjs >=0.1) 72 | build-depends: 73 | base >= 4.8.1 && < 5 74 | , containers >= 0.5.6 75 | , transformers >= 0.4.2 76 | , time >= 1.5 77 | , directory >= 1.2.2 78 | , bytestring >= 0.10.6 79 | 80 | -- libraries not bundled w/ GHC 81 | , mtl 82 | , stm 83 | , random == 1.1 84 | 85 | 86 | 87 | type: exitcode-stdio-1.0 88 | main-is: TestSuite.hs 89 | build-depends: 90 | base >4 91 | default-language: Haskell2010 92 | hs-source-dirs: tests src . 93 | ghc-options: -threaded -rtsopts 94 | --------------------------------------------------------------------------------