Browse Source

Typeable constraint added runCloud work with keep

addedsingle
Alberto G. Corona 5 years ago
parent
commit
dc0189b1cd
  1. 10
      examples/distributedApps.hs
  2. 4
      src/Transient/MapReduce.hs
  3. 18
      src/Transient/Move.hs
  4. 2
      src/Transient/Move/Utils.hs
  5. 161
      tests/Test.hs
  6. 53
      tests/streamMonad.hs
  7. 4
      transient-universe.cabal

10
examples/distributedApps.hs

@ -79,15 +79,16 @@ chat= onBrowser $ do
let chatMessages= fs "chatMessages"
local . render . rawHtml $ div ! id (fs "chatbox")
! style (fs "margin-top:1cm;overflow: auto;height: 200px;background-color: #FFCC99; max-height: 200px;")
$ noHtml -- create the chat box
local . render . rawHtml $
div ! id (fs "chatbox")
! style (fs $"margin-top:1cm;overflow: auto;height: 200px;"
++ "background-color: #FFCC99; max-height: 200px;")
$ noHtml -- create the chat box
sendMessages chatMessages <|> waitMessages chatMessages
where
sendMessages chatMessages = do
-- local $ initFinish >> return ()
let entry= boxCell (fs "msg") ! atr "size" (fs "90")
text <- local . render $ (mk entry Nothing ) `fire` OnChange
<** inputSubmit "send"
@ -110,6 +111,7 @@ chat= onBrowser $ do
#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()

4
src/Transient/MapReduce.hs

@ -230,13 +230,11 @@ reduce red (dds@(DDS mx))= loggedc $ do
nsent <- onAll $ liftIO $ newMVar 0
(i,folded) <- local $ parallelize foldthem (M.assocs mpairs) -- <|> return Nothing
(i,folded) <- local $ parallelize foldthem (M.assocs mpairs)
n <- lliftIO $ modifyMVar nsent $ \r -> return (r+1, r+1)
runAt (nodes !! i) $ local $ putMailbox box $ Reduce folded
when (n == length) $ sendEnd nodes
where

18
src/Transient/Move.hs

@ -179,11 +179,11 @@ local = Cloud . logged
-- #ifndef ghcjs_HOST_OS
-- | run the cloud computation.
runCloudIO :: Cloud a -> IO a
runCloudIO :: Typeable a => Cloud a -> IO a
runCloudIO (Cloud mx)= keep mx
-- | run the cloud computation with no console input
runCloudIO' :: Cloud a -> IO a
runCloudIO' :: Typeable a => Cloud a -> IO a
runCloudIO' (Cloud mx)= keep' mx
-- #endif
@ -490,8 +490,20 @@ addPrefix= Transient $ do
return $ Just ()
-- | translates computations back and forth
-- | translates computations back and forth between two nodes
-- reusing a connection opened by `wormhole`
--
-- each teleport transport to the other node what is new in the log since the
-- last teleport
--
-- It is used trough other primitives like `runAt` which involves two teleports:
--
-- runAt node= wormhole node $ loggedc $ do
-- > teleport
-- > r <- Cloud $ runCloud proc <** setData WasRemote
-- > teleport
-- > return r
teleport :: Cloud ()
teleport = do
local $ Transient $ do

2
src/Transient/Move/Utils.hs

@ -75,7 +75,7 @@ inputNodes= do
port <- local $ input (const True) "port? "
connectit <- local $ input (\x -> x=="y" || x== "n") "connect to the node to get his list of nodes?"
connectit <- local $ input (\x -> x=="y" || x== "n") "connect to the node to interchange nodes lists?"
nnode <- localIO $ createNode host port
if connectit== "y" then connect' nnode
else local $ do

161
tests/Test.hs

