Skip to content

Commit 59ab3d9

Browse files
agocoronaagocorona
committed
just changes
1 parent b99181b commit 59ab3d9

36 files changed

+310136
-120
lines changed

‎Atm.hs

100644100755
File mode changed.

‎DataFramesDistributed.hs

+7
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,7 @@
1+
import Frames
2+
import qualified Control.Foldl as L
3+
4+
instance (Loggable a) => Distributable DV.Vector a where
5+
singleton = DV.singleton
6+
splitAt= DV.splitAt
7+
fromList = DV.fromList

‎DistrbDataSets.hs

100644100755
File mode changed.

‎IRCclient.hs

100644100755
File mode changed.

‎MainSamples.hs

100644100755
File mode changed.

‎PiDistribCountinuous.hs

100644100755
File mode changed.

‎PiDistribOnce.hs

100644100755
File mode changed.

‎Setup.hs

100644100755
File mode changed.

‎api.hs

100644100755
+8-5
Original file line numberDiff line numberDiff line change
@@ -1,15 +1,18 @@
1-
#!/usr/bin/env ./execthirdline.sh
2-
-- compile it with ghcjs and execute it with runghc
3-
-- 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}"
1+
#!/usr/bin/env execthirdlinedocker.sh
42

3+
-- runghc -DDEBUG -threaded -i../develold/TCache -i../transient/src -i../transient-universe/src -i../axiom/src $1 ${2} ${3}
4+
5+
-- mkdir -p ./static && ghcjs --make -DDEBUG -i../transient/src -i../transient-universe/src -i../axiom/src $1 -o static/out && runghc -DDEBUG -threaded -i../develold/TCache -i../transient/src -i../transient-universe/src -i../axiom/src $1 ${2} ${3}
6+
7+
58
{- execute as ./api.hs -p start/<docker ip>/<port>
69
710
invoque: curl http://<docker ip>/<port>/api/hello/john
811
curl http://<docker ip>/<port>/api/hellos/john
912
-}
1013

1114
import Transient.Base
12-
import Transient.Move
15+
import Transient.Move.Internals
1316
import Transient.Move.Utils
1417
import Transient.Indeterminism
1518
import Control.Applicative
@@ -24,7 +27,7 @@ main = keep' . freeThreads $ initNode apisample
2427
apisample= api $ hello <|> hellostream
2528
where
2629
hello= do
27-
paramName "hello"
30+
param "hello"
2831
name <- paramVal
2932
let msg= "hello " ++ name ++ "\n"
3033
len= length msg

‎distributedApps.hs

100644100755
+80-80
Original file line numberDiff line numberDiff line change
@@ -108,84 +108,84 @@ mapReduce= onBrowser $ do
108108
lliftIO $ print content
109109

110110

