Merge pull request #38 from transient-haskell/services12

version change, test files

tests/Dockerfile

@@ -0,0 +1,2 @@
+from test
+CMD cd /bin && ./distributedApps -p start/localhost/8080

tests/TestSuite.hs

@@ -50,7 +50,7 @@ test=  initNodeServ service  "localhost" 8080 $ do
           
       --  local $ option "get" "get instances"
         
-          [node1,node2] <- requestInstance "" service 2  
+          [node1,node2] <- requestInstance "PIN1" service 2
    
           local ( option "f" "fire")   <|> return ""       -- to repeat the test,  remove exit
 

tests/TestSuite1.hs

@@ -0,0 +1,107 @@
+#!/usr/bin/env ./execcluster.sh
+
+
+{-# LANGUAGE CPP #-}
+module Main where
+
+#ifndef ghcjs_HOST_OS
+
+import           Control.Monad
+import           Control.Monad.IO.Class
+import           Data.IORef
+import           GHC.Conc
+import           Control.Applicative
+import           Data.Monoid
+
+import           Transient.Internals
+import           Transient.Indeterminism
+import           Transient.Logged
+import           Transient.Move
+import           Transient.Move.Utils
+import           Transient.Move.Services
+import           Transient.MapReduce
+import           Transient.EVars
+import           Control.Concurrent
+import           System.IO.Unsafe
+import           Data.List
+import           Control.Exception.Base
+import qualified Data.Map as M
+import           System.Exit
+import           System.Process
+
+import Control.Monad.State
+#define _UPK_(x) {-# UNPACK #-} !(x)
+
+
+#define shouldRun(x) (local $ getMyNode >>= \n ->  assert (nodePort n == (nodePort x)) (return ()))
+#define shouldRun1(x) (local $ getMyNode >>= \(Node _ p _ _) -> liftIO (print p >> print x >> print ( p == (x))))
+
+
+
+main= do
+
+ keep $ initNode $ do
+          n1 <- local  getMyNode
+          n2 <- requestInstall ""  ("executable", "TestSuite1")  !> "request"
+          n3 <- requestInstall ""  ("executable", "TestSuite1")
+
+--          shell "./TestSuite1 -p start/localhost/8081/add/localhost/8080/y"
+--          shell "./TestSuite1 -p start/localhost/8082/add/localhost/8080/y"
+
+
+          local $ option "f" "fire"
+--           async $ do
+--              let delay= (nodePort node -2000  + 1) *10000000
+--              threadDelay delay
+
+          nodes <- local getNodes
+          onAll $ liftIO $ print nodes
+
+          let  n1= head nodes
+               n2= nodes !! 1
+               n3= nodes !! 2
+
+
+
+          localIO $ putStrLn "------checking Alternative distributed--------"
+          r <- local $   do
+                   runCloud $ (runAt n1 (shouldRun(n1) >> return "hello" ))
+                         <|>  (runAt n2 (shouldRun(n2) >> return "world" ))
+                         <|>  (runAt n3 (shouldRun(n3) >> return "world2" ))
+          localIO $ print r
+
+--          loggedc $ assert(sort r== ["hello", "world","world2"]) $ localIO $  print r
+
+--          localIO $ putStrLn "--------------checking Applicative distributed--------"
+--          r <- loggedc $(runAt n2000 (shouldRun(2000) >> return "hello "))
+--                    <>  (runAt n2001 (shouldRun(2001) >> return "world " ))
+--                    <>  (runAt n2002 (shouldRun(2002) >> return "world2" ))
+--
+--          assert(r== "hello world world2") $ localIO $ print r
+
+--          localIO $ putStrLn "----------------checking monadic, distributed-------------"
+--          r <- runAt n2000 (shouldRun(2000)
+--                  >> runAt n2001 (shouldRun(2001)
+--                       >> runAt n2002 (shouldRun(2002) >>  (return "HELLO" ))))
+--
+--          assert(r== "HELLO") $ localIO $ print r
+--
+--
+--          localIO $ putStrLn "----------------checking map-reduce -------------"
+--
+--          r <- reduce  (+)  . mapKeyB (\w -> (w, 1 :: Int))  $ getText  words "hello world hello"
+--          localIO $ putStr "SOLUTION: " >> print r
+--          assert (sort (M.toList r) == sort [("hello",2::Int),("world",1)]) $ return r
+
+--          local $ exit ()
+--     print "SUCCESS"
+--     exitSuccess
+
+
+runNodes nodes= foldr (<|>) empty (map listen nodes) <|> return ()
+
+
+#else
+
+main= return ()
+#endif

tests/api.hs

@@ -0,0 +1,56 @@
+#!/usr/bin/env ./execthirdline.sh
+
+-- set -e &&  port=`echo ${3} | awk -F/ '{print $(3)}'` && docker run -it -p ${port}:${port} -v /c/Users/magocoal/OneDrive/Haskell/devel:/devel agocorona/transient:05-02-2017  bash -c "runghc  -j2 -isrc -i/devel/transient/src -i/devel/transient-universe/src -i/devel/ghcjs-hplay/src -i/devel/ghcjs-perch/src /devel/transient-universe/tests/$1 $2 $3 $4"
+
+-- compile it with ghcjs and  execute it with runghc
+-- 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}"
+
+{- execute as ./api.hs  -p start/<docker ip>/<port>
+
+ invoque: curl http://<docker ip>/<port>/api/hello/john
+          curl http://<docker ip>/<port>/api/hellos/john
+-}
+
+import Transient.Internals
+import Transient.Move
+import Transient.Move.Utils
+import Transient.Indeterminism
+import Control.Applicative
+import Transient.Logged
+import Control.Concurrent(threadDelay)
+import Control.Monad.IO.Class
+import qualified Data.ByteString.Lazy.Char8 as BS
+import qualified Data.ByteString as BSS
+
+main = keep $  initNode   apisample
+
+apisample= api $ gets <|> posts
+    where
+    posts= do
+       received POST
+       postParams <- param
+       liftIO $ print (postParams :: PostParams)
+       return $ BS.pack "received"
+
+    gets= received GET >>  hello <|> hellostream
+    hello= do
+        received "hello"
+        name <- param
+        let msg=  "hello " ++ name ++ "\n"
+            len= length msg
+        return $ BS.pack $ "HTTP/1.0 200 OK\nContent-Type: text/plain\nContent-Length: "++ show len
+                 ++ "\nConnection: close\n\n" ++ msg
+
+
+    hellostream = do
+        received "hellos"
+        name <- param
+        header <|> stream name
+        where
+        header=async $ return $ BS.pack $
+                       "HTTP/1.0 200 OK\nContent-Type: text/plain\nConnection: close\n\n"++
+                       "here follows a stream\n"
+        stream name= do
+            i <- threads 0 $ choose [1 ..]
+            liftIO $ threadDelay 1000000
+            return . BS.pack $ " hello " ++ name ++ " "++ show i

