Browse Source

Merge pull request #18 from geraldus/refactoring-17-08-16

Some refactoring & tools update
addedsingle
Артур Файзрахманов 5 years ago
committed by GitHub
parent
commit
2eb52db8b0
  1. 1
      .gitignore
  2. 1
      .travis.yml
  3. 0
      app/client/Transient/Move/Services/MonitorService.hs
  4. 0
      app/server/Transient/Move/Services/MonitorService.hs
  5. 9
      bash.exe.stackdump
  6. 135
      src/Transient/Move.hs
  7. BIN
      src/Transient/Move/Services/CUsersmagocoalAppDataRoamingcabalbin
  8. 6
      stack-ghcjs.yaml
  9. 9
      stack.yaml1
  10. 10
      transient-universe.cabal

1
.gitignore

@ -50,3 +50,4 @@ tramp
*.key
_darcs
darcs*
/src/style.css

1
.travis.yml

@ -79,6 +79,7 @@ before_install:
# Using compiler above sets CC to an invalid value, so unset it
- unset CC
- export CASHER_TIME_OUT=600
- if [ $BUILD = "ghcjs" ]; then nvm install 6; fi
# We want to always allow newer versions of packages when building on GHC HEAD
- CABALARGS=""

0
src/client/Transient/Move/Services/MonitorService.hs → app/client/Transient/Move/Services/MonitorService.hs

0
src/server/Transient/Move/Services/MonitorService.hs → app/server/Transient/Move/Services/MonitorService.hs

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

135
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,10 @@ import Data.Dynamic
import Data.String
-- * Handful Aliases.
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 +189,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
@ -590,72 +600,57 @@ mclose (Connection _ (Just (Web2Node sconn)) _ _ blocked _ _)=
#endif
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
mconnect :: Node -> TransIO Connection
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"
liftIOF mx =
do ex <- liftIO $
fmap Right mx `catch` (\(e :: SomeException) -> return $ Left e)
case ex of
Right x -> return x
Left e -> finish (Just e)
mconnect :: Node -> TransIO Connection
mconnect node@Node{} =
do nodes <- getNodes
let fnode = filter (==node) nodes
case fnode of
[] -> addNodes [node] >> mconnect node
Node{..}:_ ->
do let pool = connection -- `connection` is a function of `Node`.
plist <- liftIO $ readMVar pool
conn <- case plist of
handle':_ -> return handle'
_ ->
do my <- getMyNode
Connection { comEvent = ev } <-
getSData <|> error "connect: listen not set for this node"
c <- getConnection my nodeHost ev nodePort
liftIO . modifyMVar_ pool $ \cs -> return (c:cs)
putMailbox "connections" (c, node)
return c
delData $ Closure undefined
return conn
where
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 s = 8192
u = undefined
sock <- connectTo' s 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
#ifndef ghcjs_HOST_OS

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

Binary file not shown.

6
stack-ghcjs.yaml

@ -8,10 +8,10 @@ packages:
extra-package-dbs: []
flags: {}
compiler: ghcjs-0.2.0.20160703_ghc-7.10.3
compiler: ghcjs-0.2.0.20160917_ghc-7.10.3
compiler-check: match-exact
setup-info:
ghcjs:
source:
ghcjs-0.2.0.20160703_ghc-7.10.3:
url: http://ghcjs.luite.com/master-20160703.tar.gz
ghcjs-0.2.0.20160917_ghc-7.10.3:
url: http://ghcjs.luite.com/master-20160917.tar.gz

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: {}

10
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
@ -13,8 +13,8 @@ description:
category: Control
author: Alberto G. Corona
extra-source-files: src/client/Transient/Move/Services/MonitorService.hs
src/server/Transient/Move/Services/MonitorService.hs
extra-source-files: app/client/Transient/Move/Services/MonitorService.hs
app/server/Transient/Move/Services/MonitorService.hs
source-repository head
type: git
@ -63,12 +63,12 @@ library
executable monitorService
build-depends: base >4 && <5
if !impl(ghcjs >=0.1)
hs-source-dirs: src/server/Transient/Move/Services
hs-source-dirs: app/server/Transient/Move/Services
build-depends: transformers
, transient >=0.4.4
, transient-universe
else
hs-source-dirs: src/client/Transient/Move/Services
hs-source-dirs: app/client/Transient/Move/Services
main-is: MonitorService.hs
default-language: Haskell2010
ghc-options: -threaded -rtsopts

Loading…
Cancel
Save