Initial commit

.gitignore

@@ -0,0 +1,14 @@
+tags
+TAGS
+dist/
+\#*#
+*~
+*.aux
+*.hp
+*.hi
+*.o
+*.prof
+*.ps
+*.swp
+cabal-dev
+.DS_Store

LICENSE

@@ -0,0 +1,31 @@
+Copyright Parallel Scientific 2012
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of the author nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+

README.md

@@ -0,0 +1,15 @@
+Cloud Haskell Global
+====================
+
+This repository holds a library of useful tools for distributed
+computing, intended for use with [Cloud Haskell][1]. This library
+is based heavily on the global module from Erlang's standard library.
+
+In particular, it offers
+
+* Simple consistent cluster management
+* Distributed locking
+* Distributed process registration
+* Synchronous safe remote procedure calls
+
+[1]: https://github.com/haskell-distributed/distributed-process

distributed-process-global.cabal

@@ -0,0 +1,75 @@
+Name:          distributed-process-global
+Version:       0.1.0.0
+Cabal-Version: >=1.8
+Build-Type:    Simple
+License:       BSD3
+License-File:  LICENSE
+Copyright:     Parallel Scientific, Inc
+Author:        Jeff Epstein <[email protected]>
+Maintainer:    Jeff Epstein <[email protected]>
+Stability:     experimental
+Homepage:      http://github.com/jepst/distributed-process-global
+Bug-Reports:   mailto:[email protected]
+Synopsis:      Distributed locks, RPC, and global registration for Cloud Haskell
+Description:   A port of Erlang's global module. Provides services for
+               synchronization between nodes. In particular, we provide the notion
+               of cluster, a fully-connected network of nodes that can synchronously
+               share data. Nodes entering the cluster are also added synchronously, so
+               that all members have a consistent view. Distributed locks and distributed
+               process registration are also available. Finally, we provide a version of
+               reliable RPC, analogous to Erlang's gen_server.
+Tested-With:   GHC==7.4.2
+Category:      Control 
+
+Source-Repository head
+  Type:     git
+  Location: http://github.com/jepst/distributed-process-global
+
+Library
+  Build-Depends:     base >= 4.4 && < 5,
+                     binary >= 0.5 && < 0.7,
+                     network-transport >= 0.3 && < 0.4,
+                     stm >= 2.3 && < 2.5,
+                     transformers >= 0.2 && < 0.4,
+                     mtl >= 2.0 && < 2.2,
+                     data-accessor >= 0.2 && < 0.3,
+                     bytestring >= 0.9 && < 0.11,
+                     containers >= 0.4 && < 0.6,
+                     old-locale >= 1.0 && < 1.1,
+                     time >= 1.2 && < 1.5,
+                     random >= 1.0 && < 1.1,
+                     ghc-prim >= 0.2 && < 0.4,
+                     distributed-static >= 0.2 && < 0.3,
+                     rank1dynamic >= 0.1 && < 0.2,
+                     syb >= 0.3 && < 0.4,
+                     distributed-process >= 0.4.1
+  Exposed-modules:   Control.Distributed.Process.Global,
+                     Control.Distributed.Process.Global.Call,
+                     Control.Distributed.Process.Global.Types,
+                     Control.Distributed.Process.Global.Server,
+                     Control.Distributed.Process.Global.Merge,
+                     Control.Distributed.Process.Global.Util
+  Extensions:        
+  ghc-options:       -Wall
+  HS-Source-Dirs:    src
+
+Test-Suite TestGlobal
+  Type:              exitcode-stdio-1.0
+  Main-Is:           TestGlobal.hs
+  Build-Depends:     base >= 4.4 && < 5,
+                     random >= 1.0 && < 1.1,
+                     ansi-terminal >= 0.5 && < 0.6,
+                     distributed-static >= 0.2 && < 0.3,
+                     distributed-process >= 0.4.1,
+                     network-transport >= 0.3 && < 0.4,
+                     network-transport-tcp >= 0.3 && < 0.4,
+                     bytestring >= 0.9 && < 0.11,
+                     network >= 2.3 && < 2.5,
+                     HUnit >= 1.2 && < 1.3,
+                     test-framework >= 0.6 && < 0.7,
+                     test-framework-hunit >= 0.2 && < 0.3,
+                     distributed-process-global
+  Extensions:        
+  ghc-options:       -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind 
+  HS-Source-Dirs:    tests 
+

examples/CounterExample.hs