111-
r<- reduce (+) . mapKeyB (\w -> (w, 1 :: Int)) $ distribute $ V.fromList $ words content
112-
lliftIO $ putStr "result:" >> print r
113-
return (r :: M.Map String Int)
114-
115-
116-
local . render $ rawHtml $ do
117-
h1 "Results"
118-
mconcat[i "word " >> b w >> i " appears " >> b n >> i " times" >> br
119-
| (w,n) <- M.assocs r]
120-
121-
empty
122-
123-
fs= fromString
124-
size= atr (fs "size")
125-
-- a chat widget that run in the browser and in a cloud of servers
126-
127-
128-
chat = onBrowser $ do
129-
let chatbox= fs "chatbox" -- <- local genNewId
130-
local . render . rawHtml $ do -- Perch monads
131-
h1 "Federated chat server"
132-
133-
div ! id chatbox
134-
! style (fs $"overflow: auto;height: 200px;"
135-
++ "background-color: #FFCC99; max-height: 200px;")
136-
$ noHtml -- create the chat box
137-
138-
sendMessages <|> waitMessages chatbox
139-
140-
where
141-
142-
sendMessages = do
143-
144-
let msg = fs "messages" -- <- local genNewId
145-
let entry= boxCell msg ! size (fs "60")
146-
(nick,text) <- local . render $ (,) <$> getString (Just "anonymous") ! size (fs "10")
147-
<*> mk entry Nothing `fire` OnChange
148-
<** inputSubmit "send"
149-
<++ br
150-
local $ entry .= ""
151-
guard (not $ null text)
152-
153-
atRemote $ do
154-
node <- local getMyNode
155-
clustered $ local $ putMailbox (showPrompt nick node ++ text ) >> empty :: Cloud ()
156-
empty
157-
111+
r<- reduce (+) . mapKeyB (\w -> (w, 1 :: Int)) $ distribute $ V.fromList $ words content
112+
lliftIO $ putStr "result:" >> print r
113+
return (r :: M.Map String Int)
114+
115+
116+
local . render $ rawHtml $ do
117+
h1 "Results"
118+
mconcat[i "word " >> b w >> i " appears " >> b n >> i " times" >> br
119+
| (w,n) <- M.assocs r]
120+
121+
empty
122+
123+
fs= fromString
124+
size= atr (fs "size")
125+
-- a chat widget that run in the browser and in a cloud of servers
126+
127+
128+
chat = onBrowser $ do
129+
let chatbox= fs "chatbox" -- <- local genNewId
130+
local . render . rawHtml $ do -- Perch monads
131+
h1 "Federated chat server"
132+
133+
div ! id chatbox
134+
! style (fs $"overflow: auto;height: 200px;"
135+
++ "background-color: #FFCC99; max-height: 200px;")
136+
$ noHtml -- create the chat box
137+
138+
sendMessages <|> waitMessages chatbox
139+
158140
where
159-
fs= fromString
160-
161-
showPrompt u (Node h p _ _)= u ++ "@" ++ h ++ ":" ++ show p ++ "> "
162-
163-
waitMessages chatbox = do
164-
165-
resp <- atRemote . local $ do
166-
labelState $ "getMailbox"
167-
r <- single getMailbox
168-
return r
169-
-- wait in the server for messages
170-
171-
local . render . at (fs "#" <> chatbox) Append $ rawHtml $ do
172-
p (resp :: String) -- display the response
173-
#ifdef ghcjs_HOST_OS
174-
liftIO $ scrollBottom $ fs "chatbox"
175-
176-
177-
foreign import javascript unsafe
178-
"var el= document.getElementById($1);el.scrollTop= el.scrollHeight"
179-
scrollBottom :: JS.JSString -> IO()
180-
#endif
181-
182-
monitorNodes= onBrowser $ do
183-
local . render $ rawHtml $ do
184-
h1 "Nodes connected"
185-
div ! atr (fs "id") (fs "nodes") $ noHtml
186-
187-
nodes <- atRemote . local . single $ sample getNodes 1000000
188-
189-
local . render . at (fs "#nodes") Insert . rawHtml $
190-
table $ mconcat[tr $ td h >> td p >> td s | Node h p _ s <- nodes]
191-
empty
141+
142+
sendMessages = do
143+
144+
let msg = fs "messages" -- <- local genNewId
145+
let entry= boxCell msg ! size (fs "60")
146+
(nick,text) <- local . render $ (,) <$> getString (Just "anonymous") ! size (fs "10")
147+
<*> mk entry Nothing `fire` OnChange
148+
<** inputSubmit "send"
149+
<++ br
150+
local $ entry .= ""
151+
guard (not $ null text)
152+
153+
atRemote $ do
154+
node <- local getMyNode
155+
clustered $ local $ putMailbox (showPrompt nick node ++ text ) >> empty :: Cloud ()
156+
empty
157+
158+
where
159+
fs= fromString
160+
161+
showPrompt u (Node h p _ _)= u ++ "@" ++ h ++ ":" ++ show p ++ "> "
162+
163+
waitMessages chatbox = do
164+
165+
resp <- atRemote . local $ do
166+
labelState $ "getMailbox"
167+
r <- single getMailbox
168+
return r
169+
-- wait in the server for messages
170+
171+
local . render . at (fs "#" <> chatbox) Append $ rawHtml $ do
172+
p (resp :: String) -- display the response
173+
#ifdef ghcjs_HOST_OS
174+
liftIO $ scrollBottom $ fs "chatbox"
175+
176+
177+
foreign import javascript unsafe
178+
"var el= document.getElementById($1);el.scrollTop= el.scrollHeight"
179+
scrollBottom :: JS.JSString -> IO()
180+
#endif
181+
182+
monitorNodes= onBrowser $ do
183+
local . render $ rawHtml $ do
184+
h1 "Nodes connected"
185+
div ! atr (fs "id") (fs "nodes") $ noHtml
186+
187+
nodes <- atRemote . local . single $ sample getNodes 1000000
188+
189+
local . render . at (fs "#nodes") Insert . rawHtml $
190+
table $ mconcat[tr $ td h >> td p >> td s | Node h p _ s <- nodes]
191+
empty

‎distributedKeyValueServant

23.1 MB
Binary file not shown.

‎distributedKeyValueServant.hi

16.4 KB
Binary file not shown.

‎distributedKeyValueServant.hs

100644100755
+35-22
Original file line numberDiff line numberDiff line change
@@ -22,11 +22,11 @@ import Control.Monad.IO.Class
2222
import Control.Monad.State
2323
import Control.Monad.Trans.Except
2424
import Data.Aeson
25-
import Data.ByteString.Lazy as DBL hiding (elemIndex, length)
25+
import Data.ByteString.Lazy as DBL hiding (elemIndex, length,empty)
2626
import Data.Hashable
2727
import Data.IORef
2828
import Data.List
29-
import Data.Map as M
29+
import qualified Data.Map as M
3030
import Data.Maybe
3131
import qualified Data.Text as DT
3232
import Data.Typeable
@@ -36,7 +36,7 @@ import Data.UUID.V4
3636
import GHC.Generics
3737
import Network.Wai
3838
import Network.Wai.Handler.Warp hiding (run)
39-
import Servant hiding (Handler)
39+
import Servant.Server hiding (Handler)
4040
import Servant.API
4141
import System.IO
4242
import System.IO.Unsafe
@@ -47,6 +47,7 @@ import Transient.Move.Utils
4747
import Data.Dynamic
4848
import Control.Concurrent.STM.TChan
4949
import Control.Concurrent.STM
50+
import Servant.Server.Internal.Handler
5051