tests/build.sh

@@ -0,0 +1 @@
+ghc -i../transient/src -i../transient-universe/src  -i../axiom/src -i../ghcjs-perch/src $1

tests/buildrun.sh

@@ -0,0 +1,14 @@
+#!/bin/bash
+
+
+
+
+
+set -e
+
+
+
+ghcjs  -j2 -isrc -i../transient/src -i../transient-universe/src -i../axiom/src -i../ghcjs-perch/src $1 -o static/out
+
+
+runghc  -i../transient/src -i../transient-universe/src -i../axiom/src -i../ghcjs-perch/src $1 $2 $3 $4

tests/certificate.csr

@@ -0,0 +1,17 @@
+-----BEGIN CERTIFICATE REQUEST-----
+MIICxzCCAa8CAQAwgYExCzAJBgNVBAYTAkVTMQswCQYDVQQIDAJBTDERMA8GA1UE
+BwwIQWxpY2FudGUxEjAQBgNVBAoMCVRyYW5zaWVudDEaMBgGA1UEAwwRQWxiZXJ0
+byBHLiBDb3JvbmExIjAgBgkqhkiG9w0BCQEWE2Fnb2Nvcm9uYUBnbWFpbC5jb20w
+ggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQCtCzOpiBpg1ze58hWrwirG
+GMjgUG4YC4px37fhhBhalXCkyQHXL7L5iFsOuuoLEymVm7XmKnqHGLoidaOtVKsO
+OF3rVWbkFma2llewNQBtW1ESpxMUv4Ff0OmIk6wzUvyRauH0Lh5g+/DRkYXM+Yqx
+psjxnVu1wguu0JK22vb9ZBU8yiJMmvUkG7mz+ZxJtPeHPm6r6RInYqNOQzwIRrhG
+Fs12jt/uIxby9yp9QU5IIPkTND+P7JgVj940oavKDcaOFiQDbtg7OoNBRrz2RC0z
+7VDSTiNeIa5cF4q6zsFCqWa5pdGERvJmEiQCnLJGb1QOg0iBObeVzGATiUbub3xj
+AgMBAAGgADANBgkqhkiG9w0BAQsFAAOCAQEAAJ85w+4Sat6C7jbqrsMXxRrxMdIQ
+d+icek80MtuLp95o22auWAyhE7qD8C/XOed3x57HqdikCk4FX/8/ypzVriy6bKem
+pm1Ym96nY1SKA8cWqOR/2tLW88sFRqvuCv+n5nMCBKCJSnK15YxfJ3DU/KTXvQHJ
+OQE3a4o8q0jA85Dduk+BaqqQtc4yREQWdCb9WfM/JeIh8JyaCc100dNcmzctPJmp
+2pktQgHTSMGLbWBjA94Kx7Ad1WKPtXUXPGOZpjEZmRlN+EOkQChtSdXfrDf0IhcA
+GOqL+VyP7zf5uEILCyFp4A//91SJKsT+qDT5+c7E31FXD29rt78a/42iTQ==
+-----END CERTIFICATE REQUEST-----