@@ -0,0 +1,72 @@
+module Main where
+
+-- This program provides a version of the venerable counter server example, wherein
+-- a central server process stores a value that can be queried and updated remotely.
+-- We use Global's RPC mechanism, though, which safely handles cases when the server
+-- dies and and automatically provides a response, with no explicit send. It also
+-- allows user functions to find the PID of process by name only.
+
+import Control.Distributed.Process
+import Control.Distributed.Process.Node
+import Control.Distributed.Process.Serializable (Serializable)
+import Control.Distributed.Process.Global
+import Network.Transport.TCP (createTransport, defaultTCPParameters)
+import Control.Distributed.Process.Global.Util (ensureResult)
+import Control.Concurrent (threadDelay)
+import Control.Monad (replicateM_)
+
+myRemoteTable :: RemoteTable
+myRemoteTable = Control.Distributed.Process.Global.__remoteTable initRemoteTable
+
+-- | Our server. Accepts messages as strings for simplicity.
+getCounterPid :: Process ProcessId
+getCounterPid = whereisOrStart "counter" (counter 0)
+  where counter :: Int -> Process a
+        counter value =
+          receiveWait
+           [
+             callResponse (\msg ->
+               case msg of
+                 "query" -> return (value,value)
+                 "increment" -> return (value,value+1)
+                 "reset" -> return (value,0))
+           ] >>= counter
+
+-- | Queries current value of this node's counter, doesn't change it
+queryCounter :: TagPool -> Process Int
+queryCounter tag = counterMessage tag "query"
+
+-- | Increments counter, returns old value
+incrementCounter :: TagPool -> Process Int
+incrementCounter tag = counterMessage tag "increment"
+
+-- | Resets counter to zero, returns old value
+resetCounter :: TagPool -> Process Int
+resetCounter tag = counterMessage tag "reset"
+
+counterMessage :: (Serializable a, Serializable b) => TagPool -> a -> Process b
+counterMessage tag msg =
+  do tag1 <- getTag tag
+     counterpid <- getCounterPid
+     ensureResult $ callAt counterpid msg tag1
+
+test :: Process ()
+test = 
+  do tag <- newTagPool
+     queryCounter tag >>= explain "Querying counter"
+     incrementCounter tag >>= explain "Incrementing counter"
+     incrementCounter tag >>= explain "Incrementing counter again"
+     queryCounter tag >>= explain "Querying again"
+     replicateM_ 500 (incrementCounter tag) >> liftIO (putStrLn "Incrementing a lot")
+     resetCounter tag >>= explain "Resetting counter"
+     queryCounter tag >>= explain "Querying again"
+   where explain txt num =
+              liftIO $ putStrLn $ txt ++": "++show num
+
+main :: IO ()
+main =
+  do Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
+     node <- newLocalNode transport myRemoteTable
+     runProcess node test
+     threadDelay 1000000
+

src/Control/Distributed/Process/Global.hs

@@ -0,0 +1,75 @@
+module Control.Distributed.Process.Global 
+  ( 
+    -- * Cluster operations
+    addNode
+
+  , ResolutionMethod(..)
+  , ResolutionNotification(..)
+  , globalWhereis
+  , globalRegister
+  , globalUnregister
+  , globalReregister
+
+  -- * Locks
+  , GlobalNameServer
+  , LockName
+  , LockRequesterId
+  , LockId
+  , queryLock
+  , setLockKnown
+  , setLock
+  , setLockOpt
+  , delLock
+  , transKnown
+  , getKnown
+  , getKnownNameServers
+
+  -- * Tags
+  , Tag
+  , TagPool
+  , newTagPool
+  , getTag
+
+  -- * Timeouts
+  , Timeout
+  , infiniteWait
+  , noWait
+
+  -- * Procedure calls
+  , callAt
+  , callTimeout
+  , multicall
+  , callResponse
+  , callResponseIf
+  , callResponseDefer
+  , callResponseDeferIf
+  , callForward
+  , callResponseAsync
+
+  -- * Server calls
+  , whereisOrStart
+  , whereisOrStartRemote
+
+  -- * Remote call table
+  , __remoteTable
+  ) where
+
+import Control.Distributed.Process
+import Control.Distributed.Process.Global.Types
+import Control.Distributed.Process.Global.Call
+import Control.Distributed.Process.Global.Util hiding (__remoteTable)
+import qualified Control.Distributed.Process.Global.Util (__remoteTable)
+import Control.Distributed.Process.Global.Server hiding (__remoteTable)
+import qualified Control.Distributed.Process.Global.Server (__remoteTable)
+import Control.Distributed.Process.Global.Merge 
+
+----------------------------------------------
+-- * Remote table
+----------------------------------------------
+
+__remoteTable :: RemoteTable -> RemoteTable
+__remoteTable = 
+   Control.Distributed.Process.Global.Server.__remoteTable .
+   Control.Distributed.Process.Global.Util.__remoteTable
+
+