├── transient ├── ChangeLog.md ├── Setup.hs ├── logo.png ├── tests │ ├── Testspark.hs │ ├── puzzle.hs │ ├── labelthreads.hs │ ├── ghcjs-websockets.hs │ ├── Test3.hs │ ├── teststreamsocket.hs │ ├── Test2.hs │ ├── TestSuite.hs │ ├── test5.hs │ ├── teststream.hs │ └── Test.hs ├── Dockerfile ├── .gitignore ├── circle.yml ├── LICENSE ├── CONTRIBUTING.md ├── src │ └── Transient │ │ ├── Backtrack.hs │ │ └── Indeterminism.hs ├── transient.cabal └── .travis.yml ├── transient-universe ├── ChangeLog.md ├── tests │ ├── ChangeLog.md │ ├── hasrocket1 │ │ ├── Setup.hs │ │ ├── app │ │ │ └── Main.hs │ │ ├── ChangeLog.md │ │ ├── hasrocket-benchmark-transient.cabal │ │ ├── Main.hs │ │ ├── LICENSE │ │ └── hasrocket.hs │ ├── Dockerfile │ ├── execthirdline.sh │ ├── build.sh │ ├── rundevel.sh │ ├── testtls.hs │ ├── dockerclean.sh │ ├── test22.hs │ ├── snippet │ ├── buildrun.sh │ ├── iterate.sh │ ├── test.sh │ ├── teststruct.hs │ ├── Testspark.hs │ ├── testIRC.hs │ ├── cert.pem │ ├── cardano.hs │ ├── cell.hs │ ├── streamMonad.hs │ ├── ghcjs-websockets.hs │ ├── Stream.hs │ ├── key.pem │ ├── teststreamsocket.hs │ ├── .ghc.environment.x86_64-linux-9.2.7 │ ├── nikita.hs │ ├── https.hs │ ├── testfreer.hs │ ├── .ghc.environment.x86_64-linux-9.2.5 │ ├── newmonad2.hs │ ├── execcluster.sh │ ├── testRestService.hs │ ├── chen.hs │ ├── raft.hs │ ├── hasrocket.hs │ ├── api.hs │ ├── newmonad3.hs │ ├── teststream.hs │ ├── Parameters.hs │ └── TestSuite.hs ├── app │ ├── server │ │ └── Transient │ │ │ └── Move │ │ │ └── Services │ │ │ ├── executor.hsvoid.hs │ │ │ ├── MonitorService.hsvoid.hs │ │ │ └── controlServices.hsvoid.hs │ └── client │ │ └── Transient │ │ └── Move │ │ └── Services │ │ └── void.hs ├── Setup.hs ├── universe.png ├── loop.sh ├── buildrun.sh ├── examples │ └── runweb2.sh ├── circle.yml ├── .gitignore ├── LICENSE ├── .ghc.environment.x86_64-linux-9.2.7 ├── src │ └── Transient │ │ ├── Move │ │ ├── JSON.hs │ │ ├── PubSub.hs │ │ └── WebHTML.hs │ │ └── Move.hs └── .travis.yml ├── axiom ├── wrong.html ├── axiom.png ├── Setup.lhs ├── .gitignore ├── circle.yml ├── tests │ ├── testm.hs │ ├── test.hs │ └── widgets.hs ├── LICENSE ├── axiom.cabal.nocompile └── .travis.yml ├── transient-universe-tls ├── stack.yaml ├── Setup.hs ├── tests │ ├── execthirdline.sh │ ├── certificate.csr │ ├── certificate.pem │ ├── key.pem │ ├── Test2.hs │ └── api.hs ├── .gitignore ├── README.md ├── transient-universe-tls.cabal ├── LICENSE └── .travis.yml ├── cabal.project.local ├── docs ├── image.png ├── image-2.png ├── ivory tower.md ├── The Evolution of Software Composition divulgative version.md ├── # The Evolution of Software Composition-professional.md └── The Evolution of Software Composition-professional.md ├── cabal.project ├── .devcontainer ├── Dockerfile └── devcontainer.json ├── .gitignore ├── .roo ├── rules-debug │ └── AGENTS.md ├── rules-ask │ └── AGENTS.md ├── rules-architect │ └── AGENTS.md └── rules-code │ └── AGENTS.md ├── hie.yaml ├── patents.md └── AGENTS.md /transient/ChangeLog.md: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /transient-universe/ChangeLog.md: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /transient-universe/tests/ChangeLog.md: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /axiom/wrong.html: -------------------------------------------------------------------------------- 1 | Something went wrong... -------------------------------------------------------------------------------- /transient-universe-tls/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-8.3 2 | -------------------------------------------------------------------------------- /cabal.project.local: -------------------------------------------------------------------------------- 1 | ignore-project: False 2 | profiling: True 3 | -------------------------------------------------------------------------------- /transient-universe/app/server/Transient/Move/Services/executor.hsvoid.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /transient/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /transient-universe/app/server/Transient/Move/Services/MonitorService.hsvoid.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /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/controlServices.hsvoid.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /transient-universe-tls/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /docs/image.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/transient-haskell/transient-stack/HEAD/docs/image.png -------------------------------------------------------------------------------- /transient-universe/tests/hasrocket1/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /axiom/axiom.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/transient-haskell/transient-stack/HEAD/axiom/axiom.png -------------------------------------------------------------------------------- /docs/image-2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/transient-haskell/transient-stack/HEAD/docs/image-2.png -------------------------------------------------------------------------------- /transient/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/transient-haskell/transient-stack/HEAD/transient/logo.png -------------------------------------------------------------------------------- /transient-universe/tests/Dockerfile: -------------------------------------------------------------------------------- 1 | from test 2 | CMD cd /bin && ./distributedApps -p start/localhost/8080 3 | -------------------------------------------------------------------------------- /transient-universe/tests/execthirdline.sh: -------------------------------------------------------------------------------- 1 | command=`sed -n '3p' ${1} | sed 's/-- //'` 2 | eval $command $1 $2 $3 3 | -------------------------------------------------------------------------------- /transient-universe-tls/tests/execthirdline.sh: -------------------------------------------------------------------------------- 1 | command=`sed -n '3p' ${1} | sed 's/-- //'` 2 | eval $command $1 $2 $3 3 | -------------------------------------------------------------------------------- /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/hasrocket1/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | main :: IO () 4 | main = putStrLn "Hello, Haskell!" 5 | -------------------------------------------------------------------------------- /transient-universe/universe.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/transient-haskell/transient-stack/HEAD/transient-universe/universe.png -------------------------------------------------------------------------------- /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/testtls.hs: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/transient-haskell/transient-stack/HEAD/transient-universe/tests/testtls.hs -------------------------------------------------------------------------------- /axiom/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/runhaskell 2 | > module Main where 3 | > import Distribution.Simple 4 | > main :: IO () 5 | > main = defaultMain 6 | 7 | -------------------------------------------------------------------------------- /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/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/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/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 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | -- packages: */*.cabal 2 | packages: transient/transient.cabal transient-universe/transient-universe.cabal 3 | 4 | profiling: True 5 | library-profiling: True 6 | executable-profiling: True 7 | tests: True 8 | -------------------------------------------------------------------------------- /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/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/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/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/test.sh: -------------------------------------------------------------------------------- 1 | runghc -DDEBUG -w -i../src -i../../transient/src flow.hs -p start/127.0.0.1/8001 < /dev/null > 8001.ansi 2>&1 & 2 | runghc -DDEBUG -w -i../src -i../../transient/src flow.hs -p start/127.0.0.1/8002 < /dev/null > 8002.ansi 2>&1 & 3 | runghc -DDEBUG -w -i../src -i../../transient/src flow.hs -p start/127.0.0.1/8000/add/127.0.0.1/8001/n/add/127.0.0.1/8002/n/go 2>&1 | tee 8000.ansi 4 | -------------------------------------------------------------------------------- /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-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/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/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 | -------------------------------------------------------------------------------- /docs/ivory tower.md: -------------------------------------------------------------------------------- 1 | | Tower of Pure Code | Tower to the Heavens | 2 | |------------------|-------------------| 3 | | ![buried ivory tower](image-2.png) | ![ivory tower all the way up](image.png) | 4 | | Your ivory tower of pure code, buried among pipelines connecting clients with servers and databases, microservices, users, logs, transactions and configurations | Ivory tower all the way up to the heaven, in the clouds of immutable, ethernal distributed blockchain-enabled computing | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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-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 | -------------------------------------------------------------------------------- /.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 | 24 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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-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-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/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 | -------------------------------------------------------------------------------- /.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 | *.dyn_hi 27 | *.dyn_o 28 | *.h 29 | *.cache 30 | *.lock 31 | dist* 32 | *.o 33 | *.so 34 | *.a 35 | *.hi 36 | .cabal-sandbox 37 | cabal.sanbox.config 38 | .stack* 39 | # emacs stuff 40 | *~ 41 | \#*\# 42 | /.emacs.desktop 43 | /.emacs.desktop.lock 44 | *.elc 45 | auto-save-list 46 | tramp 47 | .\#* 48 | 49 | # Org-mode 50 | .org-id-locations 51 | *_archive 52 | 53 | # flymake-mode 54 | *_flymake.* 55 | 56 | # eshell files 57 | /eshell/history 58 | /eshell/lastdir 59 | 60 | # elpa packages 61 | /elpa/ 62 | 63 | # vim stuff 64 | *.swp 65 | *.swo 66 | 67 | *.key 68 | _darcs 69 | darcs* 70 | -------------------------------------------------------------------------------- /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-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 | -------------------------------------------------------------------------------- /axiom/tests/testm.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes#-} 2 | module Main where 3 | 4 | newtype P a= P (IO a) 5 | 6 | instance Functor P 7 | instance Applicative P 8 | 9 | instance Monad P where 10 | return x= P $ return x 11 | P p >>= q= P $ do 12 | putStr "(renderp " 13 | x <- p 14 | putStr ")" 15 | putStr "(renderq " 16 | let P y = q x 17 | r <- y 18 | putStr ")" 19 | return r 20 | 21 | unP (P iox)= iox 22 | 23 | main=do 24 | let P io=do 25 | P $ putStr "11111" 26 | P $ unP $ do 27 | P (putStr "22222") 28 | P (putStr "33333") 29 | P (putStr "44444") 30 | P (putStr "44422") 31 | 32 | P $ putStr "55555" 33 | P $ putStr "66666" 34 | 35 | 36 | io 37 | 38 | putStrP x= P $ putStr x 39 | 40 | 41 | 42 | newtype Cont a = Cont { unCont:: forall r. (a->r) ->r} 43 | 44 | instance Applicative Cont 45 | 46 | instance Monad Cont where 47 | return a = Cont $ \c -> c a 48 | Cont m >>= f = m f -------------------------------------------------------------------------------- /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/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-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 | 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 < 2, cprng-aes, transient , transient-universe >= 0.6.0.0, 30 | bytestring, data-default, network, crypton-x509-store, crypton-x509-system, mtl, directory 31 | if impl(ghcjs >=0.1) 32 | build-depends: 33 | base >=4.8 34 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /.roo/rules-debug/AGENTS.md: -------------------------------------------------------------------------------- 1 | # Project Debug Rules (Non-Obvious Only) 2 | 3 | - **Debug compilation**: Must use `-f debug` flag with cabal for debug outputs 4 | - **Log analysis**: Pipe output to ANSI color files (e.g., `8000.ansi`) and use ANSI color extension 5 | - **Distributed debugging**: Monitor service runs on port 3000 by default 6 | - **Thread analysis**: Use `traceAllThreads` and `showThreads` for concurrency debugging 7 | - **State inspection**: `getLog` shows execution logs, `showLog` displays formatted logs 8 | - **Exception tracing**: `onException` handlers execute in LIFO order (reverse of definition) 9 | - **Exception debugging**: Use `continue` to test recovery paths, `forward` to test propagation 10 | - **Handler inheritance**: Verify event handlers propagate correctly to child threads 11 | - **Performance profiling**: Built-in with `-prof -fprof-auto -rtsopts -with-rtsopts=-p` 12 | - **Cross-node debugging**: Nodes communicate via WebSockets (browser) and sockets (servers) 13 | - **Recovery testing**: Use `restore1` to test state recovery from logs 14 | - **Finalization debugging**: `onFinish` handlers execute exactly once per computation branch -------------------------------------------------------------------------------- /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/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-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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /.roo/rules-ask/AGENTS.md: -------------------------------------------------------------------------------- 1 | # Project Documentation Rules (Non-Obvious Only) 2 | 3 | - **Package structure**: `transient/` contains core monad, `transient-universe/` adds distributed computing 4 | - **Cross-compilation**: Supports GHCJS for browser alongside native Haskell compilation 5 | - **Architecture**: Distributed computing via closure serialization and stack transport 6 | - **Exception system**: Sophisticated event handling with LIFO handler execution and thread inheritance 7 | - **Event types**: `onException` (errors), `onUndo` (cancellation), `onFinish` (cleanup) use same propagation 8 | - **Control primitives**: `forward` for event propagation, `continue` for exception recovery 9 | - **Web integration**: Browser nodes connect via WebSockets, compiled with GHCJS to `static/out` 10 | - **State persistence**: Execution logs enable computation recovery across sessions 11 | - **Concurrency model**: Based on continuations with implicit threading and event handling 12 | - **Testing approach**: Tests run in same directory as source, not separate test folders 13 | - **Development workflow**: Uses Docker containers with specific transient images 14 | - **API design**: REST endpoints via `api` combinator, web forms via `minput` -------------------------------------------------------------------------------- /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. -------------------------------------------------------------------------------- /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-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 | -------------------------------------------------------------------------------- /.roo/rules-architect/AGENTS.md: -------------------------------------------------------------------------------- 1 | # Project Architecture Rules (Non-Obvious Only) 2 | 3 | - **Distributed computing**: Based on closure serialization and stack transport between nodes 4 | - **State persistence**: Execution logs enable computation recovery and continuation 5 | - **Concurrency model**: Continuation-based with implicit threading and event handling 6 | - **Event system**: Unified event handling with LIFO execution and automatic thread inheritance 7 | - **Exception architecture**: `forward`/`continue` primitives provide fine-grained control over event propagation 8 | - **Resource management**: `onFinish` guarantees cleanup execution exactly once per computation branch 9 | - **Cross-platform**: Supports GHCJS for browser nodes alongside native Haskell servers 10 | - **Communication**: Browser nodes use WebSockets, server nodes use raw sockets 11 | - **Monad design**: TransIO monad handles threading, events, and distributed execution 12 | - **Package dependencies**: `transient` (core) → `transient-universe` (distributed) → `axiom` (web UI) 13 | - **Testing strategy**: Tests require multiple running nodes on different ports 14 | - **Development workflow**: Docker-based with specific transient development images 15 | - **Performance**: Built-in profiling and RTS options for concurrency analysis -------------------------------------------------------------------------------- /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/tests/cardano.hs: -------------------------------------------------------------------------------- 1 | main= keep $ initNode $ start <|> guess id 2 | 3 | start = do 4 | 5 | amount <- webpoint "enter the amount to lock" -- display the path/$d as parameter of the REST call from the type of the response 6 | -- and the path. 7 | -- also, it read it from the console if executed in console 8 | -- generates {"msg"="enter the amount to lock","url"= "https://servername/e/f/w/$d"} 9 | gameId <- local $ inChain startGame 10 | local $ inChain $ lock amount 11 | newFlow gameId -- set a game identifier 12 | guessText <- webPoint "enter guess text" -- generates{msg="enter guess text". "url"="https://servername//$d" } 13 | -- and input it from console 14 | result <- inChain $ guess guessText -- the inChain code of "guess" also pay if it is correct 15 | if result 16 | then 17 | removeFlow gameId 18 | webPoint "OK" 19 | else 20 | webPoint "FAIL" 21 | 22 | from type to input: 23 | class Input a where 24 | inputIt :: a -> TransIO a -------------------------------------------------------------------------------- /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 -- unCloud $ atRemote $ local $ do 25 | liftIO $ print "running cella at server" 26 | norender $ gcell "speed" * gcell "time" 27 | 28 | time = scell "time" $ do -- unCloud $ atRemote $ local $ do 29 | liftIO $ print "running cellb at server" 30 | norender $ gcell "space" / gcell "speed" 31 | 32 | speed = scell "speed" $ do -- unCloud $ atRemote $ local $ do 33 | liftIO $ print "running cellc at server" 34 | norender $ gcell "space" / gcell "time" 35 | 36 | 37 | 38 | 39 | 40 | -------------------------------------------------------------------------------- /.roo/rules-code/AGENTS.md: -------------------------------------------------------------------------------- 1 | # Project Coding Rules (Non-Obvious Only) 2 | 3 | - **Distributed primitives**: Always use `wormhole` for node communication, not direct socket calls 4 | - **State transport**: Use `teleport` to transport stack info between nodes, not manual serialization 5 | - **Concurrency control**: `collect` with `threads` parameter must be used for parallelism, not raw forkIO 6 | - **Exception handling**: `onException` handlers execute in LIFO order (last defined, first executed) 7 | - **Exception recovery**: Use `continue` inside handlers to stop propagation and resume normal execution 8 | - **Event control**: `forward` is the general primitive for event propagation control 9 | - **Logging pattern**: Use `logged` and `loggedc` for checkpointing, not manual logging 10 | - **State management**: Non-serializable mutable variables in stack persist across invocations 11 | - **Web integration**: Browser nodes require GHCJS compilation to `static/out` directory 12 | - **API patterns**: Use `minput` for web form inputs, not manual HTTP handling 13 | - **Testing**: Tests must be in same directory as source files for proper module resolution 14 | - **Handler inheritance**: Event handlers automatically propagate to child threads via state inheritance 15 | - **Finalization**: Use `onFinish` for guaranteed resource cleanup, not `onException` -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /.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 | } 21 | ======= 22 | { 23 | "image": "codeany/templates-base-ubuntu", 24 | "features": { 25 | "ghcr.io/devcontainers/features/common-utils:1": { 26 | "installZsh": "true", 27 | "username": "vscode", 28 | "uid": "1000", 29 | "gid": "1000", 30 | "upgradePackages": "true" 31 | } 32 | }, 33 | // Use 'forwardPorts' to make a list of ports inside the container available locally. 34 | // "forwardPorts": [], 35 | 36 | // Use 'postCreateCommand' to run commands after the container is created. 37 | // "postCreateCommand": "uname -a", 38 | 39 | // Comment out to connect as root instead. More info: https://aka.ms/vscode-remote/containers/non-root. 40 | "remoteUser": "vscode" 41 | } 42 | -------------------------------------------------------------------------------- /axiom/axiom.cabal.nocompile: -------------------------------------------------------------------------------- 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 | -------------------------------------------------------------------------------- /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-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/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/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/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/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/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/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/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 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | - path: "axiom/src" 4 | component: "lib:axiom" 5 | 6 | - path: "axiom/." 7 | component: "lib:axiom" 8 | 9 | - path: "transient/src" 10 | component: "lib:transient" 11 | 12 | - path: "transient/." 13 | component: "lib:transient" 14 | 15 | - path: "transient/tests" 16 | component: "transient:test:test-transient" 17 | 18 | - path: "transient/src" 19 | component: "transient:test:test-transient" 20 | 21 | - path: "transient/." 22 | component: "transient:test:test-transient" 23 | 24 | - path: "transient/tests/Test.hs" 25 | component: "transient:exe:Test" 26 | 27 | - path: "transient-universe/src" 28 | component: "lib:transient-universe" 29 | 30 | - path: "transient-universe/." 31 | component: "lib:transient-universe" 32 | 33 | 34 | 35 | - path: "transient-universe/app/client/Transient/Move/Services/void.hs" 36 | component: "transient-universe:exe:monitorService" 37 | 38 | - path: "transient-universe/tests/TestSuite.hs" 39 | component: "transient-universe:exe:test-transient1" 40 | 41 | - path: "transient-universe/src/TestSuite.hs" 42 | component: "transient-universe:exe:test-transient1" 43 | 44 | - path: "transient-universe/./TestSuite.hs" 45 | component: "transient-universe:exe:test-transient1" 46 | 47 | - path: "transient-universe/tests" 48 | component: "transient-universe:test:test-transient" 49 | 50 | - path: "transient-universe/src" 51 | component: "transient-universe:test:test-transient" 52 | 53 | - path: "transient-universe/." 54 | component: "transient-universe:test:test-transient" 55 | 56 | - path: "transient-universe-tls/src" 57 | component: "lib:transient-universe-tls" 58 | 59 | - path: "transient-typelevel/." 60 | component: "lib:transient-typelevel" 61 | 62 | - path: "transient-typelevel/src" 63 | component: "lib:transient-typelevel" -------------------------------------------------------------------------------- /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/.ghc.environment.x86_64-linux-9.2.7: -------------------------------------------------------------------------------- 1 | clear-package-db 2 | global-package-db 3 | package-db /root/.cabal/store/ghc-9.2.7/package.db 4 | package-id ghc-9.2.7 5 | package-id bytestring-0.11.4.0 6 | package-id unix-2.7.2.2 7 | package-id base-4.16.4.0 8 | package-id time-1.11.1.1 9 | package-id hpc-0.6.1.0 10 | package-id filepath-1.4.2.2 11 | package-id process-1.6.16.0 12 | package-id array-0.5.4.0 13 | package-id integer-gmp-1.1 14 | package-id containers-0.6.5.1 15 | package-id ghc-boot-9.2.7 16 | package-id binary-0.8.9.0 17 | package-id ghc-prim-0.8.0 18 | package-id ghci-9.2.7 19 | package-id rts 20 | package-id terminfo-0.4.1.5 21 | package-id transformers-0.5.6.2 22 | package-id deepseq-1.4.6.1 23 | package-id ghc-boot-th-9.2.7 24 | package-id pretty-1.1.3.6 25 | package-id template-haskell-2.18.0.0 26 | package-id directory-1.3.6.2 27 | package-id text-1.2.5.0 28 | package-id TCache-0.13.3-45ffa404b65b1cbf3396cee629e084bac6d3827506ff43b9cb24a6bd37924eda 29 | package-id aeson-2.2.3.0-69fe9301ca92cf03801b5db14952b7193e98058f04540e27a5eb230bd3b1b08a 30 | package-id base64-bytestring-1.2.1.0-00d76968cd139050aafa6e1f25382a11901b4d0cb123f21a24e24503a514110b 31 | package-id case-insensitive-1.2.1.0-eadc0a94d397b380de2e99e61ab53a0b6b7a530c5f78070ee06679276fa5a7ea 32 | package-id data-default-0.7.1.1-ca7076baaa7b263112ac7898d3f63749fe70c54bb970f903ef3e0f493dee4fba 33 | package-id mime-types-0.1.2.0-91bb7cf568f6dc178d0f78b1ea5eb8ed1699feb6a85fcf9c5066694e0a6c7d96 34 | package-id network-3.2.2.0-7f872ed4e8bbac2607fee42cefa150387c07456af232469b57aad762ba9d1076 35 | package-id network-uri-2.6.4.2-00d4c969c49b8638e0fe80d7b7418962c4c33ae2a11a83fab48d1d4bcc93b888 36 | package-id old-time-1.1.0.4-1b9560448693904abbb147badb9a73e948c85c880c871311ec1ad9359995bfc4 37 | package-id random-1.2.1.2-051bf230da8fa5b06df07b5793d3414793a7982b2fed6c347b13a29a2d3e3d38 38 | package-id vector-0.13.1.0-be7f5f6ad74e2b196142e330724a6a0fb0ebbf910e8b888ac53d54901c978edf 39 | package-id websockets-0.13.0.0-e5830115b93c33de9d809d061d5d7277b2d6b98bac2b7e0ec32fee766c8159ee 40 | package-id mtl-2.2.2 41 | package-id stm-2.5.0.2 42 | -------------------------------------------------------------------------------- /transient-universe/.ghc.environment.x86_64-linux-9.2.7: -------------------------------------------------------------------------------- 1 | clear-package-db 2 | global-package-db 3 | package-db /root/.cabal/store/ghc-9.2.7/package.db 4 | package-id ghc-9.2.7 5 | package-id bytestring-0.11.4.0 6 | package-id unix-2.7.2.2 7 | package-id base-4.16.4.0 8 | package-id time-1.11.1.1 9 | package-id hpc-0.6.1.0 10 | package-id filepath-1.4.2.2 11 | package-id process-1.6.16.0 12 | package-id array-0.5.4.0 13 | package-id integer-gmp-1.1 14 | package-id containers-0.6.5.1 15 | package-id ghc-boot-9.2.7 16 | package-id binary-0.8.9.0 17 | package-id ghc-prim-0.8.0 18 | package-id ghci-9.2.7 19 | package-id rts 20 | package-id terminfo-0.4.1.5 21 | package-id transformers-0.5.6.2 22 | package-id deepseq-1.4.6.1 23 | package-id ghc-boot-th-9.2.7 24 | package-id pretty-1.1.3.6 25 | package-id template-haskell-2.18.0.0 26 | package-id directory-1.3.6.2 27 | package-id text-1.2.5.0 28 | package-id data-default-0.7.1.1-fe1d9da671af21c6ac86d1124809607c4b800a3171fbaca03757611b8989412a 29 | package-id mtl-2.2.2 30 | package-id stm-2.5.0.2 31 | package-id aeson-2.2.0.0-81236a4f7fe3352d884e8ef9622e9f1dd03e200a44776b973a04d5e0dc180666 32 | package-id base64-bytestring-1.2.1.0-8ba0e450b799cffcd3e03b68e76979b49e9a226d2d1ab6353244d5e1a824d041 33 | package-id mime-types-0.1.1.0-719f6224b12c6013398b912d1957df3d4be857262db31445b5018194b5c36013 34 | package-id case-insensitive-1.2.1.0-8f6b47f093d066625e3d95bc91e1a15c5bfc200a7efc28a04b30d481eada93d6 35 | package-id network-3.1.4.0-827301738a1edd357a36c4753f2ffa326c630132219626702bc9802fe5c14756 36 | package-id TCache-0.13.3-3dff12e8025bea19018c273ea86379ddd4cf608e70c4ad9f1fa9b642aed7e6dd 37 | package-id network-uri-2.6.4.2-5b7026a242918aed9f778f74c8389e205d88c1234920c50f5563a19c7ca5365b 38 | package-id old-time-1.1.0.3-0fa2a6823a641b5bcec7f4ef002b214c7c89589be474bd23605c0f46498689c0 39 | package-id random-1.2.1.1-14950f0d57c55eed8fd0701e27e87527c3c7ef42acca95164df8337d2d526ad3 40 | package-id transient-universe-0.7.0.1-4b5c40e15ade6f53fc33cc626c0c9020d2bb6f69ad6b0653d6d816b161c33667 41 | package-id websockets-0.12.7.3-72efbd7f68bc966e1f00c499761818bc08ac4ee44778aa56effffeaa62da7d26 42 | -------------------------------------------------------------------------------- /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/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 <-unCloud $ callService getGoogleService () 40 | 41 | liftIO $ do putStr "100 chars of web page: "; print $ BS.take 100 r 42 | empty 43 | Pack packages <- unCloud $ 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/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-universe/tests/testfreer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | module Console where 7 | 8 | import Control.Monad.Freer 9 | import Control.Monad.Freer.Error 10 | import Control.Monad.Freer.State 11 | import Control.Monad.Freer.Writer 12 | import System.Exit hiding (ExitCode(ExitSuccess)) 13 | 14 | -------------------------------------------------------------------------------- 15 | -- Effect Model -- 16 | -------------------------------------------------------------------------------- 17 | data Console r where 18 | PutStrLn :: String -> Console () 19 | GetLine :: Console String 20 | ExitSuccess :: Console () 21 | 22 | putStrLn' :: Member Console effs => String -> Eff effs () 23 | putStrLn' = send . PutStrLn 24 | 25 | getLine' :: Member Console effs => Eff effs String 26 | getLine' = send GetLine 27 | 28 | exitSuccess' :: Member Console effs => Eff effs () 29 | exitSuccess' = send ExitSuccess 30 | 31 | -------------------------------------------------------------------------------- 32 | -- Effectful Interpreter -- 33 | -------------------------------------------------------------------------------- 34 | runConsole :: Eff '[Console, IO] a -> IO a 35 | runConsole = runM . interpretM (\case 36 | PutStrLn msg -> putStrLn msg 37 | GetLine -> getLine 38 | ExitSuccess -> exitSuccess) 39 | 40 | -------------------------------------------------------------------------------- 41 | -- Pure Interpreter -- 42 | -------------------------------------------------------------------------------- 43 | runConsolePure :: [String] -> Eff '[Console] w -> [String] 44 | runConsolePure inputs req = snd . fst $ 45 | run (runWriter (runState inputs (runError (reinterpret3 go req)))) 46 | where 47 | go :: Console v -> Eff '[Error (), State [String], Writer [String]] v 48 | go (PutStrLn msg) = tell [msg] 49 | go GetLine = get >>= \case 50 | [] -> error "not enough lines" 51 | (x:xs) -> put xs >> pure x 52 | go ExitSuccess = throwError () 53 | 54 | 55 | main= print $ runConsolePure ["hello"] $do 56 | r <-getLine' 57 | putStrLn' r -------------------------------------------------------------------------------- /transient-universe/tests/.ghc.environment.x86_64-linux-9.2.5: -------------------------------------------------------------------------------- 1 | clear-package-db 2 | global-package-db 3 | package-db /root/.cabal/store/ghc-9.2.5/package.db 4 | package-id ghc-9.2.5 5 | package-id bytestring-0.11.3.1 6 | package-id unix-2.7.2.2 7 | package-id base-4.16.4.0 8 | package-id time-1.11.1.1 9 | package-id hpc-0.6.1.0 10 | package-id filepath-1.4.2.2 11 | package-id process-1.6.16.0 12 | package-id array-0.5.4.0 13 | package-id integer-gmp-1.1 14 | package-id containers-0.6.5.1 15 | package-id ghc-boot-9.2.5 16 | package-id binary-0.8.9.0 17 | package-id ghc-prim-0.8.0 18 | package-id ghci-9.2.5 19 | package-id rts 20 | package-id terminfo-0.4.1.5 21 | package-id transformers-0.5.6.2 22 | package-id deepseq-1.4.6.1 23 | package-id ghc-boot-th-9.2.5 24 | package-id pretty-1.1.3.6 25 | package-id template-haskell-2.18.0.0 26 | package-id directory-1.3.6.2 27 | package-id text-1.2.5.0 28 | package-id random-1.2.1.1-885807a6bd9d41e8fc2e75d8dd80c9e20b0ba1730d05301809f964023485f9cd 29 | package-id mtl-2.2.2 30 | package-id stm-2.5.0.2 31 | package-id aeson-2.1.2.1-54ee0e16890ee2ed7837b25682ef61c99af5bd4359ac74a352630b38e79b025b 32 | package-id base64-bytestring-1.2.1.0-ddaa73d09e15bfc3382c7c5d48847e29bd125ee17cfc7e1c2448d8af5c55a637 33 | package-id data-default-0.7.1.1-2130b9f58b27fb96851f203e67fcd686c6226fb649ca900ec81fb8e250c4d669 34 | package-id mime-types-0.1.1.0-99c81908bff0f46464d12983f7496c8328d901ae0c313d082ccf053e416fbb43 35 | package-id network-3.1.2.8-249f868f4743c6e7b8cecbdda9c560e4143fb32567b647d36873976f4738e6a5 36 | package-id websockets-0.12.7.3-2a64faf5a1fb51520ffb23abeb16ebd789d16f056f8b528f7122c754f79be3a4 37 | package-id TCache-0.13.3-8511632aa3c0c9e3c04a7489ad783cbd9536be0d11f187822fd7919ce0d1d853 38 | package-id case-insensitive-1.2.1.0-18e07d3920017d67f16e6077b90eb3e8018f95d7d226a0b605194eedb5b6e7b3 39 | package-id network-uri-2.6.4.2-b7c2aa5f9118dbc2c342353a403b1ed1a052de37c7869566fa569c6329f54f08 40 | package-id old-time-1.1.0.3-77517b64016404b30f2d3f1c63c0cd841ff3a8b2f304e7375729b263228da820 41 | package-id vector-0.13.0.0-baf4f7a92b0bd408eb93eb77897c353459f79fc186f6db0c2cd88849427bcaeb 42 | package-id hashable-1.4.2.0-cd83efde5acf8903e5c98006b3dc0a9ad0c59df25dc4cfb7a8637e6a72487748 43 | package-id HTTP-4000.4.1-a81a86859bcfd39b33f17a4ff65845598ba4368e65b63e1bf07b65df2f92339b 44 | -------------------------------------------------------------------------------- /transient-universe/tests/newmonad2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE DeriveFunctor #-} 5 | {-# LANGUAGE InstanceSigs #-} 6 | 7 | import Control.Monad.State.Strict 8 | import Control.Monad.IO.Class 9 | import Control.Monad.Trans.Maybe 10 | import Control.Monad.Trans.Class 11 | import Control.Applicative 12 | import Data.Functor 13 | import Data.Monoid 14 | 15 | newtype StateTMaybeIO s a = StateTMaybeIO { runStateTMaybeIO :: s -> IO (Maybe a, s) } 16 | deriving (Functor) 17 | 18 | instance Monad (StateTMaybeIO s) where 19 | return :: a -> StateTMaybeIO s a 20 | return x = StateTMaybeIO $ \s -> return (Just x, s) 21 | 22 | (>>=) :: StateTMaybeIO s a -> (a -> StateTMaybeIO s b) -> StateTMaybeIO s b 23 | StateTMaybeIO m >>= f = StateTMaybeIO $ \s -> do 24 | (ma, s') <- m s 25 | case ma of 26 | Nothing -> return (Nothing, s') 27 | Just a -> runStateTMaybeIO (f a) s' 28 | 29 | instance Applicative (StateTMaybeIO s) where 30 | pure :: a -> StateTMaybeIO s a 31 | pure = return 32 | 33 | (<*>) :: StateTMaybeIO s (a -> b) -> StateTMaybeIO s a -> StateTMaybeIO s b 34 | StateTMaybeIO mf <*> StateTMaybeIO mx = StateTMaybeIO $ \s -> do 35 | (mf', s') <- mf s 36 | case mf' of 37 | Nothing -> return (Nothing, s') 38 | Just f -> do 39 | (mx', s'') <- mx s' 40 | return (f <$> mx', s'') 41 | 42 | instance Alternative (StateTMaybeIO s) where 43 | empty :: StateTMaybeIO s a 44 | empty = StateTMaybeIO $ \s -> return (Nothing, s) 45 | 46 | (<|>) :: StateTMaybeIO s a -> StateTMaybeIO s a -> StateTMaybeIO s a 47 | StateTMaybeIO m1 <|> StateTMaybeIO m2 = StateTMaybeIO $ \s -> do 48 | (ma, s') <- m1 s 49 | case ma of 50 | Nothing -> m2 s' 51 | Just _ -> return (ma, s') 52 | 53 | instance Monoid a => Semigroup (StateTMaybeIO s a) where 54 | (<>) :: StateTMaybeIO s a -> StateTMaybeIO s a -> StateTMaybeIO s a 55 | StateTMaybeIO m1 <> StateTMaybeIO m2 = StateTMaybeIO $ \s -> do 56 | (ma1, s1) <- m1 s 57 | (ma2, s2) <- m2 s1 58 | return (mappend <$> ma1 <*> ma2, s2) 59 | 60 | instance Monoid a => Monoid (StateTMaybeIO s a) where 61 | mempty :: StateTMaybeIO s a 62 | mempty = StateTMaybeIO $ \s -> return (Just mempty, s) 63 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /patents.md: -------------------------------------------------------------------------------- 1 | I want to summarize the things that I consider unique in transient 2 | With full composability I mean the availiability of two binary operator such that 3 | 4 | ```haskell 5 | <|> :: m x -> m x -> m x 6 | <*> :: m (y -> x) -> m y -> m x 7 | ``` 8 | 9 | The composition of two elements produce a third element with the same signature where `m` is the monad and x is the type of the result. 10 | - full composability of threaded routines. where the operands run in different threads 11 | - The two operators introduce two ways: the <|> introduce parallel execution. <*> introduce concurrency 12 | - The <*> concurrent operator allows the use of concurrency in any other conventional operator. 13 | - For example addition: `(+) x y = (+) <$> x <*> y` so that in the formula a + b + c the three terms will be computed in parallel and the result will be computed concurrently. 14 | Both operators <*> <|> can be combined to create arbitrary parallel and concurrent combinations. 15 | 16 | The expression can become conventionally serial when the number of threads or a special flag is set. Also the parallelism can be controlled among the two limits of fully parallel and fully serial. Sometimes, for example, parsing need strict serial execution. In other cases excessive parallelization of trivial tasks could increase memory footprint and reduce performance instead of increasing it. 17 | 18 | 19 | - How to serialize and deserialize the execution state necessary to respond to an event or network request 20 | - How to move computations back and forth between different computers 21 | - distributing computations between different computers, in a fully composable way 22 | r <- (a+b)* c -- where a b and c run in different computers 23 | 24 | - streaming as a default effect ever available, not as a distinct set of primitives 25 | r <- (a+b) *c -- where a, b and c generate streams of values 26 | 27 | - De-inversion of callbcks to make them composable 28 | r <- (react onCallback + b) * c 29 | 30 | - Fully composing multi-threaded code 31 | r <- (a+b)* c -- where a b and c run in different threads 32 | 33 | - homoiconic code in browser and server 34 | 35 | - web widgets fully composable 36 | r <- (a+ b)* c -- where a, b and c are widgets activated by browser events 37 | 38 | -------------------------------------------------------------------------------- /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 | import Control.Applicative 9 | import Control.Concurrent 10 | import Control.Exception.Base 11 | import Control.Monad.State 12 | import Control.Monad 13 | import Data.List 14 | import Data.Monoid 15 | import System.Exit 16 | import System.Random 17 | import Transient.Base 18 | import Transient.EVars 19 | import Transient.Indeterminism 20 | import Transient.Console 21 | import Prelude hiding (return, (>>), (>>=)) 22 | import qualified Prelude as Pr (return) 23 | 24 | 25 | 26 | main = do 27 | void $ keep $ do 28 | let -- genElem :: a -> TransIO a 29 | genElem x = do 30 | -- generates synchronous and asynchronous results with various delays 31 | isasync <- return True -- liftIO randomIO 32 | delay <- return 500 -- liftIO $ randomRIO (1, 1000) 33 | liftIO $ threadDelay delay 34 | if isasync then async $ return x else return x 35 | 36 | liftIO $ putStrLn "--Testing thread control + Monoid + Applicative + async + indetermism---" 37 | 38 | void $ collect 0 $ do 39 | -- gather the result of 100 iterations 40 | i <- threads 0 $ choose [1 .. 100] -- test 100 times. 'loop' for 100 times 41 | nelems <- return 100-- liftIO $ randomRIO (1, 100) -- :: TransIO Int 42 | nthreads <- return 50 -- liftIO $ randomRIO (0, nelems) -- different numbers of threads 43 | r <- threads nthreads $ sum $ map genElem [1 .. nelems] -- sum sync and async results using applicative 44 | let result = sum [1 .. nelems] 45 | assert (r == result) $ return () 46 | 47 | liftIO $ putStrLn "--------------checking parallel execution, Alternative, events, collect --------" 48 | ev <- newEVar 49 | r <- collect 300 $ readEVar ev <|> ((choose [1 .. 300] >>= writeEVar ev) >> stop) 50 | assert (sort r == [1 .. 300]) $ return () 51 | 52 | liftIO $ print "SUCCESS" 53 | exit () 54 | 55 | exitSuccess 56 | 57 | -------------------------------------------------------------------------------- /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, finish 58 | ) where 59 | 60 | import Transient.Internals 61 | 62 | 63 | -- Code moved to Internals in order to manage exceptions in spawned threads. 64 | -------------------------------------------------------------------------------- /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' . unCloud $ 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/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/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/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 . unCloud 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 | $ unCloud $ 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 $ unCloud $ 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/src/Transient/Move/JSON.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE OverlappingInstances #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | {-# LANGUAGE CPP, LambdaCase #-} 10 | 11 | module Transient.Move.JSON where 12 | 13 | import Transient.Internals 14 | import Transient.Loggable 15 | import Transient.Parse 16 | import Data.Aeson 17 | import Data.Maybe 18 | import Data.ByteString.Builder 19 | import qualified Data.ByteString.Char8 as BC 20 | import qualified Data.ByteString.Lazy as BL 21 | import qualified Data.ByteString.Lazy.Char8 as BS 22 | 23 | import Control.Monad.State 24 | import Control.Applicative 25 | 26 | import Data.Typeable 27 | 28 | serializeToJSON :: ToJSON a => a -> Builder 29 | serializeToJSON = lazyByteString . encode 30 | 31 | deserializeJSON :: FromJSON a => TransIO a 32 | deserializeJSON = do 33 | modify $ \s -> s{execMode=Serial} 34 | -- tr ("BEFOFE DECODE") 35 | s <- jsElem 36 | tr ("decode", s) 37 | 38 | case eitherDecode s of 39 | Right x -> return x 40 | Left err -> empty 41 | 42 | jsElem :: TransIO BS.ByteString -- just delimites the json string, do not parse it 43 | jsElem = dropSpaces >> ( jsonObject <|> array <|> atom) 44 | where 45 | atom = elemString 46 | 47 | array = try emptyList <|> (brackets $ return "[" <> jsElem <> ( chainMany mappend (comma <>jsElem)) ) <> return "]" 48 | 49 | emptyList= string "[" <> (dropSpaces >> string "]") 50 | 51 | jsonObject = try emptyObject <|> (braces $ return "{" <> field <> (chainMany mappend (comma <> field)) ) <> return "}" 52 | 53 | emptyObject= string "{" <> (dropSpaces >> string "}") 54 | 55 | field = 56 | dropSpaces >> string "\"" <> tTakeWhile (/= '\"') <> string "\"" 57 | <> (dropSpaces >> string ":" <> (dropSpaces >> jsElem)) 58 | 59 | elemString = do 60 | dropSpaces 61 | (string "\"" <> tTakeWhile ( /= '\"' ) <> string "\"" ) <|> 62 | tTakeWhile (\c -> c /= '}' && c /= ']' && c /= ',' && c /= '/' && c /= ' ') 63 | 64 | instance {-# OVERLAPPING #-} Loggable Value where 65 | serialize = serializeToJSON 66 | deserialize = deserializeJSON 67 | 68 | 69 | 70 | instance {-# OVERLAPPABLE #-} ToJSON a => Show a where 71 | show = BS.unpack . toLazyByteString . serializeToJSON . toJSON 72 | 73 | instance FromJSON a => Read a where 74 | readsPrec _ ss = error "Read FromJSON: not implemented" 75 | -- let (s,rest)= fragment $ BS.pack ss 76 | -- mr = decode s 77 | -- in if isJust mr then [(fromJust mr, BS.unpack rest)] else [] 78 | 79 | instance {-# OVERLAPPABLE #-} (Typeable a, ToJSON a, FromJSON a) => Loggable (AsJSON a) where 80 | serialize (AsJSON a)= serializeToJSON a 81 | deserialize = AsJSON <$> deserializeJSON 82 | 83 | newtype AsJSON a= AsJSON a 84 | 85 | 86 | -- | to force JSON deserialization 87 | instance FromJSON a => FromJSON (AsJSON a) where 88 | parseJSON val= AsJSON <$> parseJSON val 89 | 90 | instance ToJSON a => ToJSON (AsJSON a) where 91 | toJSON (AsJSON x)= toJSON x -------------------------------------------------------------------------------- /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/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 | -------------------------------------------------------------------------------- /AGENTS.md: -------------------------------------------------------------------------------- 1 | # AGENTS.md 2 | 3 | This file provides guidance to agents when working with code in this repository. 4 | 5 | ## Build/Test Commands (Non-Obvious) 6 | 7 | - **Debug compilation**: `cabal install -f debug test-transient1 --overwrite-policy=always` 8 | - **Run monitor in debug mode**: `runghc -w -threaded -rtsopts -i../src -i../../transient/src ../app/server/Transient/Move/Services/MonitorService.hs -p start/localhost/3000` 9 | - **Run test suite in debug mode**: `runghc -DDEBUG -w -threaded -rtsopts -i../src -i../../transient/src TestSuite.hs` 10 | - **Run examples**: `runghc -DDEBUG -w -threaded -rtsopts -i../src -i../../transient/src flow.hs -p g 2>&1 | tee 8000.ansi` 11 | - **Compile examples**: `ghc -DDEBUG -w -threaded -rtsopts -i../src -i../../transient/src flow.hs 2>&1 | tee 8000.ansi` 12 | 13 | ## Code Style & Architecture (Non-Obvious) 14 | 15 | - **Distributed computing patterns**: Use `wormhole` for node communication, `teleport` for stack transport 16 | - **State management**: Non-serializable mutable variables in stack are kept across successive invocations 17 | - **Exception handling**: `onException` handlers execute in LIFO order (last defined, first executed) 18 | - **Exception recovery**: Use `continue` to stop propagation and resume normal execution after handler 19 | - **Event propagation**: `forward` is the general primitive for event control, `continue` is `forward` for exceptions 20 | - **Concurrency patterns**: `collect` with `threads` parameter controls parallelism level 21 | - **Logging system**: Uses custom logging with `logged` and `loggedc` for checkpointing and recovery 22 | - **Handler inheritance**: Event handlers (`onException`, `onUndo`, `onFinish`) are inherited by child threads 23 | - **Finalization**: `onFinish` handlers execute exactly once when entire computation branch finishes 24 | 25 | ## Project Structure (Non-Obvious) 26 | 27 | - **Main packages**: `transient` (core), `transient-universe` (distributed), `transient-universe-tls` (secure comms), `axiom` (web UI) 28 | - **Test organization**: Tests are in same directory as source files, not separate test folders 29 | - **Cross-compilation**: Supports GHCJS for browser execution alongside native compilation 30 | - **Dependency resolution**: Use `cabal install --lib --package-env . ` when libraries not found 31 | 32 | ## Testing Patterns (Non-Obvious) 33 | 34 | - **Single test execution**: Use `runghc` with specific include paths rather than cabal test 35 | - **Distributed testing**: Tests require multiple nodes running on different ports 36 | - **Debug output**: Use `-DDEBUG` flag and pipe to ANSI color files for log analysis 37 | - **Performance profiling**: Built-in profiling with `-prof -fprof-auto -rtsopts` 38 | 39 | ## Critical Gotchas 40 | 41 | - **File encoding**: Use `sed -i 's/\r//g' file` if encountering "No such file or directory" errors 42 | - **Docker development**: Many scripts assume Docker environment with specific image 43 | - **WebSocket connections**: Browser nodes use WebSockets, server nodes use sockets 44 | - **State recovery**: Execution logs are serialized and can restore computation state 45 | - **Handler ordering**: `onException` handlers execute in reverse order of definition (LIFO stack) 46 | - **Thread safety**: Event handlers propagate to child threads automatically via state inheritance 47 | - **Resource cleanup**: Use `onFinish` for guaranteed cleanup, not `onException` for resource management 48 | - **Exception control**: `continue` resumes execution AFTER the handler scope, not at the failure point -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /docs/The Evolution of Software Composition divulgative version.md: -------------------------------------------------------------------------------- 1 | # Evolution of Composition 2 | 3 | ## Grand Unification Timeline 4 | 5 | CPU Machine Code Era: 6 | - Technology: CPUs, Interrupts, High level languages (FORTRAN) 7 | - Result: Batch processing, direct execution of formulas (pure numeric algebra) 8 | 9 | Memory Access Era: 10 | - Technology: DMA, OS with synchronous IO blocking (Linux) 11 | - Result: Interactive console apps, algebraic composition with I/O blocking, single threading 12 | 13 | ### The OOP Composition Ice Age 14 | 15 | - Technology: Disk I/O, Mouse, Communication Systems 16 | - Approach: Object-Oriented Programming (message-based), epoll, event loops 17 | - Result: Complex spaghetti code without algebraic composition 18 | 19 | ### The Small Global Warming 20 | 21 | - Technology: Threading, Parallelism, Concurrency 22 | - Approach: Semaphores, critical sections, async/await patterns 23 | - Result: Imperative programming with blocking operations; algebraic composition absent; synchronous and asynchronous modes remain separate 24 | 25 | ### Back to the Ice Age 26 | 27 | - Technology: Web Development 28 | - Approach: Web servers, routing systems, contexts, event loops 29 | - Result: Manual state management with no compositional benefits 30 | 31 | ### The Paradise Lost 32 | 33 | Continuations could have solved the composition problems but were abandoned due to: 34 | - Large execution states 35 | - OOP dominance 36 | - Disconnection of academia from real world programming needs 37 | - Lack of global vision (get things done) 38 | - Search for substitutes: 39 | - Modularity 40 | - Encapsulation 41 | - Separation of concerns 42 | - Partial solutions: async/await 43 | - False dichotomies: block programming versus microservices 44 | 45 | ### Modern Distributed Era 46 | 47 | - Technology: Distributed Computing 48 | - Approach: Actor model, agent programming (OOP with other names) 49 | - Result: No advancement in composition, artisanal programming 50 | 51 | - Technology: Client-side Programming 52 | - Approach: Message passing, web services, JSON, callbacks 53 | - Result: No imperative composition, explicit state management 54 | 55 | - Technology: Multiuser Workflows (Blockchain contracts) 56 | - Approach: Same solutions 57 | - Result: Similar limitations 58 | 59 | ## The New Grand Unification: Transient 60 | 61 | **Core Principle:** Everything should compose with anything 62 | 63 | Key Concepts: 64 | - New threads can execute continuations 65 | - "async x" is a thread that executes the same continuation with a different result x 66 | - Parallelism represents alternatives with different threads 67 | - Streaming is composition of parallel applicatives 68 | - Implicit concurrency is programmed within applicatives 69 | - Concurrency consists of applicatives of different threads 70 | - Formulas/binary operators can be constructed with applicatives 71 | - Execution states can be transported as logs and restored 72 | - Callbacks are continuations 73 | - Streaming is a composition of alternatives 74 | 75 | ### Implementation Details: 76 | - Requests/responses send/receive stack states to build execution stacks of communicating machines upon previous states 77 | - Web routes are stacks 78 | - Execution logs are serializations of stack 79 | - Intermediate results can be removed from logs when not in scope 80 | - GET Web requests are logs 81 | - Messages/web/distributed requests can transport stacks as logs 82 | - Messages can address previous restored stacks to construct distributed computing state among different machines 83 | - Stacks serialize as logs 84 | - Deserialize to restore any execution state upon previous states 85 | 86 | 87 | - synchronous AND asynchronous: Horizontally asyncronous, vertically syncronouys 88 | 89 | ```haskell 90 | do 91 | this <- async(is) + asynchronous 92 | async(is) 93 | sinchronous 94 | ``` -------------------------------------------------------------------------------- /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(..), 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 | 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, logged,loggedc, localIO, 70 | 71 | -- * Moving Computations 72 | wormhole, teleport, 73 | 74 | -- * Running at a Remote Node 75 | beamTo, forkTo,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 | import Transient.Move.Defs 97 | import Transient.Move.Internals 98 | import Transient.Move.Logged 99 | import Transient.Mailboxes 100 | 101 | -------------------------------------------------------------------------------- /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, for, collect, collect', group, groupByTime, burst 17 | ) where 18 | 19 | import Transient.Internals 20 | 21 | import Data.IORef 22 | import Control.Applicative 23 | import Data.Monoid 24 | import Data.Maybe 25 | import Control.Concurrent 26 | import Control.Monad.State 27 | -- import Control.Exception hiding (onException) 28 | -- import qualified Data.ByteString.Char8 as BS 29 | 30 | -- import System.IO.Unsafe 31 | 32 | -- | inject a stream of values in the computation in as much threads as are available. You can use the 33 | -- 'threads' primitive to control the parallelism. 34 | -- 35 | -- unlike normal loops, two or more choose primitives or expressions that use choose can be composed algebraically 36 | choose :: [a] -> TransIO a 37 | choose = foldr ((<|>) . async . return) empty 38 | 39 | -- -- | inject a stream of SMore values in the computation in as much threads as are available. transmit the end of stream witha SLast value 40 | -- chooseStream :: [a] -> TransIO (StreamData a) 41 | -- chooseStream []= empty 42 | -- chooseStream xs = do 43 | -- evs <- liftIO $ newIORef xs 44 | -- parallel $ do 45 | -- es <- atomicModifyIORef evs $ \es -> let tes= tail es in (tes,es) 46 | -- case es of 47 | -- [] -> return SDone 48 | -- x:_ -> x `seq` return $ SMore x 49 | 50 | 51 | -- -- | Same as 'choose', but slower and more parallized in some cases 52 | 53 | -- 54 | 55 | 56 | 57 | 58 | 59 | -- | Collect the results in groups of @n@ elements. 60 | -- 61 | group :: Int -> TransIO a -> TransIO [a] 62 | group num proc = do 63 | v <- liftIO $ newIORef (0,[]) 64 | x <- proc 65 | 66 | mn <- liftIO $ atomicModifyIORef v $ \(n,xs) -> 67 | let n'=n +1 68 | in if n'== num 69 | 70 | then ((0,[]), Just $ x:xs) 71 | else ((n', x:xs),Nothing) 72 | maybe stop return mn 73 | 74 | 75 | -- | Collect the first @n@ results. if n==0 it collects all the results until there are no 76 | -- active threads within the argument. When n/=0, when the desired number of results are reached it 77 | -- kills all the remaining non-free threads before returning the results. 78 | -- 79 | collect :: Int -> TransIO a -> TransIO [a] 80 | collect n = collect' n 0 81 | 82 | 83 | -- | insert `SDone` response every time there is a timeout since the last response 84 | 85 | burst :: Int -> TransIO a -> TransIO (StreamData a) 86 | burst timeout comp= do 87 | r <- oneThread comp 88 | return (SMore r) <|> (async (threadDelay timeout) >> return SDone) 89 | 90 | -- | Collect the results of a task set, grouping all results received within 91 | -- every time interval specified by the first parameter as `diffUTCTime`. 92 | groupByTime :: Monoid a => Int -> TransIO a -> TransIO a 93 | groupByTime timeout comp= do 94 | v <- liftIO $ newIORef mempty 95 | gather v <|> run v 96 | where 97 | run v = do 98 | x <- comp 99 | liftIO $ atomicModifyIORef v $ \xs -> (xs <> x,()) 100 | empty 101 | 102 | gather v= do 103 | waitEvents $ do 104 | threadDelay timeout 105 | atomicModifyIORef v $ \xs -> (mempty , xs) 106 | 107 | 108 | -------------------------------------------------------------------------------- /docs/# The Evolution of Software Composition-professional.md: -------------------------------------------------------------------------------- 1 | # The Evolution of Software Composition 2 | 3 | ## Historical Timeline of Computing Paradigms 4 | 5 | | Era | Innovation | Impact | 6 | |-----|------------|--------| 7 | | Machine Code Era | Introduction of microprocessors, interrupts, and high-level languages (FORTRAN) | Enabled batch processing and direct formula execution through pure numerical algebra | 8 | | Memory Management Era | Introduction of DMA and synchronous I/O blocking in operating systems | Facilitated interactive console applications with algebraic composition, albeit limited to single-threaded execution | 9 | 10 | ### The Object-Oriented Programming Era 11 | 12 | | Technology | Methodology | Outcome | 13 | |------------|------------|---------| 14 | | Modern I/O Systems (Disk, GUI, Network) | Object-oriented programming with message-based architecture and event loops | Resulted in complex codebases with limited algebraic composition capabilities | 15 | 16 | ### The Concurrent Programming Era 17 | 18 | | Technology | Methodology | Outcome | 19 | |------------|------------|---------| 20 | | Multi-threaded Systems | Implementation of semaphores, critical sections, and asynchronous operations | Achieved imperative execution with blocking operations, but failed to unify synchronous and asynchronous paradigms | 21 | 22 | ### The Web Development Era 23 | 24 | | Technology | Methodology | Outcome | 25 | |------------|------------|---------| 26 | | Web Technologies | Implementation of server routing, contexts, and event loops | Required explicit state management without proper composition patterns | 27 | 28 | ### The Missed Opportunity: Continuations 29 | 30 | The potential of continuations as a unifying concept was overlooked due to several factors: 31 | - Complex execution state management 32 | - Prevalence of object-oriented programming 33 | - Disconnect between academic research and industry requirements 34 | - Focus on immediate solutions rather than architectural vision 35 | - Emergence of alternative paradigms: 36 | - Modular programming 37 | - Information hiding 38 | - Separation of concerns 39 | - Limited solutions such as async/await 40 | - Artificial divisions between monolithic and microservice architectures 41 | 42 | ### The Modern Distributed Computing Era 43 | 44 | | Technology | Methodology | Outcome | 45 | |------------|------------|---------| 46 | | Distributed Systems | Actor model and agent-based programming | Limited advancement in composition patterns, resulting in bespoke solutions | 47 | | Frontend Development | Event-driven architecture with web services and callbacks | Lacks imperative composition with explicit state management requirements | 48 | | Blockchain Applications | Similar architectural patterns | Inherits comparable limitations | 49 | 50 | ## The Transient Framework: A New Unified Approach 51 | 52 | **Fundamental Principle:** Universal composability across all programming concepts 53 | 54 | Core Features: 55 | - Continuation-based thread execution 56 | - Asynchronous operations as continuation-based thread executions 57 | - Thread-based parallel execution paths 58 | - Stream processing through parallel applicative composition 59 | - Native support for implicit concurrency within applicatives 60 | - Multi-threaded applicative composition 61 | - Algebraic operations through applicative construction 62 | - Portable execution state through logging mechanisms 63 | - Continuation-based callback handling 64 | - Non-deterministic parallel stream processing 65 | 66 | ### Technical Implementation: 67 | - Stack state propagation through request/response cycles 68 | - Route management through stack-based architecture 69 | - Stack serialization via execution logging 70 | - Optimized log management with scope-based pruning 71 | - HTTP GET requests as serialized execution logs 72 | - Cross-system state propagation via log transportation 73 | - Distributed state management through stack restoration 74 | - Bidirectional stack serialization 75 | - Universal state reconstruction capabilities -------------------------------------------------------------------------------- /docs/The Evolution of Software Composition-professional.md: -------------------------------------------------------------------------------- 1 | # The Evolution of Software Composition 2 | 3 | ## Historical Timeline of Computing Paradigms 4 | 5 | | Era | Innovation | Impact | 6 | |-----|------------|--------| 7 | | Machine Code Era | Introduction of microprocessors, interrupts, and high-level languages (FORTRAN) | Enabled batch processing and direct formula execution through pure numerical algebra | 8 | | Memory Management Era | Introduction of DMA and synchronous I/O blocking in operating systems | Facilitated interactive console applications with algebraic composition, albeit limited to single-threaded execution | 9 | 10 | ### The Object-Oriented Programming Era 11 | 12 | | Technology | Methodology | Outcome | 13 | |------------|------------|---------| 14 | | Modern I/O Systems (Disk, GUI, Network) | Object-oriented programming with message-based architecture and event loops | Resulted in complex codebases with limited algebraic composition capabilities | 15 | 16 | ### The Concurrent Programming Era 17 | 18 | | Technology | Methodology | Outcome | 19 | |------------|------------|---------| 20 | | Multi-threaded Systems | Implementation of semaphores, critical sections, and asynchronous operations | Achieved imperative execution with blocking operations, but failed to unify synchronous and asynchronous paradigms | 21 | 22 | ### The Web Development Era 23 | 24 | | Technology | Methodology | Outcome | 25 | |------------|------------|---------| 26 | | Web Technologies | Implementation of server routing, contexts, and event loops | Required explicit state management without proper composition patterns | 27 | 28 | ### The Missed Opportunity: Continuations 29 | 30 | The potential of continuations as a unifying concept was overlooked due to several factors: 31 | - Complex execution state management 32 | - Prevalence of object-oriented programming 33 | - Disconnect between academic research and industry requirements 34 | - Focus on immediate solutions rather than architectural vision 35 | - Emergence of alternative paradigms: 36 | - Modular programming 37 | - Information hiding 38 | - Separation of concerns 39 | - Limited solutions such as async/await 40 | - Artificial divisions between monolithic and microservice architectures 41 | 42 | ### The Modern Distributed Computing Era 43 | 44 | | Technology | Methodology | Outcome | 45 | |------------|------------|---------| 46 | | Distributed Systems | Actor model and agent-based programming | Limited advancement in composition patterns, resulting in bespoke solutions | 47 | | Frontend Development | Event-driven architecture with web services and callbacks | Lacks imperative composition with explicit state management requirements | 48 | | Blockchain Applications | Similar architectural patterns | Inherits comparable limitations | 49 | 50 | ## The Transient Framework: A New Unified Approach 51 | 52 | **Fundamental Principle:** Universal composability across all programming concepts 53 | 54 | Core Features: 55 | - Continuation-based thread execution 56 | - Asynchronous operations as continuation-based thread executions 57 | - Thread-based parallel execution paths 58 | - Stream processing through parallel applicative composition 59 | - Native support for implicit concurrency within applicatives 60 | - Multi-threaded applicative composition 61 | - Algebraic operations through applicative construction 62 | - Portable execution state through logging mechanisms 63 | - Continuation-based callback handling 64 | - Non-deterministic parallel stream processing 65 | 66 | ### Technical Implementation: 67 | - Stack state propagation through request/response cycles 68 | - Route management through stack-based architecture 69 | - Stack serialization via execution logging 70 | - Optimized log management with scope-based pruning 71 | - HTTP GET requests as serialized execution logs 72 | - Cross-system state propagation via log transportation 73 | - Distributed state management through stack restoration 74 | - Bidirectional stack serialization 75 | - Universal state reconstruction capabilities -------------------------------------------------------------------------------- /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 | atEnd = tbracket 97 | 98 | useResources rs= collect 2 rs -- <|> liftIO (forever (threadDelay maxBound) ) 99 | 100 | main2= keep $ job1 101 | 102 | job1= do 103 | onException $ \(e :: SomeException) -> do 104 | th <- liftIO myThreadId 105 | liftIO $ print ("JOB", e,th) 106 | empty 107 | r <- tbracket adquire release 108 | --labelState "JOB" 109 | w <- useResources $ do 110 | i <- choose[1,2] 111 | liftIO $ print "after adquire, managing resource" 112 | return $ r ++ " processed " ++ show i 113 | 114 | liftIO $ print w 115 | where 116 | adquire = do 117 | print "adquire" 118 | return "Resource" 119 | release _ = print "release" 120 | 121 | 122 | main= keep $ do 123 | setParseString "{\"username\":\"xyz\",\"password\":\"xyz\"}" 124 | r <- param 125 | liftIO $ print ("value=",r :: Value) 126 | where 127 | string= do 128 | d <- isDone 129 | if d then empty !> "empty" else tTakeWhile (\c -> c /= '}' && c /= ']' ) 130 | 131 | 132 | 133 | -------------------------------------------------------------------------------- /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-universe/tests/newmonad3.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE DeriveFunctor #-} 5 | {-# LANGUAGE InstanceSigs #-} 6 | 7 | import Control.Monad.State.Strict 8 | import Control.Monad.IO.Class 9 | import Control.Monad.Trans.Maybe 10 | import Control.Monad.Trans.Class 11 | import Control.Applicative 12 | import Data.Functor 13 | import Data.Monoid 14 | import Data.Dynamic 15 | 16 | data StreamData a = 17 | SMore a -- ^ More to come Just sin finalización 18 | | SLast a -- ^ This is the last one Just con finalizacion 19 | | SDone -- ^ No more, we are done Nothing 20 | | SBacktrack Dynamic -- ^ error/backtrack BackTracking 21 | deriving (Typeable, Show) 22 | 23 | instance Functor StreamData where 24 | fmap f (SMore a)= SMore (f a) 25 | fmap f (SLast a)= SLast (f a) 26 | fmap _ SDone= SDone 27 | fmap _ (SBacktrack e)= SBacktrack e 28 | 29 | instance Monad StreamData where 30 | return = SLast 31 | SMore a >>= f= f a 32 | SLast a >>= f= f a 33 | SDone >>= _= SDone 34 | SBacktrack e >>= _= SBacktrack e 35 | 36 | instance Applicative StreamData where 37 | pure = SLast 38 | SMore f <*> SMore a= SMore (f a) 39 | SMore f <*> SLast a= SLast (f a) 40 | SLast f <*> SMore a= SLast (f a) 41 | SLast f <*> SLast a= SLast (f a) 42 | SDone <*> _= SDone 43 | _ <*> SDone= SDone 44 | SBacktrack e <*> _= SBacktrack e 45 | _ <*> SBacktrack e= SBacktrack e 46 | 47 | instance Semigroup a => Semigroup (StreamData a) where 48 | SMore a <> SMore b = SMore (a <> b) 49 | SMore a <> SLast b = SMore (a <> b) 50 | SLast a <> SMore b = SMore (a <> b) 51 | SLast a <> SLast b = SLast (a <> b) 52 | SDone <> _ = SDone 53 | _ <> SDone = SDone 54 | SBacktrack e <> _ = SBacktrack e 55 | _ <> SBacktrack e = SBacktrack e 56 | 57 | newtype EventF= EventF Int 58 | 59 | newtype TransIO a = TransIO { runTrans :: EventF -> IO (StreamData a, EventF) } 60 | deriving (Functor) 61 | 62 | instance Applicative TransIO where 63 | pure x = TransIO $ \s -> return (SLast x, s) 64 | TransIO f <*> TransIO x = TransIO $ \s -> do 65 | (f', s') <- f s 66 | case f' of 67 | SMore g -> do 68 | (x', s'') <- x s' 69 | case x' of 70 | SMore a -> return (SMore (g a), s'') 71 | SLast a -> return (SLast (g a), s'') 72 | SDone -> return (SDone, s'') 73 | SBacktrack e -> return (SBacktrack e, s'') 74 | SLast g -> do 75 | (x', s'') <- x s' 76 | case x' of 77 | SMore a -> return (SMore (g a), s'') 78 | SLast a -> return (SLast (g a), s'') 79 | SDone -> return (SDone, s'') 80 | SBacktrack e -> return (SBacktrack e, s'') 81 | SDone -> return (SDone, s') 82 | SBacktrack e -> return (SBacktrack e, s') 83 | 84 | instance Monad TransIO where 85 | return = pure 86 | TransIO x >>= f = TransIO $ \s -> do 87 | (x', s') <- x s 88 | case x' of 89 | SMore a -> runTrans (f a) s' 90 | SLast a -> runTrans (f a) s' 91 | SDone -> return (SDone, s') 92 | SBacktrack e -> return (SBacktrack e, s') 93 | 94 | instance MonadState EventF TransIO where 95 | get = TransIO $ \s -> return (SLast s, s) 96 | put s = TransIO $ \_ -> return (SLast (), s) 97 | 98 | instance MonadIO TransIO where 99 | liftIO io = TransIO $ \s -> do 100 | a <- io 101 | return (SLast a, s) 102 | 103 | instance Alternative TransIO where 104 | empty = TransIO $ \_ -> return (SDone, undefined) 105 | TransIO x <|> TransIO y = TransIO $ \s -> do 106 | (x', s') <- x s 107 | case x' of 108 | SDone -> y s 109 | _ -> return (x', s') 110 | 111 | instance Semigroup a => Semigroup (TransIO a) where 112 | TransIO x <> TransIO y = TransIO $ \s -> do 113 | (x', s') <- x s 114 | (y', s'') <- y s' 115 | return (x' <> y', s'') 116 | 117 | instance Monoid a => Monoid (TransIO a) where 118 | mempty = pure mempty 119 | mappend = (<>) 120 | -------------------------------------------------------------------------------- /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/transient.cabal: -------------------------------------------------------------------------------- 1 | name: transient 2 | version: 0.9.0.2 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 | 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 | , vector 43 | , TCache 44 | , signal 45 | 46 | 47 | exposed-modules: Transient.Backtrack 48 | Transient.Base 49 | Transient.EVars 50 | Transient.Mailboxes 51 | Transient.Indeterminism 52 | Transient.Internals 53 | Transient.Parse 54 | Transient.Console 55 | Transient.Loggable 56 | 57 | 58 | 59 | exposed: True 60 | buildable: True 61 | default-language: Haskell2010 62 | hs-source-dirs: src . 63 | ghc-options: -O0 64 | cpp-options: 65 | 66 | if flag(debug) 67 | cpp-options: -DDEBUG 68 | 69 | source-repository head 70 | type: git 71 | location: https://github.com/agocorona/transient-stack/transient 72 | 73 | test-suite test-transient 74 | 75 | if !impl(ghcjs >=0.1) 76 | build-depends: 77 | base >= 4.8.1 && < 5 78 | , containers >= 0.5.6 79 | , transformers >= 0.4.2 80 | , time >= 1.5 81 | , directory >= 1.2.2 82 | , bytestring >= 0.10.6 83 | 84 | -- libraries not bundled w/ GHC 85 | , transient == 0.9.0.2 86 | , mtl 87 | , stm 88 | , random 89 | , vector 90 | , TCache 91 | , signal 92 | 93 | 94 | 95 | type: exitcode-stdio-1.0 96 | main-is: TestSuite.hs 97 | build-depends: 98 | base >4 99 | default-language: Haskell2010 100 | hs-source-dirs: tests src . 101 | ghc-options: -O0 102 | 103 | executable test-transient1 104 | 105 | if !impl(ghcjs >=0.1) 106 | build-depends: 107 | base >= 4.8.1 && < 5 108 | , containers >= 0.5.6 109 | , transformers >= 0.4.2 110 | , time >= 1.5 111 | , directory >= 1.2.2 112 | , bytestring >= 0.10.6 113 | 114 | -- libraries not bundled w/ GHC 115 | , transient 116 | , mtl 117 | , stm 118 | , random 119 | , vector 120 | , TCache 121 | , signal 122 | 123 | 124 | 125 | main-is: TestSuite.hs 126 | build-depends: 127 | base >4 128 | default-language: Haskell2010 129 | hs-source-dirs: tests src . 130 | ghc-options: -prof -fprof-auto -rtsopts -with-rtsopts=-p -------------------------------------------------------------------------------- /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 | -} -------------------------------------------------------------------------------- /axiom/tests/widgets.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 --make -i${LIB}/transient/src -i${LIB}/transient-universe/src -i${LIB}/axiom/src $1 -o static/out && runghc -w -i${LIB}/transient/src -i${LIB}/transient-universe/src -i${LIB}/axiom/src $1 $2 $3 4 | 5 | 6 | {-# LANGUAGE DeriveDataTypeable , ExistentialQuantification 7 | ,ScopedTypeVariables, StandaloneDeriving, RecordWildCards, FlexibleContexts, CPP 8 | ,GeneralizedNewtypeDeriving #-} 9 | 10 | module Main where 11 | 12 | import Prelude hiding (div) 13 | import Transient.Base 14 | 15 | import GHCJS.HPlay.View 16 | 17 | 18 | 19 | import Transient.Move hiding(teleport) 20 | import Control.Applicative 21 | import Control.Monad 22 | import Data.Typeable 23 | import Data.IORef 24 | import Control.Concurrent (threadDelay) 25 | import Control.Monad.IO.Class 26 | import Data.Monoid 27 | import Data.String 28 | 29 | #ifdef ghcjs_HOST_OS 30 | import qualified Data.JSString as JS hiding (empty) 31 | #endif 32 | {- 33 | Example with different input fields with events and haskell combinators 34 | 35 | The hplayground version is running at: 36 | 37 | http://tryplayg.herokuapp.com/try/widgets.hs/edit 38 | 39 | That running version uses the Haste haskell to JS compiler, while this has to be compiled 40 | with GHCJS. Some differences: 41 | 42 | This is a client AND server side app. while the hplayground one is purely client-side 43 | 44 | If you have installed transient, transient-universe and ghcjs-hplay packages, just compile and run it with 45 | 46 | 47 | ghcjs examples/widgets.hs -o static/out 48 | runghc examples/widgets.hs 49 | 50 | Also is different: 51 | now Widgets run in his own monad. To render them and convert them to the Transient monad it 52 | uses `render`. Since `simpleWebApp` expect a `Cloud` application, use `local` to run a local transient computation. `onBrowser` only execute in the web browser, so the server application does nothing. Simply stay watching at the port 8081 for browser requests. 53 | 54 | Also the
tags have been moved to the widgets and the **> has been substituted by the more standard <|> operator. In the other side, rawHtml (=== wraw) is more readable. 55 | 56 | -} 57 | 58 | #ifdef ghcjs_HOST_OS 59 | jstr x= JS.pack x 60 | #else 61 | jstr (x :: String)= undefined 62 | #endif 63 | 64 | data Person= Person{name :: String , age :: Int} deriving (Read,Show) 65 | 66 | main= keep $ initNode $ onBrowser $ local $ buttons <|> linksample 67 | where 68 | linksample= do 69 | r <- render $ br ++> br ++> wlink "Hi!" (toElem "This link say Hi!")`fire` OnClick 70 | render $ rawHtml . b $ " returns "++ r 71 | 72 | buttons :: TransIO () 73 | buttons= do 74 | render . rawHtml $ p "Different input elements:" 75 | inputPerson <|> radio <|> checkButton <|> select 76 | 77 | placeholder x = atr "placeholder" (jstr x) 78 | 79 | inputPerson= do 80 | per <- render $ Person <$> (div <<< inputString Nothing ! placeholder "Enter the name") 81 | <*> (div <<< inputInt Nothing ! placeholder "Enter the age (Int)") `fire`OnChange 82 | <** inputSubmit "send" `fire` OnClick 83 | <++ do br ; br 84 | render . rawHtml $ do b "input boxes returned:"; p per 85 | 86 | checkButton :: TransIO () 87 | checkButton=do 88 | rs <- render $ br ++> br ++> getCheckBoxes( 89 | ((setCheckBox False "Red" <++ b "red") `fire` OnClick) 90 | <> ((setCheckBox True "Green" <++ b "green") `fire` OnClick) 91 | <> ((setCheckBox False "blue" <++ b "blue") `fire` OnClick)) 92 | render $ rawHtml $ fromString " returns: " <> b (show rs) 93 | empty 94 | 95 | radio :: TransIO () 96 | radio= do 97 | r <- render $ getRadio [fromString v ++> setRadioActive True v 98 | | v <- ["red","green","blue"]] 99 | 100 | render $ rawHtml $ fromString " returns: " <> b ( show r ) 101 | 102 | select :: TransIO () 103 | select= do 104 | r <- render $ br ++> br ++> getSelect 105 | ( setOption "red" (fromString "red") 106 | <|> setOption "green" (fromString "green") 107 | <|> setOption "blue" (fromString "blue")) 108 | `fire` OnClick 109 | 110 | render $ rawHtml $ fromString " returns: " <> b ( show r ) 111 | 112 | -------------------------------------------------------------------------------- /transient/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" && runghc -DDEBUG -i${LIB}/transient/src -i${LIB}/transient-universe/src -i${LIB}/axiom/src $1 ${2} ${3} 4 | 5 | {-# LANGUAGE ExistentialQuantification, CPP, OverloadedStrings,ScopedTypeVariables, DeriveDataTypeable, FlexibleInstances, UndecidableInstances #-} 6 | {-# LANGUAGE MagicHash, UnboxedTuples #-} 7 | 8 | 9 | import Transient.Internals 10 | import Transient.Console 11 | import Transient.EVars 12 | -- import Transient.Move.Logged 13 | import Transient.Parse 14 | import Transient.Indeterminism 15 | import Data.Typeable 16 | import Control.Applicative 17 | import Data.Monoid hiding (Any) 18 | import Data.List 19 | import System.Directory 20 | import System.IO 21 | import System.IO.Error 22 | import System.Random 23 | import Control.Exception hiding (onException) 24 | import qualified Control.Exception(onException) 25 | import Control.Concurrent.MVar 26 | import Control.Monad.State 27 | import Control.Concurrent 28 | import System.IO.Error 29 | import Debug.Trace 30 | 31 | import qualified Data.ByteString.Char8 as BSS 32 | import qualified Data.ByteString.Lazy.Char8 as BS 33 | import Data.ByteString.Builder 34 | import Control.Monad.IO.Class 35 | import System.Time 36 | import Control.Monad 37 | import Data.IORef 38 | import Data.Maybe 39 | import Data.String 40 | import Data.Default 41 | import Data.Char 42 | import System.IO.Unsafe 43 | import Unsafe.Coerce 44 | 45 | 46 | import GHC.Exts 47 | import GHC.IO 48 | 49 | 50 | {-# language MagicHash #-} 51 | 52 | import Data.IORef 53 | import System.IO.Unsafe 54 | import Control.Exception 55 | import Control.Monad 56 | import GHC.Exts 57 | 58 | unique :: IORef Int 59 | unique = unsafePerformIO $ newIORef 0 60 | {-# noinline unique #-} 61 | 62 | newTag :: IO Int 63 | newTag = do 64 | t <- readIORef unique 65 | modifyIORef' unique (+1) 66 | pure t 67 | 68 | data Tagged = Tagged !Int Any 69 | instance Show Tagged where show = undefined 70 | instance Exception Tagged 71 | 72 | callCC :: ((a -> IO b) -> IO a) -> IO a 73 | callCC f = do 74 | t <- newTag 75 | catch (f $ \a -> throwIO (Tagged t (unsafeCoerce# a))) 76 | (\e@(Tagged t' a) -> if t == t' then pure (unsafeCoerce# a) else throwIO e) 77 | 78 | main :: IO () 79 | main = do 80 | x <- callCC $ \exit -> do 81 | b <- read <$> getLine 82 | when b $ do 83 | putStrLn "exit branch" 84 | exit 10 85 | putStrLn "pure branch" 86 | return 20 87 | print x 88 | 89 | -- callCC :: ((a -> IO b) -> IO a) -> IO a 90 | -- callCC f = IO $ \s0 -> 91 | -- case newPromptTag# s0 of 92 | -- (# s1, p #) -> 93 | -- let 94 | -- body s = 95 | -- unIO (f k) s 96 | -- where 97 | -- k x = IO $ \s' -> 98 | -- control0# p (\_ -> unIO (return x)) s' 99 | -- in 100 | -- prompt# p body s1 101 | 102 | 103 | -- main :: IO String 104 | -- main = do 105 | -- r <- callCC $ \f -> do 106 | -- putStrLn "Antes" 107 | -- f "Salto inmediato" 108 | -- putStrLn "Después" -- nunca se ejecuta 109 | -- print r 110 | 111 | -- {-#NOINLINE reff#-} 112 | -- reff= unsafePerformIO $ newIORef undefined 113 | -- main1= do 114 | -- writeIORef reff (2*) 115 | -- f2 <- readIORef reff 116 | -- print $ ((coerce f2) 2 :: Int) 117 | 118 | 119 | 120 | -- data Callback1= forall a.Call a -- Int -> IO (Maybe (),TranShip) 121 | 122 | -- {-# NOINLINE rcallbacks1#-} 123 | -- rcallbacks1 :: IORef (Callback1) 124 | -- rcallbacks1 = unsafePerformIO $ newIORef undefined 125 | 126 | -- addInternalCallbackData1 :: Callback1 -> IO () 127 | -- addInternalCallbackData1 cb = do 128 | -- writeIORef rcallbacks1 cb 129 | 130 | -- main= keep empty :: IO (Either String ()) 131 | 132 | -- main1= keep' $ it <|> callb 2 133 | -- where 134 | -- it= do 135 | -- r <- react1 136 | -- ttr (r :: Int) 137 | 138 | 139 | 140 | -- callb (x)= do 141 | -- liftIO $ do 142 | -- Call cb <- readIORef rcallbacks1 143 | -- (unsafeCoerce cb) x 144 | -- ttr "after1" 145 | -- empty 146 | -- -- where 147 | -- -- cast f= unsafeCoerce f `asTypeOf` typ x 148 | -- -- typ:: a -> a -> IO (Maybe(),TranShip) 149 | -- -- typ= error "typ: type level" 150 | 151 | 152 | 153 | -- react1 = Transient $ do 154 | 155 | -- cont <- get 156 | 157 | -- let callback dat = do 158 | -- ttr "callbackreact1" 159 | 160 | -- runContIO dat cont 161 | -- liftIO $ addInternalCallbackData1 $ Call callback 162 | 163 | 164 | -- return Nothing -------------------------------------------------------------------------------- /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 user 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 perturbated 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-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/.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/tests/TestSuite.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, ScopedTypeVariables #-} 2 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} 3 | {-# HLINT ignore "Move brackets to avoid $" #-} 4 | {-# HLINT ignore "Redundant bracket" #-} 5 | module Main where 6 | 7 | #ifndef ghcjs_HOST_OS 8 | 9 | import Control.Monad 10 | import Control.Monad.IO.Class 11 | import Control.Applicative 12 | import Data.Monoid 13 | import Transient.Base 14 | import Transient.Internals 15 | import Transient.Console 16 | import Transient.Indeterminism 17 | import Transient.Loggable 18 | 19 | import Transient.Move.Logged 20 | import Transient.Move.Internals 21 | import Transient.Loggable 22 | import Transient.Move.Utils 23 | import Transient.Move.Defs 24 | import Transient.Move.Services 25 | -- import Transient.MapReduce 26 | import Data.List 27 | import qualified Data.Map as M 28 | import System.Exit 29 | import Control.Monad.State 30 | import Control.Exception 31 | import Control.Concurrent.MVar 32 | 33 | import Control.Concurrent(threadDelay ) 34 | import Data.Typeable 35 | 36 | 37 | #define SHOULDRUNIN(x) (local $ do p <-getMyNode;tr p;assert ( p == (x)) (liftIO $ print ("running at node: " <> show x))) 38 | 39 | 40 | -- #define _UPK_(x) {-# UNPACK #-} !(x) 41 | 42 | -- SHOULDRUNIN x= local $ getMyNode >>= \p -> assert ( p == (x)) (liftIO $ print p) 43 | 44 | service= Service $ M.fromList 45 | [("service","test suite") 46 | ,("executable", "test-transient1") 47 | ,("package","https://github.com/agocorona/transient-universe")] 48 | 49 | 50 | 51 | 52 | main= do 53 | mr <- keep test 54 | endMonitor 55 | 56 | case mr of 57 | Left e -> print ("FAILURE",e) >> exitFailure 58 | Right () -> print "SUCCESS" >> exitSuccess 59 | 60 | 61 | 62 | portnumber= 8081 63 | 64 | liftA1 tcomp ccomp= local $ tcomp $ unCloud ccomp 65 | 66 | test= initNodeServ service "localhost" portnumber $ do 67 | 68 | -- ( thereIsArgPath' >> interactive >>= testIt) <|> 69 | (batchTest >>= testIt >> exitIt ) 70 | 71 | 72 | 73 | thereIsArgPath'= local $ Transient $ liftIO $ do 74 | ph <- thereIsArgPath 75 | if null ph then return Nothing else return $ Just ph 76 | 77 | interactive= do 78 | liftA1 fork inputNodes 79 | local $ sync $ option "f" "fire" 80 | local $ do ns <- getNodes 81 | return $ tail ns 82 | 83 | 84 | exitIt= onAll $ exit (Nothing :: Maybe SomeException) 85 | 86 | batchTest= do 87 | n <- local getMyNode 88 | local $ guard (nodePort n== portnumber) -- only executes locally in node "portnumber" 89 | 90 | requestInstance service 3 91 | 92 | 93 | 94 | 95 | testIt nodes = do 96 | let node1:node2:node3:_ = nodes 97 | tr nodes 98 | node0 <- local getMyNode 99 | 100 | 101 | 102 | -- localIO $ putStrLn "------checking empty in remote node when the remote call back to the caller #46 --------" 103 | 104 | 105 | -- r <- runAt node1 $ do 106 | -- local $ getMyNode >>= \n -> tr ("node1",n) 107 | -- SHOULDRUNIN(node1) 108 | -- runAt node2 $ (runAt node1 $ SHOULDRUNIN(node1) >> empty) <|> (SHOULDRUNIN(node2) >> return "world") 109 | -- localIO $ print r 110 | 111 | -- localIO $ putStrLn "------checking Alternative distributed--------" 112 | 113 | 114 | -- r <- local $ collect 3 $ unCloud $ 115 | -- runAt node0 (SHOULDRUNIN(node0) >> return "hello" ) <|> 116 | -- runAt node1 (SHOULDRUNIN(node1) >> return "world" ) <|> 117 | -- runAt node2 (SHOULDRUNIN(node2) >> return "world2") 118 | 119 | -- assert(sort r== ["hello", "world", "world2"]) $ localIO $ print r 120 | 121 | 122 | 123 | 124 | -- localIO $ putStrLn "--------------checking Applicative distributed--------" 125 | -- r <- loggedc $ (runAt node0 (SHOULDRUNIN( node0) >> return "hello ")) 126 | -- <> (runAt node1 (SHOULDRUNIN( node1) >> return "world " )) 127 | -- <> (runAt node2 (SHOULDRUNIN( node2) >> return "world2" )) 128 | 129 | -- assert(r== "hello world world2") $ localIO $ print r 130 | 131 | 132 | 133 | localIO $ putStrLn "----------------checking monadic, distributed-------------" 134 | r <- runAt node0 (SHOULDRUNIN(node0) 135 | >> runAt node1 (SHOULDRUNIN(node1) 136 | >> runAt node2 (SHOULDRUNIN(node2) >> (return "HELLO" )))) 137 | 138 | assert(r== "HELLO") $ localIO $ print r 139 | 140 | -- -- localIO $ putStrLn "----------------checking map-reduce -------------" 141 | 142 | -- r <- reduce (+) . mapKeyB (\w -> (w, 1 :: Int)) $ getText words "hello world hello" 143 | -- localIO $ print r 144 | -- assert (sort (M.toList r) == sort [("hello",2::Int),("world",1)]) $ return r 145 | 146 | return (Nothing :: Maybe SomeException) 147 | 148 | 149 | 150 | 151 | 152 | #else 153 | main= return () 154 | #endif 155 | -------------------------------------------------------------------------------- /transient-universe/src/Transient/Move/WebHTML.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runghc 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Transient.Move.WebHTML (generateHTML) where 4 | 5 | import Transient.Move.Defs 6 | import Transient.Move.Web 7 | import Data.ByteString.Lazy.Char8 as BS 8 | import Data.Aeson 9 | import Data.List.Split (splitOn) 10 | import Data.List (isPrefixOf) 11 | 12 | -- | Generates an interactive HTML page for a transient endpoint. 13 | generateHTML :: String -> HTTPReq -> BS.ByteString 14 | generateHTML endpoint req = BS.pack $ """ 15 | 16 | 17 | Transient Endpoint: " ++ endpoint ++ " 18 | 28 | 29 | 30 |