@ -1,53 +1,134 @@
import Control.Concurrent.Async
import Control.Concurrent
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
newtype Stream a = Stream{ runStream :: IO [Async a]}
instance Functor Stream where
fmap f (Stream mxs) = Stream $ do
xs <- mxs
return [fmap f x | x <- xs]
module Main where
instance Applicative Stream where
pure x= Stream $ do
z <- async $ return x
return [z]
import Control.Applicative
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Data.Aeson
import Data.ByteString.Lazy as DBL hiding (elemIndex, length)
import Data.Hashable
import Data.IORef
import Data.List
import Data.Map as M
import Data.Maybe
import qualified Data.Text as DT
import Data.Typeable
import Data.UUID
import Data.UUID.Aeson
import Data.UUID.V4
import GHC.Generics
import Network.Wai
import Network.Wai.Handler.Warp hiding (run)
import Servant hiding (Handler)
import Servant.API
import System.IO
import System.IO.Unsafe
import Transient.Base
import Transient.Move
import Transient.Move.Utils
import Transient.Internals
(Stream mfs) <*> (Stream mas) = Stream $do
as <- mas
fs <- mfs
sequence [
async $ ( wait f) <*> ( wait a)
| f <- fs, a <- as]
newtype VendorId = VendorId UUID
deriving(Eq, Ord, FromHttpApiData)
instance Monad Stream where
return = pure
(Stream mxs) >>= f = Stream $ do
xs <- mxs
rs <- mapM wait xs
rr <- sequence [ runStream $ f r | r <- rs]
return $ concat rr
newtype ItemId = ItemId UUID
deriving(Eq, Ord, FromHttpApiData)
type ItemApi =
"item" :> Get '[JSON] [Item] :<|>
"item" :> Capture "itemId" ItemId :> Capture "vendorId" VendorId :> Get '[JSON] Item
itemApi :: Proxy ItemApi
itemApi = Proxy
stream :: [IO a] -> Stream a
stream ioa= Stream $ mapM async ioa
-- * app
waitStream :: Stream a -> IO [a]
waitStream (Stream mxs)= do
xs <- mxs
mapM wait xs
instance FromHttpApiData UUID where
parseUrlPiece t = case fromText t of
Just u -> Right u
Nothing -> Left "Invalid UUID"
run :: IO ()
run = do
let port = 3000
settings =
setPort port $
setBeforeMainLoop (hPutStrLn stderr ("listening on port " ++ show port)) defaultSettings
runSettings settings =<< mkApp
main= do
r <- waitStream $ stream $ map return [1..10]
print r
r <- waitStream $ do
x <- stream $ map (\x -> do threadDelay 1000000; return x) [1..100]
return $ 2 * x
print r
mkApp :: IO Application
mkApp = return $ serve itemApi server
where
fact 0 = 1
fact n= n * fact (n -1)
server :: Server ItemApi
server =
getItems :<|>
getItemById
type Handler = ExceptT ServantErr IO
getItems :: Handler [Item]
getItems = return [exampleItem]
getItemById :: ItemId -> VendorId -> Handler Item
getItemById i@(ItemId iid) v@(VendorId vid) = do
let h = hash $ toString iid ++ toString vid
liftIO $ runCloudIO $ do
local $ liftIO (readIORef ref) >>= \dat -> modify s{mfData= dat}
nodes <- onAll getNodes
let num = h `rem` length nodes
let node = sort nodes !! num
m <- hashmap
quant <- runAt node $ return $ fromJust $ M.lookup (v, i) m
return $ Item quant "Item 1"
exampleItem :: Item
exampleItem = Item 0 "example item"
-- * item
data Item
= Item {
itemId :: Int,
itemText :: String
}
deriving (Eq, Show, Generic)
instance ToJSON Item
instance FromJSON Item
--connectionHandle = connect "localhost" 28015 Nothing
hashmap :: Cloud (Map (VendorId, ItemId) Int)
hashmap = onAll (return $ M.fromList [((VendorId . fromJust $ fromText "bacd5f20-8b46-4790-b93f-73c47b8def72", ItemId . fromJust $ fromText "db6af727-1007-4cae-bd24-f653b1c6e94e"), 10),
((VendorId . fromJust $ fromText "8f833732-a199-4a74-aa55-a6cd7b19ab66", ItemId . fromJust $ fromText "d6693304-3849-4e69-ae31-1421ea320de4"), 10)])
ref= unsafePerformIO $ newIORef (error "state should have been written here!")
main :: IO ()
main = do
runCloudIO' $ do
seed <- lliftIO $ createNode "localhost" 8000
node <- lliftIO $ createNode "localhost" 8000
connect node seed
local $ gets mfData >>= liftIO . writeIORef ref
nodes <- onAll getNodes
lliftIO $ print $ length nodes
m <- hashmap
-- let num = fromJust $ elemIndex node (sort nodes)
-- quant <- runAt (nodes !! num) $ return $ M.lookup num m
-- lliftIO $ print quant
(do i <- local $ getMailbox "mailbox" ; lliftIO $ print (i::Int))
<|> (do clustered $ local $ putMailbox "mailbox" (123::Int) ; Control.Applicative.empty)
<|> lliftIO run

53
tests/streamMonad.hs

@ -0,0 +1,53 @@
import Control.Concurrent.Async
import Control.Concurrent
newtype Stream a = Stream{ runStream :: IO [Async a]}
instance Functor Stream where
fmap f (Stream mxs) = Stream $ do
xs <- mxs
return [fmap f x | x <- xs]
instance Applicative Stream where
pure x= Stream $ do
z <- async $ return x
return [z]
(Stream mfs) <*> (Stream mas) = Stream $do
as <- mas
fs <- mfs
sequence [
async $ ( wait f) <*> ( wait a)
| f <- fs, a <- as]
instance Monad Stream where
return = pure
(Stream mxs) >>= f = Stream $ do
xs <- mxs
rs <- mapM wait xs
rr <- sequence [ runStream $ f r | r <- rs]
return $ concat rr
stream :: [IO a] -> Stream a
stream ioa= Stream $ mapM async ioa
waitStream :: Stream a -> IO [a]
waitStream (Stream mxs)= do
xs <- mxs
mapM wait xs
main= do
r <- waitStream $ stream $ map return [1..10]
print r
r <- waitStream $ do
x <- stream $ map (\x -> do threadDelay 1000000; return x) [1..100]
return $ 2 * x
print r
where
fact 0 = 1
fact n= n * fact (n -1)

4
transient-universe.cabal

@ -1,5 +1,5 @@
name: transient-universe
version: 0.3.3
version: 0.3.4
cabal-version: >=1.10
build-type: Simple
license: MIT
@ -56,7 +56,7 @@ library
text -any,
time -any,
transformers -any,
transient >=0.4.2
transient >=0.4.4
default-language: Haskell2010
hs-source-dirs: src .

Loading…
Cancel
Save