Browse Source

Merge pull request #14 from geraldus/hot-fix

Some fix ups
addedsingle
Alberto 5 years ago
committed by GitHub
parent
commit
da71834ee1
  1. 9
      bash.exe.stackdump
  2. 109
      src/Transient/Move.hs
  3. BIN
      src/Transient/Move/Services/CUsersmagocoalAppDataRoamingcabalbin
  4. 4
      stack-ghcjs.yaml
  5. 4
      stack.yaml
  6. 9
      stack.yaml1
  7. 17
      transient-universe.cabal

9
bash.exe.stackdump

@ -1,9 +0,0 @@
Stack trace:
Frame Function Args
000005FC358 0018007198E (001802596AD, 0018020EE46, 000005FC358, 000005FB250)
000005FC358 00180046E22 (000005FC2B8, 00000000000, 00000000000, 00000000000)
000005FC358 00180046E62 (00180259769, 000005FC208, 000005FC358, 00000000000)
000005FC358 001800BCD0F (00000000000, 00000000000, 00000000000, 00000000000)
000005FC358 001800BCF2F (000005FC380, 00000000000, 00000000000, 00000000000)
000005FC400 001800BE1CA (000005FC380, 00000000000, 00000000000, 00000000000)
End of stack trace

109
src/Transient/Move.hs