tests/certificate.pem

@@ -0,0 +1,21 @@
+-----BEGIN CERTIFICATE-----
+MIIDgDCCAmgCCQCPngD5S+HGtzANBgkqhkiG9w0BAQsFADCBgTELMAkGA1UEBhMC
+RVMxCzAJBgNVBAgMAkFMMREwDwYDVQQHDAhBbGljYW50ZTESMBAGA1UECgwJVHJh
+bnNpZW50MRowGAYDVQQDDBFBbGJlcnRvIEcuIENvcm9uYTEiMCAGCSqGSIb3DQEJ
+ARYTYWdvY29yb25hQGdtYWlsLmNvbTAeFw0xNzAyMTAxNTI3MzJaFw0xNzAzMTIx
+NTI3MzJaMIGBMQswCQYDVQQGEwJFUzELMAkGA1UECAwCQUwxETAPBgNVBAcMCEFs
+aWNhbnRlMRIwEAYDVQQKDAlUcmFuc2llbnQxGjAYBgNVBAMMEUFsYmVydG8gRy4g
+Q29yb25hMSIwIAYJKoZIhvcNAQkBFhNhZ29jb3JvbmFAZ21haWwuY29tMIIBIjAN
+BgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEArQszqYgaYNc3ufIVq8IqxhjI4FBu
+GAuKcd+34YQYWpVwpMkB1y+y+YhbDrrqCxMplZu15ip6hxi6InWjrVSrDjhd61Vm
+5BZmtpZXsDUAbVtREqcTFL+BX9DpiJOsM1L8kWrh9C4eYPvw0ZGFzPmKsabI8Z1b
+tcILrtCSttr2/WQVPMoiTJr1JBu5s/mcSbT3hz5uq+kSJ2KjTkM8CEa4RhbNdo7f
+7iMW8vcqfUFOSCD5EzQ/j+yYFY/eNKGryg3GjhYkA27YOzqDQUa89kQtM+1Q0k4j
+XiGuXBeKus7BQqlmuaXRhEbyZhIkApyyRm9UDoNIgTm3lcxgE4lG7m98YwIDAQAB
+MA0GCSqGSIb3DQEBCwUAA4IBAQCV9UZ5ym/fgitS0HmgvroFY9DCrz5lLGCxJw1v
+nfCxRzebtskgnbb1nX/dk8HLA/9qxjWMxr9hNHINgY+ER6yfJl2/tRfvziDlHpio
+O4tprK/HincK7g53jntXpJAvam0k2431SmV+KOBhVD80BEivmDlHI0S+n9SZlF50
+Xb9zHw5unLj8+iM6+ySRSgPAdroWFWgxCt8yFfKVubLyYDLfywSxLKbcEhvhW1iU
+AJkwhRjALJ9E5G9OmDIhmEVf01hlZxnZ2oiAk0WoEFqgMzXgTc8XEydkVIpm2UkO
+e1mN9AraJYMe/xzKuv5VS+2afYtI0JI/M0ttj0bT64Y0ZluR
+-----END CERTIFICATE-----

tests/distributedApps.hs