5152
newtype VendorId = VendorId UUID
5253
deriving(Eq, Ord, Read, Show,FromHttpApiData)
@@ -80,22 +81,26 @@ mkApp :: IO Application
8081
mkApp = return $ serve itemApi server
8182

8283
server :: Server ItemApi
83-
server =
84-
getItems :<|>
85-
getItemById
84+
server = getItems :<|> getItemById
8685

87-
type Handler = ExceptT ServantErr IO
86+
-- type Handler = ExceptT ServantErr IO
8887

8988
getItems :: Handler [Item]
9089
getItems = return [exampleItem]
9190

9291
getItemById :: ItemId -> VendorId -> Handler Item
93-
getItemById i v = query i v
92+
-- getItemById i v = query i v
93+
getItemById i v= do
94+
Just hand <- liftIO $ readIORef rhandler
95+
hand (i, v)
96+
97+
rhandler = unsafePerformIO $ newIORef Nothing
98+
setHandlerQuery f= writeIORef rhandler $ Just f
9499

95-
query i v= liftIO $ do
96-
tv <- newMVar $ toDyn (i, v)
97-
atomically $ writeTChan rquery tv
98-
takeMVar tv >>= return . fromJust . fromDynamic
100+
--query i v= liftIO $ do
101+
-- tv <- newMVar $ toDyn (i, v)
102+
-- atomically $ writeTChan rquery tv
103+
-- takeMVar tv >>= return . fromJust . fromDynamic
99104

100105

101106

@@ -115,7 +120,7 @@ instance ToJSON Item
115120
instance FromJSON Item
116121

117122

118-
hashmap :: Cloud (Map (VendorId, ItemId) Int)
123+
hashmap :: Cloud (M.Map (VendorId, ItemId) Int)
119124
hashmap = onAll (return $ M.fromList [((VendorId . fromJust $ fromText "bacd5f20-8b46-4790-b93f-73c47b8def72", ItemId . fromJust $ fromText "db6af727-1007-4cae-bd24-f653b1c6e94e"), 10)])
120125
-- ((VendorId . fromJust $ fromText "8f833732-a199-4a74-aa55-a6cd7b19ab66", ItemId . fromJust $ fromText "d6693304-3849-4e69-ae31-1421ea320de4"), 20)])
121126

@@ -128,20 +133,24 @@ rquery= unsafePerformIO $ newTChanIO
128133

129134

130135
main :: IO ()
131-
main = keep' $ async run <|> initNode (inputNodes <|> cluster)
136+
main = do
137+
keep' $ (async run >> empty) <|> initNode (inputNodes <|> cluster)
138+
return ()
132139

133140
cluster= do
134141

135-
-- lliftIO $ print $ length nodes
136-
137-
tv <- onAll . waitEvents . atomically $ readTChan rquery
138-
(i@(ItemId iid), v@(VendorId vid)) <- localIO $ do
139-
d <- takeMVar tv
140-
return $ fromJust $ fromDynamic d
142+
-- localIO $ print $ length nodes
141143

144+
-- tv <- onAll . waitEvents . atomically $ readTChan rquery
145+
--(i@(ItemId iid), v@(VendorId vid)) <- localIO $ do
146+
-- d <- takeMVar tv
147+
-- return $ fromJust $ fromDynamic d
148+
149+
tv <- onAll $ liftIO newEmptyMVar
150+
(i@(ItemId iid), v@(VendorId vid)) <- local $ react setHandlerQuery (takeMVar tv)
142151
let h = abs $ hash $ toString iid ++ toString vid
143152

144-
onAll $ liftIO $ print $ "hash" ++ show h
153+
localIO $ print $ "hash" ++ show h
145154

146155
node <- local $ do
147156
nodes <- getNodes
@@ -156,6 +165,10 @@ cluster= do
156165
return () !> ("accessing", (v,i), "map=",m)
157166
return $ M.lookup (v, i) m
158167

159-
localIO $ putMVar tv $ toDyn $ case quant of
168+
--localIO $ putMVar tv $ toDyn $ case quant of
169+
-- Just q -> (Item q "Item 1")
170+
-- Nothing -> (Item 0 "Item Unknown")
171+
172+
return $ case quant of
160173
Just q -> (Item q "Item 1")
161174
Nothing -> (Item 0 "Item Unknown")

‎distributedKeyValueServant.o

156 KB
Binary file not shown.

‎hasrocket.hs

100644100755
File mode changed.

‎restChat.hs

100644100755
File mode changed.

0 commit comments

Comments
 (0)