@ -10,9 +10,15 @@
--
-- | see <https://www.fpcomplete.com/user/agocorona/moving-haskell-processes-between-nodes-transient-effects-iv>
-----------------------------------------------------------------------------
{-# LANGUAGE DeriveDataTypeable , ExistentialQuantification, OverloadedStrings
,ScopedTypeVariables, StandaloneDeriving, RecordWildCards, FlexibleContexts, CPP
,GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
module Transient.Move(
Cloud(..),runCloudIO, runCloudIO',local,onAll,lazy, loggedc, lliftIO,localIO,
@ -123,6 +129,8 @@ import Data.Dynamic
import Data.String
type EventMapRef = IORef (M.Map T.Text (EVar Dynamic))
#ifdef ghcjs_HOST_OS
type HostName = String
newtype PortID = PortNumber Int deriving (Read, Show, Eq, Typeable)
@ -179,12 +187,12 @@ local = Cloud . logged
-- #ifndef ghcjs_HOST_OS
-- | run the cloud computation.
runCloudIO :: Typeable a => Cloud a -> IO a
runCloudIO (Cloud mx)= keep mx
runCloudIO :: Typeable a => Cloud a -> IO a
runCloudIO (Cloud mx) = keep mx
-- | run the cloud computation with no console input
runCloudIO' :: Typeable a => Cloud a -> IO a
runCloudIO' (Cloud mx)= keep' mx
runCloudIO' :: Typeable a => Cloud a -> IO a
runCloudIO' (Cloud mx) = keep' mx
-- #endif
@ -593,66 +601,53 @@ liftIOF :: IO b -> TransIO b
liftIOF mx=do
ex <- liftIO $ (mx >>= return . Right) `catch` (\(e :: SomeException) -> return $ Left e)
case ex of
Left e -> finish $ Just e
Right x -> return x
Left e -> finish (Just e)
mconnect :: Node -> TransIO Connection
mconnect node@(Node _ _ _ _ )= do
mconnect node@Node{} = do
nodes <- getNodes -- !> ("connecting node", node)
let fnode = filter (==node) nodes
case fnode of
[] -> addNodes [node] >> mconnect node
[Node host port pool _] -> do
plist <- liftIO $ readMVar pool
case plist of
handle:_ -> do
delData $ Closure undefined
return handle -- !> ("REUSED!", node)
_ -> do
-- liftIO $ putStr "*****CONNECTING NODE: " >> print node
my <- getMyNode
-- liftIO $ putStr "OPENING CONNECTION WITH :" >> print port
Connection{comEvent= ev} <- getSData <|> error "connect: listen not set for this node"
Node host port pool _:_ -> do
plist <- liftIO $ readMVar pool
case plist of
handle':_ -> do
delData (Closure undefined)
return handle' -- !> ("REUSED!", node)
_ -> do
my <- getMyNode
Connection { comEvent = ev } <-
getSData <|> error "connect: listen not set for this node"
conn <- getConnection my host ev port
liftIO . modifyMVar_ pool $ \cs -> return (conn:cs)
putMailbox "connections" (conn,node)
delData $ Closure undefined
return conn
where
u = undefined
getConnection :: Node -> HostName -> EventMapRef -> Int ->TransIO Connection
#ifndef ghcjs_HOST_OS
conn <- liftIOF $ do
let size=8192
sock <- connectTo' size host $ PortNumber $ fromIntegral port
-- !> ("CONNECTING ",port)
conn <- defConnection >>= \c -> return c{myNode=my,comEvent= ev,connData= Just $ Node2Node u sock (error $ "addr: outgoing connection")}
SBS.send sock "CLOS a b\n\n" -- !> "sending CLOS"
return conn
getConnection n h ev p = liftIOF $
do let size = 8192
sock <- connectTo' size h (PortNumber $ fromIntegral p)
conn <- defConnection >>= \c ->
return c { myNode = n
, comEvent = ev
, connData = Just $
Node2Node u sock (error "addr: outgoing connection")
}
SBS.send sock "CLOS a b\n\n"
return conn
#else
conn <- do
ws <- connectToWS host $ PortNumber $ fromIntegral port
conn <- defConnection >>= \c -> return c{comEvent= ev,connData= Just $ Web2Node ws}
return conn -- !> ("websocker CONNECION")
getConnection _ h ev p =
do ws <- connectToWS h (PortNumber $ fromIntegral p)
defConnection >>= \c ->
return c { comEvent = ev
, connData = Just $ Web2Node ws
}
#endif
liftIO $ modifyMVar_ pool $ \plist -> return $ conn:plist
putMailbox "connections" (conn,node)
delData $ Closure undefined
return conn
where u= undefined
-- mconnect _ = empty

BIN
src/Transient/Move/Services/CUsersmagocoalAppDataRoamingcabalbin

Binary file not shown.

4
stack-ghcjs.yaml

@ -1,9 +1,9 @@
resolver: lts-6.6
resolver: lts-6.16
packages:
- '.'
- location:
git: https://github.com/agocorona/transient.git
commit: 8d44c8fee7ad10e76385dc68898af09c55819846
commit: b06645a46462e68a2712de8ecd0d8f325b07a520
extra-dep: true
extra-package-dbs: []
flags: {}

4
stack.yaml

@ -1,9 +1,9 @@
resolver: lts-6.6
resolver: lts-6.16
packages:
- '.'
- location:
git: https://github.com/agocorona/transient.git
commit: 8d44c8fee7ad10e76385dc68898af09c55819846
commit: b06645a46462e68a2712de8ecd0d8f325b07a520
extra-dep: true
extra-package-dbs: []
flags: {}

9
stack.yaml1

@ -1,9 +0,0 @@
resolver: lts-6.6
packages:
- '.'
- location:
git: https://github.com/agocorona/transient.git
commit: 5d67ec5b47166110abc7d1a3e1d3618aa5b3f25e
extra-dep: true
extra-package-dbs: []
flags: {}

17
transient-universe.cabal

@ -1,5 +1,5 @@
name: transient-universe
version: 0.3.4
version: 0.3.5
cabal-version: >=1.10
build-type: Simple
license: MIT
@ -61,14 +61,13 @@ library
hs-source-dirs: src .
executable monitorService
if !impl(ghcjs >=0.1)
main-is : MonitorService.hs
build-depends: base >4 && <5, transient, transient-universe, transformers
executable monitorService
if !impl(ghcjs >=0.1)
main-is: MonitorService.hs
build-depends: base >4 && <5, transient >=0.4.4, transient-universe, transformers
default-language: Haskell2010
ghc-options: -threaded -rtsopts
hs-source-dirs: src/Transient/Move/Services
else
main-is : void.hs
build-depends: base
else
main-is: void.hs
build-depends: base
Loading…
Cancel
Save