Endpoint: " ++ endpoint ++ "

31 |

cURL Command

32 | 
" ++ (BS.unpack $ printURL req) ++ "
33 | 34 |

HTML Form

35 |
36 | " ++ (generateFormFields req) ++ " 37 | 38 |
39 | 40 |

Response

41 | 

 42 |   
 43 |   
Follow-up Actions

 44 |   

 45 | 
 46 |   
101 | 
102 | 
103 | "
104 | 
105 | -- | Generate the curl command string from an HTTPReq
106 | printURL :: HTTPReq -> BS.ByteString
107 | printURL req = "curl " <> (if reqtype req == GET then mempty else "-H 'content-type: application/json' -XPOST -d '" <> reqbody req <> "' ") <> requrl req
108 | 
109 | -- | Generate HTML input fields from an HTTPReq
110 | generateFormFields :: HTTPReq -> String
111 | generateFormFields req = 
112 |     let urlParams = parseParams (BS.unpack $ requrl req)
113 |         bodyParams = parseParams (BS.unpack $ reqbody req)
114 |         allParams = urlParams ++ bodyParams
115 |     in concatMap createInputField allParams
116 | 
117 | -- | A simple parser for placeholders like $int, $string etc.
118 | parseParams :: String -> [String]
119 | parseParams str = [p | p <- splitOn "/" str, "$" `isPrefixOf` p]
120 | 
121 | -- | Create an HTML input field based on the parameter type
122 | createInputField :: String -> String
123 | createInputField param = 
124 |     let (inputType, paramName) = case param of
125 |             "$int"     -> ("number", "int")
126 |             "$string"  -> ("text", "string")
127 |             _          -> ("text", tail param) -- Default for other types
128 |     in "
"
129 |        ++ "
"
130 | 
131 | 
132 | 


--------------------------------------------------------------------------------
/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 | 


--------------------------------------------------------------------------------
/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 | 


--------------------------------------------------------------------------------