@@ -0,0 +1,194 @@
+#!/usr/bin/env ./execthirdline.sh
+-- compile all the transient libraries whith ghcjs and run with ghc
+-- set -e &&  port=`echo ${3} | awk -F/ '{print $(3)}'` && docker run -it -p ${port}:${port} -v /c/Users/magocoal/OneDrive/Haskell/devel:/devel agocorona/transient:05-02-2017  bash -c "mkdir -p static && ghcjs  -j2 -isrc -i/devel/transient/src -i/devel/transient-universe/src -i/devel/ghcjs-hplay/src -i/devel/ghcjs-perch/src /devel/transient-universe/tests/$1 -o static/out && runghc  -j2 -isrc -i/devel/transient/src -i/devel/transient-universe/src -i/devel/ghcjs-hplay/src -i/devel/ghcjs-perch/src /devel/transient-universe/tests/$1 $2 $3 $4"
+
+
+-- compile it with ghcjs and  execute it with runghc
+-- set -e && port=`echo ${3} | awk -F/ '{print $(3)}'` && docker run -it -p ${port}:${port} -v $(pwd):/work agocorona/transient:05-02-2017  bash -c "mkdir -p static && ghcjs /work/${1} -o static/out && runghc /work/${1} ${2} ${3}"
+
+
+-- set -e &&  port=`echo ${3} | awk -F/ '{print $(3)}'` && docker run -it -p ${port}:${port} -v /c/Users/magocoal/OneDrive/Haskell/devel:/devel agocorona/transient:05-02-2017  bash -c "mkdir -p static && ghcjs  -j2 -isrc -i/devel/transient/src -i/devel/transient-universe/src -i/devel/ghcjs-hplay/src -i/devel/ghcjs-perch/src /devel/transient-universe/examples/$1 -o static/out && runghc  -j2 -isrc -i/devel/transient/src -i/devel/transient-universe/src -i/devel/ghcjs-hplay/src -i/devel/ghcjs-perch/src /devel/transient-universe/examples/$1 $2 $3 $4"
+
+-- usage: ./distributedApps.hs -p start/<docker ip>/<port>
+
+{-# LANGUAGE   CPP, NoMonomorphismRestriction, DeriveDataTypeable  #-}
+
+module Main where
+
+import Prelude hiding (div,id)
+import Transient.Internals
+
+import GHCJS.HPlay.Cell
+import GHCJS.HPlay.View hiding (map, input,option,parent)
+
+import Transient.Move
+import Transient.EVars
+import Transient.Indeterminism
+
+import Control.Applicative
+import qualified Data.Vector as V
+import qualified Data.Map as M
+import Transient.MapReduce
+import Control.Monad.IO.Class
+import Control.Monad
+import Data.String
+import qualified Data.Text as T
+
+#ifdef ghcjs_HOST_OS
+import qualified Data.JSString as JS hiding (span,empty,strip,words)
+#endif
+
+import Data.Typeable
+import Data.Monoid
+
+import qualified Data.ByteString.Lazy.Char8 as BS
+import Transient.Logged
+
+
+import Transient.Internals
+import Control.Concurrent.MVar
+import System.IO.Unsafe
+import Control.Concurrent
+import Control.Monad.State
+import Control.Concurrent.STM
+
+data Options= MapReduce | Chat | MonitorNodes | AllThree deriving (Typeable, Read, Show)
+
+
+main = keep $  initNode  $ inputNodes <|> menuApp  <|> thelink
+
+
+
+
+thelink=   do
+     local . render $ rawHtml $ do
+         br;br
+         a ! href (fs "https://github.com/agocorona/transient-universe/blob/master/examples/distributedApps.hs") $ "source code"
+     empty
+
+menuApp= do
+     local . render . rawHtml $ do
+        h1 "Transient Demo"
+        br; br
+     op <- local .  render $
+               tlink MapReduce (b "map-reduce") <++ fs "   " <|>
+               tlink Chat (b "chat")  <++ fs "   " <|>
+               tlink MonitorNodes (b "monitor nodes") <++ fs "   "  <|>
+               tlink AllThree  (b "all widgets")
+
+     case op of
+               AllThree -> allw
+               MapReduce -> mapReduce                        -- !> " option mapReduce"
+               Chat -> chat
+               MonitorNodes -> monitorNodes
+
+
+allw=   mapReduce <|> chat  <|>  monitorNodes
+
+
+
+
+-- A Web node launch a map-reduce computation in all the server nodes, getting data from a
+-- textbox and render the results returned
+
+mapReduce= onBrowser $ do
+
+    content <- local . render $
+            h1 "Map-Reduce widget" ++>
+            p "Return the frequencies of words from a text using all the server nodes connected" ++>
+            textArea   (fs "") ! atr "placeholder" (fs "enter the content")
+                               ! atr "rows"  (fs "4")
+                               ! atr "cols"  (fs "80")
+            <++  br
+            <**  inputSubmit "send"  `fire` OnClick
+            <++  br
+--    return () !> ("content",content)
+
+    guard (content /= "")
+    msg <-   local genNewId
+    let entry= boxCell msg ! size  (fs "60")
+
+    r <- atRemote $ do
+           lliftIO $ print content
+
+
+           r<- reduce  (+) . mapKeyB (\w -> (w, 1 :: Int))  $ distribute $ V.fromList $ words content
+           lliftIO $ putStr "result:" >> print r
+           return   (r :: M.Map String Int)
+
+
+    local . render $ rawHtml $ do
+             h1 "Results"
+             mconcat[i "word " >> b w >> i " appears " >> b n >> i " times" >> br
+                    | (w,n) <- M.assocs r]
+
+    empty
+
+fs= fromString
+size= atr (fs "size")
+-- a chat widget that run in the browser and in a cloud of servers
+
+
+chat = onBrowser $ do
+    let chatbox= fs "chatbox" -- <- local  genNewId
+    local . render . rawHtml $ do   -- Perch monads
+            h1 "Federated chat server"
+
+            div ! id chatbox
+                ! style (fs $"overflow: auto;height: 200px;"
+                         ++  "background-color: #FFCC99; max-height: 200px;")
+                $ noHtml  -- create the chat box
+
+    sendMessages   <|>  waitMessages chatbox
+
+  where
+
+  sendMessages   = do
+
+      let msg = fs "messages" -- <-   local genNewId
+      let entry= boxCell msg ! size  (fs "60")
+      (nick,text) <- local . render $  (,) <$> getString (Just "anonymous") ! size (fs "10")
+                                           <*> mk entry Nothing  `fire` OnChange
+                                           <** inputSubmit "send"
+                                           <++ br
+      local $ entry .= ""
+      guard (not $ null text)
+
+      atRemote $ do
+          node <- local getMyNode
+          clustered $ local $ putMailbox  (showPrompt nick node ++ text )  >> empty :: Cloud ()
+          empty
+
+      where
+
+      showPrompt u (Node h p _ _)= u ++ "@" ++ h ++ ":" ++ show p ++ "> "
+
+  waitMessages chatbox = do
+
+      resp <-  atRemote . local $ do
+           labelState $ "getMailbox"
+           r <-  single getMailbox
+           return r
+                                                           -- wait in the server for messages
+
+      local . render . at (fs "#" <> chatbox) Append $ rawHtml $ do
+                                          p (resp :: String)    -- display the response
+#ifdef ghcjs_HOST_OS
+                                          liftIO $ scrollBottom $ fs "chatbox"
+
+
+foreign import javascript unsafe
+  "var el= document.getElementById($1);el.scrollTop=  el.scrollHeight"
+  scrollBottom  :: JS.JSString -> IO()
+#endif
+
+monitorNodes= onBrowser $ do
+    local . render $ rawHtml $ do
+         h1 "Nodes connected"
+         div ! atr (fs "id") (fs "nodes") $ noHtml
+
+    nodes <- atRemote . local  . single $  sample getNodes 1000000
+
+    local . render . at (fs "#nodes") Insert . rawHtml $
+           table $ mconcat[tr $ td h >> td p >> td s | Node h p _ s  <- nodes]
+    empty

tests/dockerclean.sh

@@ -0,0 +1,3 @@
+docker kill $(docker ps -q)
+docker rm $(docker ps -a -q)
+docker rmi $(docker images -q -f dangling=true)

tests/execcluster.sh

@@ -0,0 +1,61 @@
+set -e
+# compile=`sed -n '3p' ${1} | sed 's/-- //'`
+# execute=`sed -n '4p' ${1} | sed 's/-- //'`
+
+
+# compile with ghcjs and ghc, run a cluster of N nodes: <source.hs> -p start/<host>/<port>  N
+
+compile (){
+    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"
+}
+
+compile_no_ghcjs (){
+   docker run  -v $(pwd):/devel agocorona/transient:24-03-2017  bash -c "cd /devel && ghc -O -threaded -rtsopts  -j2 $1"
+}
+
+execute() {
+    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"
+}
+
+executeone(){
+   docker run -p ${port}:${port} -v $(pwd):/devel agocorona/transient:24-03-2017 bash -c "cd devel && $1 $2 $3"
+}
+
+# compile with ghcjs and ghc with develop. libraries, run a cluster of N nodes: <source.hs> -p start/<host>/<port>  N
+
+compiled() {
+    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"
+}
+
+
+nnodes=$4
+
+re='^[0-9]+$'
+if ! [[ $nnodes =~ $re ]] ; then
+   nnodes=1
+fi
+
+host=`echo ${3} | awk -F/ '{print $(2)}'`
+baseport=`echo ${3} | awk -F/ '{print $(3)}'`
+finalport=`expr $baseport + $nnodes`
+port=$baseport
+executable=./$(basename $1 .hs)
+
+echo "compiling"
+compile_no_ghcjs $1
+
+echo executing $nnodes nodes
+if [ $nnodes -eq 1 ]
+  then
+    $executeone $executable $2 $3
+  else
+    while [ "$port" -lt "$finalport" ]
+      do
+        execute $executable & # >> log${port}.log  &
+        sleep 1
+        ((port++))
+      done
+fi
+echo "done"
+
+

tests/execthirdline.sh

@@ -0,0 +1,2 @@
+command=`sed -n '3p' ${1} | sed 's/-- //'`
+eval $command $1 $2 $3

tests/iterate.sh

@@ -0,0 +1,6 @@
+#!/bin/bash
+set -e
+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"
+./tests/hasrocket -p start/localhost/8080 &
+sleep 2
+../websocket-shootout/bin/websocket-bench broadcast ws://127.0.0.1:8080/ws -c 4 -s 40 --step-size 100

tests/key.pem

@@ -0,0 +1,27 @@
+-----BEGIN RSA PRIVATE KEY-----
+MIIEpQIBAAKCAQEArQszqYgaYNc3ufIVq8IqxhjI4FBuGAuKcd+34YQYWpVwpMkB
+1y+y+YhbDrrqCxMplZu15ip6hxi6InWjrVSrDjhd61Vm5BZmtpZXsDUAbVtREqcT
+FL+BX9DpiJOsM1L8kWrh9C4eYPvw0ZGFzPmKsabI8Z1btcILrtCSttr2/WQVPMoi
+TJr1JBu5s/mcSbT3hz5uq+kSJ2KjTkM8CEa4RhbNdo7f7iMW8vcqfUFOSCD5EzQ/
+j+yYFY/eNKGryg3GjhYkA27YOzqDQUa89kQtM+1Q0k4jXiGuXBeKus7BQqlmuaXR
+hEbyZhIkApyyRm9UDoNIgTm3lcxgE4lG7m98YwIDAQABAoIBAH6cFpWxJpO6hGSB
+0wdTztYYZklxr8vaDdbZuIHBk8wbUUrQY49dsBbRhMZXTk0CHUgAoOuiIvpbxjzW
+VAbLT0jdRyKb3ud92HM5tzkO3pwk10HNirGAmRlREr3CRpla279OM7rkT4fobr/3
+OK3L24W2IYpe9y4ap0+l/eLafSLR9nURhz/Q8wTIjYV9mxAbTYgb/wvDeiDeVlom
+I03C2um6AAqmx9ltGFUGNV7r6zLwUG8tvaWJyFF1e8jHY+PVWhyRTP65H53tbEgk
+gNJrIdd4rjz3qqO9lzisBd/XImHX7HRPX7vvynokvqaNjAHrNeUb08mA7XrAEuAB
+1PtTz2ECgYEA2Ip5AjhCRXUPmL66eQg7jzjTaXG8dThA8F6hJY0gQrmpBp4tMf3R
+tc8J60oZrpIukprbuH9OjrUPE5WxPZIg4ppItBf5qRWprvHIL3i/hekP4/59YdTQ
+D/7MK2a9fOuNNxd6dfSit96FoFNVcQt0Nnn9U9qv92CqXRragHJe39ECgYEAzJOb
+uPFp6PnG0E4E7Q7W2qZySSHsN5om2Ckqpsc6H6e0gvLN3KQtLFFaAElyr7/LUCQD
+ccBBc8RW4tYPqghyPixCByKk5SKJ1voV7GSXdevmtfccVB2pORCg0RJn3F94EJ/j
+/86ezrwFyTRpGCgaEMKSXm/PznFFc9PYv7gzufMCgYEAv/EeimUr+T1mcdK+oAI4
+KSAJ5fG3R4Bxr59x4ENUUVEZDpCvJx0CAtJezH2GfkN9nN4/3S6bh8vebVHHJfid
+xb9Uqq6F0ucs3bHb7JhvzFdmioZOxaVKOKN2fxI27MAvEKJzHpOWmL1aXV8A4Y9x
+l8hSUT4LtI+u85CWFj1K88ECgYEArvmZeYfSpFfu+n+gqvnEPuOaYH7JQY1xp/Ud
+6+P/DNAuDsqJ1Sv/DybNqe0oULXkubjz0Tk1QkUuY3nfj/kFbbQBDYVOMEVoTB0+
+3x/yhAOvIvgmnLN557sXMXtiphRp5x46rrMVFZGwCTXwpZ63HJqvAmL0BIjRdI4/
+l0t/wo0CgYEA1beM5dxv6RrqJxY8RyA/qECuNtrXcCMrjCud96irpew3RFj1+H6C
+17NDkbfzZZIl75JFEy7ncbRQeo8QRA1wqxkb0J0yAn9l8cHVV/6WBRVFeIt4mBP7
+oHRLc68+Qn+RGlR854CTQVjYxNYUiEosI1u0yRIO6erIKHMohsy9FyY=
+-----END RSA PRIVATE KEY-----

tests/nikita.hs

@@ -0,0 +1,78 @@
+import Prelude hiding (div, id)
+import Transient.Base
+import Transient.Move
+import GHCJS.HPlay.View
+import Control.Applicative
+import Data.String
+import Control.Monad.IO.Class
+import Data.IORef
+import Data.Typeable
+
+fs= fromString
+
+data AppState = AppState
+  { appStateMessage :: Int }
+  deriving (Read, Show)
+
+data Action
+  = ButtonClicked
+  | Stop
+  deriving (Read, Show, Eq)ca
+
+(|>) = flip ($)
+
+initialAppState :: AppState
+initialAppState = AppState 0
+
+
+main= keep $ initNode $ onBrowser $  do
+      local . render . rawHtml $ div ! id (fs "appdiv") $ noHtml
+      displayState
+      app 
+
+app ::  Cloud ()
+
+app  =    do
+        action <- displayButton 
+        updateState action 
+        displayState
+
+        
+           
+displayButton ::  Cloud Action
+displayButton  = local $ render $ wbutton ButtonClicked (fromString "Click me")
+
+displayState=   local $ do
+     appState <- getAppState
+     render $ at (fs "#appdiv") Insert $ do
+            rawHtml (appStateMessage appState |> show |> h1)
+ 
+updateState  ButtonClicked  = local $ do
+   AppState v <- getAppState
+   setAppState (AppState $ v+1)
+
+getAppState :: TransIO AppState
+getAppState= getRData <|>  (setRData initialAppState >> return initialAppState)
+
+setAppState :: AppState -> TransIO ()
+setAppState= setRData
+
+
+---------------------------------------------  State References in the TransIO monad ------------
+newtype Ref a = Ref (IORef a)
+
+-- | An state reference that can be updated (similar to STRef in the state monad)
+--
+-- Initialized the first time it is set.
+setRData:: Typeable a => a -> TransIO ()
+setRData x= do
+     Ref ref <- getSData
+     liftIO $ atomicModifyIORef ref $ const (x,())
+   <|> do
+     ref <- liftIO (newIORef x)
+     setData $ Ref ref
+
+getRData :: Typeable a => TransIO a
+getRData= do
+    Ref ref <- getSData
+    liftIO $ readIORef ref

tests/rundevel.sh

@@ -0,0 +1 @@
+runghc -i../transient/src -i../transient-universe/src  -i../axiom/src -i../ghcjs-perch/src $1 $2 $3

tests/testtls.hs

@@ -0,0 +1,205 @@
+#!/usr/bin/env ./execthirdline.sh
+--  execute it with runghc
+-- set -e && port=`echo ${3} | awk -F/ '{print $(3)}'` && docker run -it -p ${port}:${port} -v $(pwd):/work testtls  bash -c "runghc /work/${1} ${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 "mkdir -p static && ghcjs  -j2 -isrc -i/devel/transient/src -i/devel/transient-universe/src -i/devel/ghcjs-hplay/src -i/devel/ghcjs-perch/src /devel/transient-universe/tests/$1 -o static/out && runghc  -j2 -isrc -i/devel/transient/src -i/devel/transient-universe/src -i/devel/ghcjs-hplay/src -i/devel/ghcjs-perch/src /devel/transient-universe/tests/$1 $2 $3 $4"
+
+
+{-# LANGUAGE   CPP, ScopedTypeVariables, DeriveDataTypeable, BangPatterns, OverloadedStrings #-}
+
+import Transient.Base
+import Transient.EVars
+import Transient.Move
+import Transient.Move.Utils
+import Transient.Backtrack
+import Transient.Indeterminism
+import Transient.Internals
+import Transient.Logged
+import Data.Typeable
+import Control.Applicative
+import Data.Monoid
+import Control.Monad
+import Data.Typeable
+import Data.IORef
+import Control.Concurrent (threadDelay)
+import Control.Monad.IO.Class
+import System.Directory
+import System.Random
+import Control.Exception as E
+
+import Network  hiding(accept)
+import Network.Socket as NSS
+import Network.Socket.ByteString as NS
+--import Network.Socket (accept)
+import Network.TLS as TLS
+
+
+import           Network.TLS.Extra                  as TLSExtra
+import qualified Crypto.Random.AESCtr               as AESCtr
+
+import qualified Network.Socket.ByteString.Lazy     as SBSL
+
+import qualified Data.ByteString.Lazy               as BL
+import qualified Data.ByteString.Lazy.Char8         as BL8
+import qualified Data.ByteString.Char8              as B
+import qualified Data.ByteString                    as BE
+import qualified Data.Certificate.X509              as X
+import qualified Data.X509.CertificateStore         as C
+import Data.Default
+
+
+import Debug.Trace
+
+(!>) a b = trace b a
+
+sendTLSData = TLS.sendData
+
+
+recvTLSData = TLS.recvData
+
+
+maybeTLSServerHandshake _ _ = return ()
+
+--initNode $ Cloud $ do
+--  ParseContext _ input <- getSData <|> error "parse"
+--  Connection _(Just (Node2Node _ sock _)) _ _ _ _ _ _  <- getSData <|> error "conn"
+
+-- cabal install tls cprng-aes  certificate
+
+main= keep $  do
+
+  sock <- liftIO . listenOn  $ PortNumber 8080
+  (sock,addr) <- waitEvents $ NSS.accept sock                       !>  "wait"
+  input <-  liftIO $ SBSL.getContents sock                          !>  "read"
+
+  let fmsg msg= "HTTP/1.0 200 OK\nContent-Type: text/plain\nContent-Length: "
+                 ++ show (length msg)
+                 ++ "\nConnection: close\n\n" ++ msg
+
+  hs <-maybeTLSHandshake sock input
+  case hs of
+    Just ctx -> liftIO $ TLS.sendData ctx $ BL8.pack $ fmsg "TLS"
+    Nothing -> do
+
+    liftIO $ NS.sendAll sock $ B.pack $ fmsg "NOTLS"
+    return ()
+
+maybeTLSServerHandshake sock input=
+ if ((not $ BL.null input) && BL.head input  == 0x16)
+   then  do
+    ctx <- liftIO $ do
+          cred <- either error id <$>TLS.credentialLoadX509
+                 "/work/certificate.pem"
+                 "/work/key.pem"
+          let sp = makeServerSettings    cred                                       !> "TLS"
+          ctx <- makeServerContext sp sock  input
+          TLS.handshake ctx
+          return ctx
+      -- xxxx save context in connection a¤adir msend
+    onFinish $ const $  liftIO $ TLS.contextClose ctx
+    return $ Just ctx
+   else return Nothing
+
+clientTLSHandshake hostname sock input= do
+   ctx <- liftIO $ do
+       sp <- makeClientSettings hostname
+       ctx <- makeCLientContext sp sock
+       TLS.handshake ctx
+       -- save..
+   onFinish $ const $  liftIO $ TLS.contextClose ctx
+
+
+makeClientSettings hostname= ClientParams{
+         TLS.clientUseMaxFragmentLength= Nothing
+      ,  TLS.clientServerIdentification= (hostname,"")
+      ,  TLS.clientUseServerNameIndication = False
+      ,  TLS.clientWantSessionResume = Nothing
+      ,  TLS.clientShared  = def
+      ,  TLS.clientHooks = def
+      ,  TLS.clientSupported = supported
+      }
+makeServerSettings credential = def { -- TLS.ServerParams
+        TLS.serverWantClientCert = False
+      , TLS.serverCACertificates = []
+      , TLS.serverDHEParams      = Nothing
+      , TLS.serverHooks          = hooks
+      , TLS.serverShared         = shared
+      , TLS.serverSupported      = supported
+      }
+    where
+    -- Adding alpn to user's tlsServerHooks.
+    hooks =  def
+--    TLS.ServerHooks {
+--        TLS.onALPNClientSuggest = TLS.onALPNClientSuggest tlsServerHooks <|>
+--          (if settingsHTTP2Enabled set then Just alpn else Nothing)
+--      }
+
+    shared = def {
+        TLS.sharedCredentials = TLS.Credentials [credential]
+      }
+supported = def { -- TLS.Supported
+        TLS.supportedVersions       = [TLS.TLS12,TLS.TLS11,TLS.TLS10]
+      , TLS.supportedCiphers        = ciphers
+      , TLS.supportedCompressions   = [TLS.nullCompression]
+      , TLS.supportedHashSignatures = [
+          -- Safari 8 and go tls have bugs on SHA 512 and SHA 384.
+          -- So, we don't specify them here at this moment.
+          (TLS.HashSHA256, TLS.SignatureRSA)
+        , (TLS.HashSHA224, TLS.SignatureRSA)
+        , (TLS.HashSHA1,   TLS.SignatureRSA)
+        , (TLS.HashSHA1,   TLS.SignatureDSS)
+        ]
+      , TLS.supportedSecureRenegotiation = True
+      , TLS.supportedClientInitiatedRenegotiation = False
+      , TLS.supportedSession             = True
+      , TLS.supportedFallbackScsv        = True
+      }
+ciphers :: [TLS.Cipher]
+ciphers =
+    [ TLSExtra.cipher_ECDHE_RSA_AES128GCM_SHA256
+    , TLSExtra.cipher_ECDHE_RSA_AES128CBC_SHA256
+    , TLSExtra.cipher_ECDHE_RSA_AES128CBC_SHA
+    , TLSExtra.cipher_DHE_RSA_AES128GCM_SHA256
+    , TLSExtra.cipher_DHE_RSA_AES256_SHA256
+    , TLSExtra.cipher_DHE_RSA_AES128_SHA256
+    , TLSExtra.cipher_DHE_RSA_AES256_SHA1
+    , TLSExtra.cipher_DHE_RSA_AES128_SHA1
+    , TLSExtra.cipher_DHE_DSS_AES128_SHA1
+    , TLSExtra.cipher_DHE_DSS_AES256_SHA1
+    , TLSExtra.cipher_AES128_SHA1
+    , TLSExtra.cipher_AES256_SHA1
+    ]
+
+makeClientContext params sock = liftIO $ do
+     TLS.contextNew backend params
+
+-- | Make a server-side TLS 'Context' for the given settings, on top of the
+-- given TCP `Socket` connected to the remote end.
+makeServerContext :: MonadIO m => TLS.ServerParams -> Socket -> BL.ByteString  -> m Context
+makeServerContext params sock input= liftIO $ do
+    inputBuffer <- newIORef input
+    TLS.contextNew (backend inputBuffer)  params
+
+
+    where
+    backend inputBuffer= TLS.Backend {
+        TLS.backendFlush = return ()
+      , TLS.backendClose = NSS.close sock
+      , TLS.backendSend  = sendAll' sock
+      , TLS.backendRecv  =  \n -> do
+          input <- readIORef inputBuffer
+          let (res,input')= BL.splitAt (fromIntegral n) input
+          writeIORef inputBuffer input'
+          return $ toStrict res
+      }
+    recvAll input= step B.empty
+       where step !acc 0 = return acc
+             step !acc n = do
+                bs <- NS.recv sock n
+                step (acc `B.append` bs) (n - B.length bs)
+
+    toStrict s= BE.concat $ BL.toChunks s :: BE.ByteString
+
+    sendAll' sock bs = NS.sendAll sock bs `E.catch` \(SomeException e) ->
+        throwIO e

transient-universe.cabal

@@ -1,5 +1,5 @@
 name: transient-universe
-version: 0.4.4
+version: 0.4.5
 cabal-version: >=1.10
 build-type: Simple
 license: MIT