Permalink
Browse files

Moved projects out into separate repositories

The distributed-process library is pulled up to the 'top level' and
everything else has its own git repository now. See the README file
in https://github.com/haskell-distributed/repo-migration for more
details
  • Loading branch information...
1 parent a6dd115 commit 6a18c50b773d996edc8df51861abe2c5366301b8 @hyperthunk hyperthunk committed Feb 4, 2013
Showing with 61 additions and 14,405 deletions.
  1. +10 −0 .travis.yml
  2. 0 {distributed-process → }/ChangeLog
  3. 0 {network-transport → }/LICENSE
  4. +27 −0 Makefile
  5. +20 −34 README.md
  6. +4 −0 REPOS
  7. 0 {rank1dynamic → }/Setup.hs
  8. +0 −30 azure-service-api/LICENSE
  9. +0 −2 azure-service-api/Setup.hs
  10. +0 −44 azure-service-api/azure-service-api.cabal
  11. +0 −319 azure-service-api/src/Network/Azure/ServiceManagement.hs
  12. 0 {distributed-process → }/benchmarks/Channels.hs
  13. 0 {distributed-process → }/benchmarks/Latency.hs
  14. 0 {distributed-process → }/benchmarks/Spawns.hs
  15. 0 {distributed-process → }/benchmarks/Throughput.hs
  16. 0 {distributed-process → }/benchmarks/erlang/latency.erl
  17. 0 {distributed-process → }/benchmarks/erlang/throughput.erl
  18. 0 {distributed-process → }/benchmarks/remote/Latency.hs
  19. 0 {distributed-process → }/benchmarks/remote/Throughput.hs
  20. +0 −31 distributed-process-azure/LICENSE
  21. +0 −2 distributed-process-azure/Setup.hs
  22. +0 −49 distributed-process-azure/demos/Echo.hs
  23. +0 −74 distributed-process-azure/demos/Fib.hs
  24. +0 −85 distributed-process-azure/demos/Ping.hs
  25. +0 −102 distributed-process-azure/distributed-process-azure.cabal
  26. +0 −964 distributed-process-azure/src/Control/Distributed/Process/Backend/Azure.hs
  27. +0 −30 distributed-process-demos/LICENSE
  28. +0 −2 distributed-process-demos/Setup.hs
  29. +0 −154 distributed-process-demos/distributed-process-demos.cabal
  30. +0 −25 distributed-process-demos/src/Common/PrimeFactors.hs
  31. +0 −34 distributed-process-demos/src/MapReduce/CountWords.hs
  32. +0 −127 distributed-process-demos/src/MapReduce/KMeans.hs
  33. +0 −46 distributed-process-demos/src/MapReduce/MapReduce.hs
  34. +0 −60 distributed-process-demos/src/MapReduce/MonoDistrMapReduce.hs
  35. +0 −123 distributed-process-demos/src/MapReduce/PolyDistrMapReduce.hs
  36. +0 −75 distributed-process-demos/src/MapReduce/SimpleLocalnet.hs
  37. +0 −37 distributed-process-demos/src/MasterSlave/Azure.hs
  38. +0 −49 distributed-process-demos/src/MasterSlave/MasterSlave.hs
  39. +0 −25 distributed-process-demos/src/MasterSlave/SimpleLocalnet.hs
  40. +0 −37 distributed-process-demos/src/TypedWorkPushing/Azure.hs
  41. +0 −22 distributed-process-demos/src/TypedWorkPushing/SimpleLocalnet.hs
  42. +0 −41 distributed-process-demos/src/TypedWorkPushing/TypedWorkPushing.hs
  43. +0 −37 distributed-process-demos/src/WorkPushing/Azure.hs
  44. +0 −22 distributed-process-demos/src/WorkPushing/SimpleLocalnet.hs
  45. +0 −37 distributed-process-demos/src/WorkPushing/WorkPushing.hs
  46. +0 −22 distributed-process-demos/src/WorkStealing/SimpleLocalnet.hs
  47. +0 −54 distributed-process-demos/src/WorkStealing/WorkStealing.hs
  48. +0 −45 distributed-process-simplelocalnet/ChangeLog
  49. +0 −31 distributed-process-simplelocalnet/LICENSE
  50. +0 −2 distributed-process-simplelocalnet/Setup.hs
  51. +0 −70 distributed-process-simplelocalnet/distributed-process-simplelocalnet.cabal
  52. +0 −420 distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet.hs
  53. +0 −128 ...ocess-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet/Internal/Multicast.hs
  54. +0 −24 distributed-process-simplelocalnet/tests/TestSimpleLocalnet.hs
  55. +0 −11 distributed-process-simplelocalnet/tests/runTestSimpleLocalnet.hs
  56. 0 {distributed-process → }/distributed-process.cabal
  57. +0 −31 distributed-process/LICENSE
  58. +0 −2 distributed-process/Setup.hs
  59. +0 −16 distributed-static/ChangeLog
  60. +0 −30 distributed-static/LICENSE
  61. +0 −2 distributed-static/Setup.hs
  62. +0 −37 distributed-static/distributed-static.cabal
  63. +0 −453 distributed-static/src/Control/Distributed/Static.hs
  64. +0 −181 doc/InternalsTransportMulticast.txt
  65. +0 −81 doc/InternalsTransportTCP.txt
  66. BIN doc/NetworkTCP.png
  67. +0 −657 doc/NetworkTCP.svg
  68. BIN doc/semantics/CloudHaskellSemantics.pdf
  69. +0 −706 doc/semantics/CloudHaskellSemantics.tex
  70. +0 −11 doc/semantics/Makefile
  71. +0 −72 doc/semantics/references.bib
  72. +0 −24 doc/tutorial/tutorial-client.hs
  73. +0 −54 doc/tutorial/tutorial-server.hs
  74. +0 −11 install_all.sh
  75. +0 −30 network-transport-composed/LICENSE
  76. +0 −2 network-transport-composed/Setup.hs
  77. +0 −22 network-transport-composed/network-transport-composed.cabal
  78. +0 −181 network-transport-composed/src/Network/Transport/Composed.hs
  79. +0 −31 network-transport-inmemory/LICENSE
  80. +0 −2 network-transport-inmemory/Setup.hs
  81. +0 −44 network-transport-inmemory/network-transport-inmemory.cabal
  82. +0 −157 network-transport-inmemory/src/Network/Transport/Chan.hs
  83. +0 −8 network-transport-inmemory/tests/TestInMemory.hs
  84. +0 −7 network-transport-inmemory/tests/TestMulticastInMemory.hs
  85. +0 −30 network-transport-tcp/ChangeLog
  86. +0 −31 network-transport-tcp/LICENSE
  87. +0 −2 network-transport-tcp/Setup.hs
  88. +0 −16 network-transport-tcp/benchmarks/Headers.gnuplot
  89. +0 −16 network-transport-tcp/benchmarks/Indirection.gnuplot
  90. +0 −150 network-transport-tcp/benchmarks/JustPingC.c
  91. +0 −134 network-transport-tcp/benchmarks/JustPingCacheHeader.hs
  92. +0 −105 network-transport-tcp/benchmarks/JustPingHaskell.hs
  93. +0 −131 network-transport-tcp/benchmarks/JustPingOneRecv.hs
  94. +0 −127 network-transport-tcp/benchmarks/JustPingThroughChan.hs
  95. +0 −127 network-transport-tcp/benchmarks/JustPingThroughMVar.hs
  96. +0 −95 network-transport-tcp/benchmarks/JustPingTransport.hs
  97. +0 −151 network-transport-tcp/benchmarks/JustPingTwoSocketPairs.hs
  98. +0 −131 network-transport-tcp/benchmarks/JustPingWithHeader.hs
  99. +0 −55 network-transport-tcp/benchmarks/Makefile
  100. +0 −8 network-transport-tcp/benchmarks/NewTransport.gnuplot
  101. +0 −5 network-transport-tcp/benchmarks/cabal_macros.h
  102. +0 −88 network-transport-tcp/network-transport-tcp.cabal
  103. +0 −1,651 network-transport-tcp/src/Network/Transport/TCP.hs
  104. +0 −133 network-transport-tcp/src/Network/Transport/TCP/Internal.hs
  105. +0 −359 network-transport-tcp/src/Network/Transport/TCP/Mock/Socket.hs
  106. +0 −27 network-transport-tcp/src/Network/Transport/TCP/Mock/Socket/ByteString.hs
  107. +0 −848 network-transport-tcp/tests/TestQC.hs
  108. +0 −800 network-transport-tcp/tests/TestTCP.hs
  109. +0 −7 network-transport-tests/ChangeLog
  110. +0 −30 network-transport-tests/LICENSE
  111. +0 −2 network-transport-tests/Setup.hs
  112. +0 −36 network-transport-tests/network-transport-tests.cabal
  113. +0 −968 network-transport-tests/src/Network/Transport/Tests.hs
  114. +0 −112 network-transport-tests/src/Network/Transport/Tests/Auxiliary.hs
  115. +0 −72 network-transport-tests/src/Network/Transport/Tests/Multicast.hs
  116. +0 −210 network-transport-tests/src/Network/Transport/Tests/Traced.hs
  117. +0 −22 network-transport/ChangeLog
  118. +0 −2 network-transport/Setup.hs
  119. +0 −81 network-transport/network-transport.cabal
  120. +0 −273 network-transport/src/Network/Transport.hs
  121. +0 −157 network-transport/src/Network/Transport/Internal.hs
  122. +0 −33 network-transport/src/Network/Transport/Util.hs
  123. +0 −107 network-transport/tests/chat/ChatClient.hs
  124. +0 −28 network-transport/tests/chat/ChatServer.hs
  125. +0 −44 network-transport/tests/sumeuler/SumEulerMaster.hs
  126. +0 −52 network-transport/tests/sumeuler/SumEulerWorker.hs
  127. +0 −20 network-transport/tests/sumeuler/sumeuler.sh
  128. +0 −11 rank1dynamic/ChangeLog
  129. +0 −30 rank1dynamic/LICENSE
  130. +0 −28 rank1dynamic/rank1dynamic.cabal
  131. +0 −120 rank1dynamic/src/Data/Rank1Dynamic.hs
  132. +0 −362 rank1dynamic/src/Data/Rank1Typeable.hs
  133. 0 {distributed-process → }/src/Control/Distributed/Process.hs
  134. 0 {distributed-process → }/src/Control/Distributed/Process/Closure.hs
  135. 0 {distributed-process → }/src/Control/Distributed/Process/Internal/CQueue.hs
  136. 0 {distributed-process → }/src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs
  137. 0 {distributed-process → }/src/Control/Distributed/Process/Internal/Closure/TH.hs
  138. 0 {distributed-process → }/src/Control/Distributed/Process/Internal/Messaging.hs
  139. 0 {distributed-process → }/src/Control/Distributed/Process/Internal/Primitives.hs
  140. 0 {distributed-process → }/src/Control/Distributed/Process/Internal/StrictContainerAccessors.hs
  141. 0 {distributed-process → }/src/Control/Distributed/Process/Internal/StrictList.hs
  142. 0 {distributed-process → }/src/Control/Distributed/Process/Internal/StrictMVar.hs
  143. 0 {distributed-process → }/src/Control/Distributed/Process/Internal/Trace.hs
  144. 0 {distributed-process → }/src/Control/Distributed/Process/Internal/Types.hs
  145. 0 {distributed-process → }/src/Control/Distributed/Process/Internal/WeakTQueue.hs
  146. 0 {distributed-process → }/src/Control/Distributed/Process/Node.hs
  147. 0 {distributed-process → }/src/Control/Distributed/Process/Serializable.hs
  148. 0 {distributed-process → }/tests/TestCH.hs
  149. 0 {distributed-process → }/tests/TestClosure.hs
  150. 0 {distributed-process → }/tests/TestReceive.hs
  151. 0 {distributed-process → }/tests/TestStats.hs
View
10 .travis.yml
@@ -0,0 +1,10 @@
+language: haskell
+script: "make ci"
+notifications:
+ email:
+ recipients:
+ - cloud.haskell@gmail.com
+ irc:
+ channels:
+ - "irc.freenode.org#haskell-distributed"
+ use_notice: true
View
0 distributed-process/ChangeLog → ChangeLog
File renamed without changes.
View
0 network-transport/LICENSE → LICENSE
File renamed without changes.
View
27 Makefile
@@ -0,0 +1,27 @@
+# CI build
+
+GHC ?= $(shell which ghc)
+CABAL ?= $(shell which cabal)
+
+BASE_GIT := git://github.com/haskell-distributed
+REPOS=$(shell cat REPOS | sed '/^$$/d')
+
+.PHONY: all
+all: $(REPOS)
+
+$(REPOS):
+ git clone $(BASE_GIT)/$@.git
+
+.PHONY: install
+install: $(REPOS)
+ $(CABAL) install --with-ghc=$(GHC) $(REPOS) --force-reinstalls
+ $(CABAL) install
+
+.PHONY: ci
+ci: install test
+
+.PHONY: test
+test:
+ $(CABAL) configure --enable-tests
+ $(CABAL) build
+ $(CABAL) test --show-details=always
View
54 README.md
@@ -1,34 +1,20 @@
-Haskell Distributed Project
-===========================
-
-This repository holds an implementation of [Cloud Haskell][1].
-
-At present, this repository hosts
-
-* network-transport: Generic Network.Transport API
-* network-transport-tests: Test suite for Network.Transport instantiations
-* network-transport-tcp: TCP instantiation of Network.Transport
-* network-transport-inmemory: In-memory instantiation of Network.Transport (incomplete)
-* network-transport-composed: Compose two transports (very preliminary)
-* distributed-static: Support for static values
-* distributed-process: The main Cloud Haskell package
-* distributed-process-simplelocalnet: Simple backend for local networks
-* distributed-process-azure: Azure backend for Cloud Haskell (proof of concept)
-* azure-service-api: Haskell bindings for the Azure service API
-* rank1dynamic: Like Data.Dynamic and Data.Typeable but with support for polymorphic values
-
-For more detailed information about the interfaces provided by these packages,
-please refer to the [distributed-process repository wiki][2]. People who wish
-to get started with Cloud Haskell should cabal install
-distributed-process and possibly distributed-process-simplelocalnet and refer
-to the corresponding Haddock documentation ([Control.Distributed.Process][3],
-[Control.Distributed.Process.Closure][4],
-[Control.Distributed.Process.Node][5], and
-[Control.Distributed.Process.Backend.SimpleLocalnet][6]).
-
-[1]: http://www.haskell.org/haskellwiki/Cloud_Haskell
-[2]: https://github.com/haskell-distributed/distributed-process/wiki
-[3]: http://hackage.haskell.org/packages/archive/distributed-process/0.2.1.4/doc/html/Control-Distributed-Process.html
-[4]: http://hackage.haskell.org/packages/archive/distributed-process/0.2.1.4/doc/html/Control-Distributed-Process-Closure.html
-[5]: http://hackage.haskell.org/packages/archive/distributed-process/0.2.1.4/doc/html/Control-Distributed-Process-Node.html
-[6]: http://hackage.haskell.org/packages/archive/distributed-process-simplelocalnet/0.2.0.3/doc/html/Control-Distributed-Process-Backend-SimpleLocalnet.html
+### distributed-process [![travis](https://secure.travis-ci.org/haskell-distributed/distributed-process.png?branch=master,development)](http://travis-ci.org/haskell-distributed/distributed-process)
+
+
+This repository is part of Cloud Haskell.
+
+See http://haskell-distributed.github.com for documentation, user guides,
+tutorials and assistance.
+
+### Getting Help / Raising Issues
+
+Please visit our [bug tracker](http://cloud-haskell.atlassian.net) to submit
+issues. Anyone can browse, although you'll need to provide an email address
+and create an account in order to submit new issues.
+
+If you'd like to talk to a human, please contact us at the parallel-haskell
+mailing list in the first instance - parallel-haskell@googlegroups.com.
+
+### License
+
+distributed-process is made available under a BSD-3 license.
View
4 REPOS
@@ -0,0 +1,4 @@
+rank1dynamic
+distributed-static
+network-transport
+network-transport-tcp
View
0 rank1dynamic/Setup.hs → Setup.hs
File renamed without changes.
View
30 azure-service-api/LICENSE
@@ -1,30 +0,0 @@
-Copyright (c) 2012, Edsko de Vries
-
-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 Edsko de Vries 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.
View
2 azure-service-api/Setup.hs
@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain
View
44 azure-service-api/azure-service-api.cabal
@@ -1,44 +0,0 @@
--- Initial azure-service-api.cabal generated by cabal init. For further
--- documentation, see http://haskell.org/cabal/users-guide/
-
-Name: azure-service-api
-Version: 0.1.0.0
-Synopsis: Haskell bindings for the Microsoft Azure Service Management API
-Description: At the moment, this module only provides minimal
- functionality, just enough to support the
- "distributed-process-azure" package (Azure backend for
- Cloud Haskell). However, the code is set up in such a way
- that adding additional functionality should be relatively
- straightforward; developers who wish to do will probably
- want to consult the Windows Azure Service Management REST
- API Reference
- (<http://msdn.microsoft.com/en-us/library/windowsazure/ee460799.aspx>).
-Homepage: github.com/haskell-distributed/azure-service-api
-License: BSD3
-License-File: LICENSE
-Author: Edsko de Vries
-Maintainer: edsko@well-typed.com
-Copyright: Well-Typed LLP
-Category: Network
-Build-Type: Simple
-Cabal-Version: >=1.8
-
-Library
- Exposed-Modules: Network.Azure.ServiceManagement
- Build-Depends: base >= 4.5 && < 5,
- http-conduit >= 1.8.1 && < 1.9,
- tls >= 1.0 && < 1.1,
- tls-extra >= 0.5 && < 0.6,
- bytestring >= 0.9 && < 0.11,
- certificate >= 1.3 && < 1.4,
- case-insensitive >= 0.4 && < 0.5,
- hxt >= 9.2 && < 9.4,
- hxt-xpath >= 9.1 && < 9.2,
- pretty >= 1.1 && < 1.2,
- crypto-pubkey-types >= 0.1 && < 0.2,
- binary >= 0.5 && < 0.7,
- resourcet >= 0.4 && < 0.5,
- transformers >= 0.3 && < 0.4
- HS-Source-Dirs: src
- ghc-options: -Wall
- Extensions: RankNTypes
View
319 azure-service-api/src/Network/Azure/ServiceManagement.hs
@@ -1,319 +0,0 @@
-{-# LANGUAGE Arrows #-}
-module Network.Azure.ServiceManagement
- ( -- * Data types
- CloudService
- , cloudServiceName
- , cloudServiceVMs
- , VirtualMachine
- , vmName
- , vmIpAddress
- , vmInputEndpoints
- , Endpoint
- , endpointName
- , endpointPort
- , endpointVip
- -- * Pure functions
- , vmSshEndpoint
- -- * Setup
- , AzureSetup(..)
- , azureSetup
- -- * High-level API
- , cloudServices
- ) where
-
-import Prelude hiding (id, (.))
-import Control.Category (id, (.))
-import Control.Arrow (arr)
-import Control.Monad (forM)
-import Control.Applicative ((<$>), (<*>))
-import Data.Maybe (listToMaybe)
-import Data.ByteString.Lazy (ByteString)
-import Data.ByteString.Char8 as BSC (pack)
-import Data.ByteString.Lazy.Char8 as BSLC (unpack)
-import Data.Binary (Binary(get,put))
-import Data.Binary.Put (runPut)
-import Data.Binary.Get (Get, runGet)
-import Network.TLS (PrivateKey(PrivRSA))
-import Network.TLS.Extra (fileReadCertificate, fileReadPrivateKey)
-import Data.Certificate.X509 (X509, encodeCertificate, decodeCertificate)
-import qualified Crypto.Types.PubKey.RSA as RSA (PrivateKey(..))
-import Control.Monad.Trans.Resource (ResourceT)
-import Control.Monad.IO.Class (liftIO)
-import Control.Arrow.ArrowList (listA, arr2A)
-import Text.PrettyPrint
- ( Doc
- , text
- , (<+>)
- , ($$)
- , vcat
- , hang
- , doubleQuotes
- )
-import Network.HTTP.Conduit
- ( parseUrl
- , clientCertificates
- , requestHeaders
- , withManager
- , Response(Response)
- , httpLbs
- , Manager
- )
-import Data.CaseInsensitive as CI (mk)
-import Text.XML.HXT.Core
- ( runX
- , readString
- , withValidate
- , no
- , XmlTree
- , IOSArrow
- , ArrowXml
- , getText
- )
-import Text.XML.HXT.XPath (getXPathTrees)
-
---------------------------------------------------------------------------------
--- Data types --
---------------------------------------------------------------------------------
-
-data HostedService = HostedService {
- hostedServiceName :: String
- }
-
--- | A cloud service is a bunch of virtual machines that are part of the same
--- network (i.e., can talk to each other directly using standard TCP
--- connections).
-data CloudService = CloudService {
- -- | Name of the service.
- cloudServiceName :: String
- -- | Virtual machines that are part of this cloud service.
- , cloudServiceVMs :: [VirtualMachine]
- }
-
--- | Virtual machine
-data VirtualMachine = VirtualMachine {
- -- | Name of the virtual machine.
- vmName :: String
- -- | The /internal/ IP address of the virtual machine (that is, the
- -- IP address on the Cloud Service). For the globally accessible IP
- -- address see 'vmInputEndpoints'.
- , vmIpAddress :: String
- -- | Globally accessible endpoints to the virtual machine
- , vmInputEndpoints :: [Endpoint]
- }
-
--- | Globally accessible endpoint for a virtual machine
-data Endpoint = Endpoint {
- -- | Name of the endpoint (typical example: @SSH@)
- endpointName :: String
- -- | Port number (typical examples are 22 or high numbered ports such as 53749)
- , endpointPort :: String
- -- | Virtual IP address (that is, globally accessible IP address).
- --
- -- This corresponds to the IP address associated with the Cloud Service
- -- (i.e., that would be returned by a DNS lookup for @name.cloudapp.net@,
- -- where @name@ is the name of the Cloud Service).
- , endpointVip :: String
- }
-
---------------------------------------------------------------------------------
--- Pretty-printing --
---------------------------------------------------------------------------------
-
-instance Show HostedService where
- show = show . ppHostedService
-
-instance Show CloudService where
- show = show . ppCloudService
-
-instance Show VirtualMachine where
- show = show . ppVirtualMachine
-
-instance Show Endpoint where
- show = show . ppEndpoint
-
-ppHostedService :: HostedService -> Doc
-ppHostedService = text . hostedServiceName
-
-ppCloudService :: CloudService -> Doc
-ppCloudService cs =
- (text "Cloud Service" <+> (doubleQuotes . text . cloudServiceName $ cs))
- `hang2`
- ( text "VIRTUAL MACHINES"
- `hang2`
- (vcat . map ppVirtualMachine . cloudServiceVMs $ cs)
- )
-
-ppVirtualMachine :: VirtualMachine -> Doc
-ppVirtualMachine vm =
- (text "Virtual Machine" <+> (doubleQuotes . text . vmName $ vm))
- `hang2`
- ( text "IP" <+> text (vmIpAddress vm)
- $$ ( text "INPUT ENDPOINTS"
- `hang2`
- (vcat . map ppEndpoint . vmInputEndpoints $ vm)
- )
- )
-
-ppEndpoint :: Endpoint -> Doc
-ppEndpoint ep =
- (text "Input endpoint" <+> (doubleQuotes . text . endpointName $ ep))
- `hang2`
- ( text "Port" <+> text (endpointPort ep)
- $$ text "VIP" <+> text (endpointVip ep)
- )
-
-hang2 :: Doc -> Doc -> Doc
-hang2 d1 = hang d1 2
-
---------------------------------------------------------------------------------
--- Pure operations --
---------------------------------------------------------------------------------
-
--- | Find the endpoint with name @SSH@.
-vmSshEndpoint :: VirtualMachine -> Maybe Endpoint
-vmSshEndpoint vm = listToMaybe
- [ ep
- | ep <- vmInputEndpoints vm
- , endpointName ep == "SSH"
- ]
-
---------------------------------------------------------------------------------
--- Setup --
---------------------------------------------------------------------------------
-
--- | Azure setup
---
--- The documentation of "distributed-process-azure" explains in detail how
--- to obtain the SSL client certificate and the private key for your Azure
--- account.
---
--- See also 'azureSetup'.
-data AzureSetup = AzureSetup
- { -- | Azure subscription ID
- subscriptionId :: String
- -- | SSL client certificate
- , certificate :: X509
- -- | RSA private key
- , privateKey :: PrivateKey
- -- | Base URL (generally <https://management.core.windows.net>)
- , baseUrl :: String
- }
-
--- TODO: it's dubious to be transferring private keys, but we transfer them
--- over a secure connection and it can be argued that it's safer than actually
--- storing the private key on each remote server
-
-encodePrivateKey :: PrivateKey -> ByteString
-encodePrivateKey (PrivRSA pkey) = runPut $ do
- put (RSA.private_size pkey)
- put (RSA.private_n pkey)
- put (RSA.private_d pkey)
- put (RSA.private_p pkey)
- put (RSA.private_q pkey)
- put (RSA.private_dP pkey)
- put (RSA.private_dQ pkey)
- put (RSA.private_qinv pkey)
-
-decodePrivateKey :: ByteString -> PrivateKey
-decodePrivateKey = PrivRSA . runGet getPrivateKey
- where
- getPrivateKey :: Get RSA.PrivateKey
- getPrivateKey =
- RSA.PrivateKey <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get
-
-instance Binary AzureSetup where
- put (AzureSetup sid cert pkey url) = do
- put sid
- put (encodeCertificate cert)
- put (encodePrivateKey pkey)
- put url
- get = do
- sid <- get
- Right cert <- decodeCertificate <$> get
- pkey <- decodePrivateKey <$> get
- url <- get
- return $ AzureSetup sid cert pkey url
-
--- | Initialize Azure
-azureSetup :: String -- ^ Subscription ID
- -> String -- ^ Path to certificate
- -> String -- ^ Path to private key
- -> IO AzureSetup
-azureSetup sid certPath pkeyPath = do
- cert <- fileReadCertificate certPath
- pkey <- fileReadPrivateKey pkeyPath
- return AzureSetup {
- subscriptionId = sid
- , certificate = cert
- , privateKey = pkey
- , baseUrl = "https://management.core.windows.net"
- }
-
---------------------------------------------------------------------------------
--- High-level API --
---------------------------------------------------------------------------------
-
--- | Find available cloud services
-cloudServices :: AzureSetup -> IO [CloudService]
-cloudServices setup = azureExecute setup $ \exec -> do
- services <- exec hostedServicesRequest
- forM services $ \service -> do
- roles <- exec AzureRequest {
- relativeUrl = "/services/hostedservices/" ++ hostedServiceName service
- ++ "?embed-detail=true"
- , apiVersion = "2012-03-01"
- , parser = proc xml -> do
- role <- getXPathTrees "//Role[@type='PersistentVMRole']" -< xml
- name <- getText . getXPathTrees "/Role/RoleName/text()" -< role
- roleInst <- arr2A getXPathTrees -< ("//RoleInstance[RoleName='" ++ name ++ "']", xml)
- ip <- getText . getXPathTrees "/RoleInstance/IpAddress/text()" -< roleInst
- endpoints <- listA (parseEndpoint . getXPathTrees "//InputEndpoint") -< role
- id -< VirtualMachine name ip endpoints
- }
- return $ CloudService (hostedServiceName service) roles
-
-hostedServicesRequest :: AzureRequest HostedService
-hostedServicesRequest = AzureRequest
- { relativeUrl = "/services/hostedservices"
- , apiVersion = "2012-03-01"
- , parser = arr HostedService
- . getText
- . getXPathTrees "//ServiceName/text()"
- }
-
-parseEndpoint :: ArrowXml t => t XmlTree Endpoint
-parseEndpoint = proc endpoint -> do
- name <- getText . getXPathTrees "//Name/text()" -< endpoint
- port <- getText . getXPathTrees "//Port/text()" -< endpoint
- vip <- getText . getXPathTrees "//Vip/text()" -< endpoint
- id -< Endpoint name port vip
-
---------------------------------------------------------------------------------
--- Low-level API --
---------------------------------------------------------------------------------
-
-data AzureRequest c = AzureRequest {
- relativeUrl :: String
- , apiVersion :: String
- , parser :: IOSArrow XmlTree c
- }
-
-azureExecute :: AzureSetup -> ((forall b. AzureRequest b -> ResourceT IO [b]) -> ResourceT IO a) -> IO a
-azureExecute setup f = withManager (\manager -> f (go manager))
- where
- go :: Manager -> forall b. AzureRequest b -> ResourceT IO [b]
- go manager request = do
- req <- parseUrl $ baseUrl setup
- ++ "/" ++ subscriptionId setup
- ++ "/" ++ relativeUrl request
- let req' = req {
- clientCertificates = [ (certificate setup, Just $ privateKey setup) ]
- , requestHeaders = [ (CI.mk $ BSC.pack "x-ms-version", BSC.pack $ apiVersion request)
- , (CI.mk $ BSC.pack "content-type", BSC.pack "application/xml")
- ]
- }
- Response _ _ _ lbs <- httpLbs req' manager
- liftIO . runX $ proc _ -> do
- xml <- readString [withValidate no] (BSLC.unpack lbs) -< ()
- -- arrIO putStrLn . writeDocumentToString [withIndent yes] -< xml
- parser request -< xml
View
0 distributed-process/benchmarks/Channels.hs → benchmarks/Channels.hs
File renamed without changes.
View
0 distributed-process/benchmarks/Latency.hs → benchmarks/Latency.hs
File renamed without changes.
View
0 distributed-process/benchmarks/Spawns.hs → benchmarks/Spawns.hs
File renamed without changes.
View
0 distributed-process/benchmarks/Throughput.hs → benchmarks/Throughput.hs
File renamed without changes.
View
0 ...ted-process/benchmarks/erlang/latency.erl → benchmarks/erlang/latency.erl
File renamed without changes.
View
0 ...-process/benchmarks/erlang/throughput.erl → benchmarks/erlang/throughput.erl
File renamed without changes.
View
0 ...uted-process/benchmarks/remote/Latency.hs → benchmarks/remote/Latency.hs
File renamed without changes.
View
0 ...d-process/benchmarks/remote/Throughput.hs → benchmarks/remote/Throughput.hs
File renamed without changes.
View
31 distributed-process-azure/LICENSE
@@ -1,31 +0,0 @@
-Copyright Well-Typed LLP, 2011-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 owner 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.
-
View
2 distributed-process-azure/Setup.hs
@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain
View
49 distributed-process-azure/demos/Echo.hs
@@ -1,49 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-
-import System.IO (hFlush, stdout)
-import System.Environment (getArgs)
-import Control.Monad (unless, forever)
-import Control.Monad.IO.Class (liftIO)
-import Control.Distributed.Process (Process, expect)
-import Control.Distributed.Process.Closure (remotable, mkClosure)
-import Control.Distributed.Process.Backend.Azure
-
-echoRemote :: () -> Backend -> Process ()
-echoRemote () _backend = forever $ do
- str <- expect
- remoteSend (str :: String)
-
-remotable ['echoRemote]
-
-echoLocal :: LocalProcess ()
-echoLocal = do
- str <- liftIO $ putStr "# " >> hFlush stdout >> getLine
- unless (null str) $ do
- localSend str
- liftIO $ putStr "Echo: " >> hFlush stdout
- echo <- localExpect
- liftIO $ putStrLn echo
- echoLocal
-
-main :: IO ()
-main = do
- args <- getArgs
- case args of
- "onvm":args' ->
- -- Pass execution to 'onVmMain' if we are running on the VM
- -- ('callOnVM' will provide the right arguments)
- onVmMain __remoteTable args'
-
- sid:x509:pkey:user:cloudService:virtualMachine:port:_ -> do
- -- Initialize the Azure backend
- params <- defaultAzureParameters sid x509 pkey
- let params' = params { azureSshUserName = user }
- backend <- initializeBackend params' cloudService
-
- -- Find the specified virtual machine
- Just vm <- findNamedVM backend virtualMachine
-
- -- Run the echo client proper
- callOnVM backend vm port $
- ProcessPair ($(mkClosure 'echoRemote) ())
- echoLocal
View
74 distributed-process-azure/demos/Fib.hs
@@ -1,74 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-import System.Environment (getArgs)
-import System.Random (randomIO)
-import Control.Monad (forM)
-import Control.Monad.IO.Class (liftIO)
-import Control.Distributed.Process
- ( Process
- , NodeId
- , SendPort
- , newChan
- , sendChan
- , spawn
- , receiveChan
- , spawnLocal
- )
-import Control.Distributed.Process.Backend.Azure
-import Control.Distributed.Process.Closure
- ( remotable
- , remotableDecl
- , mkClosure
- )
-
-randomElement :: [a] -> IO a
-randomElement xs = do
- ix <- randomIO
- return (xs !! (ix `mod` length xs))
-
-remotableDecl [
- [d| dfib :: ([NodeId], SendPort Integer, Integer) -> Process () ;
- dfib (_, reply, 0) = sendChan reply 0
- dfib (_, reply, 1) = sendChan reply 1
- dfib (nids, reply, n) = do
- nid1 <- liftIO $ randomElement nids
- nid2 <- liftIO $ randomElement nids
- (sport, rport) <- newChan
- _ <- spawn nid1 $ $(mkClosure 'dfib) (nids, sport, n - 2)
- _ <- spawn nid2 $ $(mkClosure 'dfib) (nids, sport, n - 1)
- n1 <- receiveChan rport
- n2 <- receiveChan rport
- sendChan reply $ n1 + n2
- |]
- ]
-
-remoteFib :: ([NodeId], Integer) -> Backend -> Process ()
-remoteFib (nids, n) _backend = do
- (sport, rport) <- newChan
- _ <- spawnLocal $ dfib (nids, sport, n)
- fib_n <- receiveChan rport
- mapM_ terminateNode nids
- remoteSend fib_n
-
-remotable ['remoteFib]
-
-printResult :: LocalProcess ()
-printResult = do
- result <- localExpect :: LocalProcess Integer
- liftIO $ print result
-
-main :: IO ()
-main = do
- args <- getArgs
- case args of
- "onvm":args' -> onVmMain (__remoteTable . __remoteTableDecl) args'
- [sid, x509, pkey, user, cloudService, n] -> do
- params <- defaultAzureParameters sid x509 pkey
- let params' = params { azureSshUserName = user }
- backend <- initializeBackend params' cloudService
- vms <- findVMs backend
- nids <- forM vms $ \vm -> spawnNodeOnVM backend vm "8080"
- callOnVM backend (head vms) "8081" $
- ProcessPair ($(mkClosure 'remoteFib) (nids, read n :: Integer))
- printResult
- _ ->
- error "Invalid command line arguments"
View
85 distributed-process-azure/demos/Ping.hs
@@ -1,85 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-
-import System.Environment (getArgs)
-import Data.Binary (encode, decode)
-import Control.Monad (forever)
-import Control.Monad.IO.Class (liftIO)
-import Control.Exception (try, IOException)
-import Control.Distributed.Process
- ( Process
- , getSelfPid
- , expect
- , send
- , monitor
- , receiveWait
- , match
- , ProcessMonitorNotification(..)
- )
-import Control.Distributed.Process.Closure (remotable, mkClosure)
-import Control.Distributed.Process.Backend.Azure
-import qualified Data.ByteString.Lazy as BSL (readFile, writeFile)
-
-pingServer :: () -> Backend -> Process ()
-pingServer () _backend = do
- us <- getSelfPid
- liftIO $ BSL.writeFile "pingServer.pid" (encode us)
- forever $ do
- them <- expect
- send them ()
-
-pingClientRemote :: () -> Backend -> Process ()
-pingClientRemote () _backend = do
- mPingServerEnc <- liftIO $ try (BSL.readFile "pingServer.pid")
- case mPingServerEnc of
- Left err ->
- remoteSend $ "Ping server not found: " ++ show (err :: IOException)
- Right pingServerEnc -> do
- let pingServerPid = decode pingServerEnc
- pid <- getSelfPid
- _ref <- monitor pingServerPid
- send pingServerPid pid
- gotReply <- receiveWait
- [ match (\() -> return True)
- , match (\(ProcessMonitorNotification {}) -> return False)
- ]
- if gotReply
- then remoteSend $ "Ping server at " ++ show pingServerPid ++ " ok"
- else remoteSend $ "Ping server at " ++ show pingServerPid ++ " failure"
-
-remotable ['pingClientRemote, 'pingServer]
-
-pingClientLocal :: LocalProcess ()
-pingClientLocal = localExpect >>= liftIO . putStrLn
-
-main :: IO ()
-main = do
- args <- getArgs
- case args of
- "onvm":args' ->
- -- Pass execution to 'onVmMain' if we are running on the VM
- onVmMain __remoteTable args'
-
- "list":sid:x509:pkey:_ -> do
- -- List all available cloud services
- -- (useful, but not strictly necessary for the example)
- params <- defaultAzureParameters sid x509 pkey
- css <- cloudServices (azureSetup params)
- mapM_ print css
-
- cmd:sid:x509:pkey:user:cloudService:virtualMachine:port:_ -> do
- -- Initialize the backend and find the right VM
- params <- defaultAzureParameters sid x509 pkey
- let params' = params { azureSshUserName = user }
- backend <- initializeBackend params' cloudService
- Just vm <- findNamedVM backend virtualMachine
-
- -- The same binary can behave as the client or the server,
- -- depending on the command line arguments
- case cmd of
- "server" -> do
- pid <- spawnOnVM backend vm port ($(mkClosure 'pingServer) ())
- putStrLn $ "Ping server started at " ++ show pid
- "client" ->
- callOnVM backend vm port $
- ProcessPair ($(mkClosure 'pingClientRemote) ())
- pingClientLocal
View
102 distributed-process-azure/distributed-process-azure.cabal
@@ -1,102 +0,0 @@
-Name: distributed-process-azure
-Version: 0.1.0
-Cabal-Version: >=1.8
-Build-Type: Simple
-License: BSD3
-License-File: LICENSE
-Copyright: Well-Typed LLP
-Author: Duncan Coutts, Nicolas Wu, Edsko de Vries
-Maintainer: edsko@well-typed.com, duncan@well-typed.com
-Stability: experimental
-Homepage: http://github.com/haskell-distributed/distributed-process
-Bug-Reports: mailto:edsko@well-typed.com
-Synopsis: Microsoft Azure backend for Cloud Haskell
-Description: This is a proof of concept Azure backend for Cloud Haskell. It
- provides just enough functionality to run Cloud Haskell
- applications on Azure virtual machines. You need to create your
- virtual machines in the Azure management portal; you can then
- use this backend to copy or verify your executable to the
- virtual machine, start or terminate Cloud Haskell nodes on those
- virtual machines, and communicate with those virtual machines
- from your local machine.
-Category: Control
-
-Source-Repository head
- Type: git
- Location: https://github.com/haskell-distributed/distributed-process
- SubDir: distributed-process-azure
-
-Flag build-demos
- description: Build the demos
- default: False
-
-Library
- Build-Depends: base >= 4.4 && < 5,
- azure-service-api >= 0.1 && < 0.2,
- filepath >= 1.3 && < 1.4,
- executable-path >= 0.0.3 && < 0.1,
- libssh2 >= 0.2 && < 0.3,
- pureMD5 >= 2.1 && < 2.2,
- bytestring >= 0.9 && < 0.11,
- distributed-process >= 0.3.2 && < 0.5,
- binary >= 0.5 && < 0.7,
- network-transport >= 0.3 && < 0.4,
- network-transport-tcp >= 0.3 && < 0.4,
- transformers >= 0.3 && < 0.4,
- certificate >= 1.3 && < 1.4,
- unix >= 2.5 && < 2.7,
- mtl >= 2.1 && < 2.2,
- rank1dynamic >= 0.1 && < 0.2,
- distributed-static >= 0.2 && < 0.3
- Exposed-modules: Control.Distributed.Process.Backend.Azure
- Extensions: ViewPatterns,
- RankNTypes,
- ExistentialQuantification,
- ScopedTypeVariables,
- DeriveDataTypeable,
- GeneralizedNewtypeDeriving
- ghc-options: -Wall
- HS-Source-Dirs: src
-
-Executable cloud-haskell-azure-echo
- if flag(build-demos)
- Build-Depends: base >= 4.4 && < 5,
- distributed-process-azure >= 0.1 && < 0.2,
- distributed-process >= 0.3.2 && < 0.5,
- transformers >= 0.3 && < 0.4
- else
- buildable: False
- Main-Is: demos/Echo.hs
- ghc-options: -Wall
-
-Executable cloud-haskell-azure-ping
- if flag(build-demos)
- Build-Depends: base >= 4.4 && < 5,
- distributed-process-azure >= 0.1 && < 0.2,
- distributed-process >= 0.3.2 && < 0.5,
- transformers >= 0.3 && < 0.4,
- bytestring >= 0.9 && < 0.11,
- binary >= 0.5 && < 0.7,
- mtl,
- libssh2
- else
- buildable: False
- Main-Is: demos/Ping.hs
- ghc-options: -Wall
-
-Executable cloud-haskell-azure-fib
- if flag(build-demos)
- Build-Depends: base >= 4.4 && < 5,
- distributed-process-azure >= 0.1 && < 0.2,
- distributed-process >= 0.3.2 && < 0.5,
- transformers >= 0.3 && < 0.4,
- bytestring >= 0.9 && < 0.11,
- binary >= 0.5 && < 0.7,
- binary-generic >= 0.2 && < 0.3,
- rank1dynamic >= 0.1 && < 0.2,
- distributed-static >= 0.2 && < 0.3,
- random >= 1.0 && < 1.1
- else
- buildable: False
- Main-Is: demos/Fib.hs
- ghc-options: -Wall
View
964 distributed-process-azure/src/Control/Distributed/Process/Backend/Azure.hs
@@ -1,964 +0,0 @@
--- | This module provides the API for running Cloud Haskell on Microsoft Azure
--- virtual machines (<http://www.windowsazure.com>). Virtual machines within an
--- Azure cloud service can talk to each other directly using standard Cloud
--- Haskell primitives (using TCP/IP under the hood); to talk to the remote
--- machines from your local machine you can use the primitives provided in this
--- module (which use ssh under the hood). It looks something like
---
--- > _ _
--- > ( ` )_
--- > ( ) `) Azure cloud service
--- > (_ (_ . _) _)
--- >
--- > |
--- > | ssh connection
--- > |
--- >
--- > +---+
--- > | | Local machine
--- > +---+
---
--- /NOTE/: It is unfortunate that the local machine cannot talk to the remote
--- machine using the standard Cloud Haskell primitives. In an ideal world, we
--- could just start a Cloud Haskell node on the local machine, too.
--- Unfortunately, Cloud Haskell does not yet support using multiple network
--- transports within the same system (i.e. both TCP/IP and SSH). This is a
--- temporary workaround.
---
--- [Azure Setup]
---
--- In this section we describe how to set up an Azure Cloud Service for use
--- with Cloud Haskell, starting from a brand new Azure account. It is not
--- intended as an Azure tutorial, but as a guide to making the right choices to
--- get Cloud Haskell up and running as quickly as possible.
---
--- An Azure /Cloud Service/ is a set of virtual machines that can talk to each
--- other directly over TCP/IP (they are part of the same private network). You
--- don't create the cloud service directly; instead, after you have set up your
--- first virtual machine as a /stand alone/ virtual machine, you can /connect/
--- subsequent virtual machines to the first virtual machine, thereby implicitly
--- setting up a Cloud Service.
---
--- We have only tested Cloud Haskell with Linux based virtual machines;
--- Windows based virtual machines /might/ work, but you'll be entering
--- uncharted territory. Cloud Haskell assumes that all nodes run the same
--- binary code; hence, you must use the same OS on all virtual machines,
--- /as well as on your local machine/. We use Ubuntu Server 12.04 LTS for our
--- tests (running on VirtualBox on our local machine).
---
--- When you set up your virtual machine, you can pick an arbitrary virtual
--- machine name; these names are for your own use only and do not need to be
--- globally unique. Set a username and password; you should use the same
--- username on all virtual machines. You should also upload an SSH key for
--- authentication (see
--- /Converting OpenSSH keys for use on Windows Azure Linux VM's/,
--- <http://utlemming.azurewebsites.net/?p=91>, for
--- information on how to convert a standard Linux @id_rsa.pub@ public key to
--- X509 format suitable for Azure). For the first VM you create select
--- /Standalone Virtual Machine/, and pick an appropriate DNS name. The DNS name
--- /does/ have to be globally unique, and will also be the name of the Cloud
--- Service. For subsequent virtual machines, select
--- /Connect to Existing Virtual Machine/ instead and then select the first VM
--- you created.
---
--- Once your virtual machines have been set up, you have to make sure that the
--- user you created when you created the VM can ssh from any virtual machine to
--- any other using public key authentication. Moreover, you have to make sure
--- that @libssh2@ is installed; if you are using the Ubuntu image you can
--- install @libssh2@ using
---
--- > sudo apt-get install libssh2-1
---
--- (TODO: if you don't install libssh2 things will break without a clear error
--- message.)
---
--- In these notes, we assume three virtual machines called @CHDemo1@,
--- @CHDemo2@, and @CHDemo3@, all part of a @CloudHaskellDemo@ cloud service.
---
--- [Obtaining a Management Certificate]
---
--- Azure authentication is by means of an X509 certificate and corresponding
--- private key. /Create management certificates for Linux in Windows Azure/,
--- <https://www.windowsazure.com/en-us/manage/linux/common-tasks/manage-certificates/>,
--- describes how you can create a management certificate for Azure, download it
--- as a @.publishsettings@ file, and extract an @.pfx@ file from it. You cannot
--- use this @.pfx@ directly; instead, you will need to extract an X509
--- certificate from it and a private key in suitable format. You can use the
--- @openssl@ command line tool for both tasks; assuming that you stored the
--- @.pfx@ file as @credentials.pfx@, to extract the X509 certificate:
---
--- > openssl pkcs12 -in credentials.pfx -nokeys -out credentials.x509
---
--- And to extract the private key:
---
--- > openssl pkcs12 -in credentials.pfx -nocerts -nodes | openssl rsa -out credentials.private
---
--- (@openssl pkcs12@ outputs the private key in PKCS#8 format (BEGIN PRIVATE
--- KEY), but we need it in PKCS#1 format (BEGIN RSA PRIVATE KEY).
---
--- [Testing the Setup]
---
--- Build and install the @distributed-process-azure@ package, making sure to
--- pass the @build-demos@ flag to Cabal.
---
--- > cabal-dev install distributed-process-azure -f build-demos
---
--- We can the @cloud-haskell-azure-ping@ demo to test our setup:
---
--- > cloud-haskell-azure-ping list \
--- > <<your subscription ID>> \
--- > /path/to/credentials.x509 \
--- > /path/to/credentials.private
---
--- (you can find your subscription ID in the @.publishsettings@ file from the previous step).
--- If everything went well, this will output something like
---
--- > Cloud Service "CloudHaskellDemo"
--- > VIRTUAL MACHINES
--- > Virtual Machine "CHDemo3"
--- > IP 10.119.182.127
--- > INPUT ENDPOINTS
--- > Input endpoint "SSH"
--- > Port 50136
--- > VIP 168.63.31.38
--- > Virtual Machine "CHDemo2"
--- > IP 10.59.238.125
--- > INPUT ENDPOINTS
--- > Input endpoint "SSH"
--- > Port 63365
--- > VIP 168.63.31.38
--- > Virtual Machine "CHDemo1"
--- > IP 10.59.224.122
--- > INPUT ENDPOINTS
--- > Input endpoint "SSH"
--- > Port 22
--- > VIP 168.63.31.38
---
--- The IP addresses listed are /internal/ IP addresses; they can be used by the
--- virtual machines to talk to each other, but not by the outside world to talk
--- to the virtual machines. To do that, you will need to use the VIP (Virtual
--- IP) address instead, which you will notice is the same for all virtual
--- machines that are part of the cloud service. The corresponding DNS name
--- (here @CloudHaskellDemo.cloudapp.net@) will also resolve to this (V)IP
--- address. To login to individual machines (through SSH) you will need to use
--- the specific port mentioned under INPUT ENDPOINTS.
---
--- [Overview of the API]
---
--- The Azure 'Backend' provides low-level functionality for interacting with
--- Azure virtual machines. 'findVMs' finds all currently available virtual
--- machines; 'copyToVM' copies the executable to a specified VM (recall that
--- all VMs, as well as the local machine, are assumed to run the same OS so
--- that they can all run the same binary), and 'checkMD5' checks the MD5 hash
--- of the executable on a remote machine.
---
--- 'callOnVM' and 'spawnOnVM' deal with setting up Cloud Haskell nodes.
--- 'spawnOnVM' takes a virtual machine and a port number, as well as a
--- @RemoteProcess ()@, starts the executable on the remote node, sets up a new
--- Cloud Haskell node, and then runs the specified process. The Cloud Haskell
--- node will be shut down when the given process terminates. 'RemoteProcess' is
--- defined as
---
--- > type RemoteProcess a = Closure (Backend -> Process a)
---
--- (If you don't know what a 'Closure' is you should read
--- "Control.Distributed.Process.Closure".); the remote process will be supplied
--- with an Azure backend initialized with the same parameters. 'spawnOnVM'
--- returns once the Cloud Haskell node has been set up.
---
--- 'callOnVM' is similar to 'spawnOnVM', but it takes a /pair/ of processes:
--- one to run on the remote host (on a newly created Cloud Haskell node), and
--- one to run on the local machine. In this case, the new Cloud Haskell node
--- will be terminated when the /local/ process terminates. 'callOnVM' is useful
--- because the remote process and the local process can communicate through a
--- set of primitives provided in this module ('localSend', 'localExpect', and
--- 'remoteSend' -- there is no 'remoteExpect'; instead the remote process can
--- use the standard Cloud Haskell 'expect' primitive).
---
--- [First Example: Echo]
---
--- When we run the @cloud-haskell-azure-echo@ demo on our local machine, it
--- starts a new Cloud Haskell node on the specified remote virtual machine. It
--- then repeatedly waits for input from the user on the local machine, sends
--- this to the remote virtual machine which will echo it back, and wait for and
--- show the echo.
---
--- Before you can try it you will first need to copy the executable (for
--- example, using scp, although the Azure backend also provides this natively
--- in Haskell). Once that's done, you can run the demo as follows:
---
--- > cloud-haskell-azure-echo \
--- > <<subscription ID>> \
--- > /path/to/credentials.x509 \
--- > /path/to/credentials.private \
--- > <<remote username>> \
--- > <<cloud service name>> \
--- > <<virtual machine name>> \
--- > <<port number>>
--- > # Everything I type gets echoed back
--- > Echo: Everything I type gets echoed back
--- > # Until I enter a blank line
--- > Echo: Until I enter a blank line
--- > #
---
--- The full @echo@ demo is
---
--- > {-# LANGUAGE TemplateHaskell #-}
--- >
--- > import System.IO (hFlush, stdout)
--- > import System.Environment (getArgs)
--- > import Control.Monad (unless, forever)
--- > import Control.Monad.IO.Class (liftIO)
--- > import Control.Distributed.Process (Process, expect)
--- > import Control.Distributed.Process.Closure (remotable, mkClosure)
--- > import Control.Distributed.Process.Backend.Azure
--- >
--- > echoRemote :: () -> Backend -> Process ()
--- > echoRemote () _backend = forever $ do
--- > str <- expect
--- > remoteSend (str :: String)
--- >
--- > remotable ['echoRemote]
--- >
--- > echoLocal :: LocalProcess ()
--- > echoLocal = do
--- > str <- liftIO $ putStr "# " >> hFlush stdout >> getLine
--- > unless (null str) $ do
--- > localSend str
--- > liftIO $ putStr "Echo: " >> hFlush stdout
--- > echo <- localExpect
--- > liftIO $ putStrLn echo
--- > echoLocal
--- >
--- > main :: IO ()
--- > main = do
--- > args <- getArgs
--- > case args of
--- > "onvm":args' ->
--- > -- Pass execution to 'onVmMain' if we are running on the VM
--- > -- ('callOnVM' will provide the right arguments)
--- > onVmMain __remoteTable args'
--- >
--- > sid:x509:pkey:user:cloudService:virtualMachine:port:_ -> do
--- > -- Initialize the Azure backend
--- > params <- defaultAzureParameters sid x509 pkey
--- > let params' = params { azureSshUserName = user }
--- > backend <- initializeBackend params' cloudService
--- >
--- > -- Find the specified virtual machine
--- > Just vm <- findNamedVM backend virtualMachine
--- >
--- > -- Run the echo client proper
--- > callOnVM backend vm port $
--- > ProcessPair ($(mkClosure 'echoRemote) ())
--- > echoLocal
---
--- The most important part of this code is the last three lines
---
--- > callOnVM backend vm port $
--- > ProcessPair ($(mkClosure 'echoRemote) ())
--- > echoLocal
---
--- 'callOnVM' creats a new Cloud Haskell node on the specified virtual machine,
--- then runs @echoRemote@ on the remote machine and @echoLocal@ on the local
--- machine.
---
--- [Second Example: Ping]
---
--- The second example differs from the @echo@ demo in that it uses both
--- 'callOnVM' and 'spawnOnVM'. It uses the latter to
--- install a ping server which keeps running in the background; it uses the
--- former to run a ping client which sends a request to the ping server and
--- outputs the response.
---
--- As with the @echo@ demo, make sure to copy the executable to the remote server first.
--- Once that is done, you can start a ping server on a virtual machine using
---
--- > cloud-haskell-azure-ping server \
--- > <<subscription ID>> \
--- > /path/to/credentials.x509 \
--- > /path/to/credentials.private \
--- > <<remote username>> \
--- > <<cloud service name>> \
--- > <<virtual machine name>> \
--- > <<port number>>
---
--- As before, when we execute this on our local machine, it starts a new Cloud
--- Haskell node on the specified remote virtual machine and then executes the
--- ping server. Unlike with the echo example, however, this command will
--- terminate once the Cloud Haskell node has been set up, leaving the ping
--- server running in the background.
---
--- Once the ping server is running we can run the ping client:
---
--- > cloud-haskell-azure-ping client \
--- > <<subscription ID>> \
--- > /path/to/credentials.x509 \
--- > /path/to/credentials.private \
--- > <<remote username>> \
--- > <<cloud service name>> \
--- > <<virtual machine name>> \
--- > <<DIFFERENT port number>>
--- > Ping server at pid://10.59.224.122:8080:0:2 ok
---
--- Note that we must pass a different port number, because the client will run
--- within its own Cloud Haskell instance.
---
--- The code for the @ping@ demo is similar to the @echo@ demo, but uses both
--- 'callOnVM' and 'spawnOnVM' and demonstrates a way to discover processes (in
--- this case, through a PID file).
---
--- > {-# LANGUAGE TemplateHaskell #-}
--- >
--- > import System.Environment (getArgs)
--- > import Data.Binary (encode, decode)
--- > import Control.Monad (void, forever)
--- > import Control.Monad.IO.Class (liftIO)
--- > import Control.Exception (try, IOException)
--- > import Control.Distributed.Process
--- > ( Process
--- > , getSelfPid
--- > , expect
--- > , send
--- > , monitor
--- > , receiveWait
--- > , match
--- > , ProcessMonitorNotification(..)
--- > )
--- > import Control.Distributed.Process.Closure (remotable, mkClosure)
--- > import Control.Distributed.Process.Backend.Azure
--- > import qualified Data.ByteString.Lazy as BSL (readFile, writeFile)
--- >
--- > pingServer :: () -> Backend -> Process ()
--- > pingServer () _backend = do
--- > us <- getSelfPid
--- > liftIO $ BSL.writeFile "pingServer.pid" (encode us)
--- > forever $ do
--- > them <- expect
--- > send them ()
--- >
--- > pingClientRemote :: () -> Backend -> Process ()
--- > pingClientRemote () _backend = do
--- > mPingServerEnc <- liftIO $ try (BSL.readFile "pingServer.pid")
--- > case mPingServerEnc of
--- > Left err ->
--- > remoteSend $ "Ping server not found: " ++ show (err :: IOException)
--- > Right pingServerEnc -> do
--- > let pingServerPid = decode pingServerEnc
--- > pid <- getSelfPid
--- > _ref <- monitor pingServerPid
--- > send pingServerPid pid
--- > gotReply <- receiveWait
--- > [ match (\() -> return True)
--- > , match (\(ProcessMonitorNotification {}) -> return False)
--- > ]
--- > if gotReply
--- > then remoteSend $ "Ping server at " ++ show pingServerPid ++ " ok"
--- > else remoteSend $ "Ping server at " ++ show pingServerPid ++ " failure"
--- >
--- > remotable ['pingClientRemote, 'pingServer]
--- >
--- > pingClientLocal :: LocalProcess ()
--- > pingClientLocal = localExpect >>= liftIO . putStrLn
--- >
--- > main :: IO ()
--- > main = do
--- > args <- getArgs
--- > case args of
--- > "onvm":args' ->
--- > -- Pass execution to 'onVmMain' if we are running on the VM
--- > onVmMain __remoteTable args'
--- >
--- > "list":sid:x509:pkey:_ -> do
--- > -- List all available cloud services
--- > -- (useful, but not strictly necessary for the example)
--- > params <- defaultAzureParameters sid x509 pkey
--- > css <- cloudServices (azureSetup params)
--- > mapM_ print css
--- >
--- > cmd:sid:x509:pkey:user:cloudService:virtualMachine:port:_ -> do
--- > -- Initialize the backend and find the right VM
--- > params <- defaultAzureParameters sid x509 pkey
--- > let params' = params { azureSshUserName = user }
--- > backend <- initializeBackend params' cloudService
--- > Just vm <- findNamedVM backend virtualMachine
--- >
--- > -- The same binary can behave as the client or the server,
--- > -- depending on the command line arguments
--- > case cmd of
--- > "server" -> void $ spawnOnVM backend vm port ($(mkClosure 'pingServer) ())
--- > "client" -> callOnVM backend vm port $
--- > ProcessPair ($(mkClosure 'pingClientRemote) ())
--- > pingClientLocal
-module Control.Distributed.Process.Backend.Azure
- ( -- * Initialization
- Backend(..)
- , AzureParameters(..)
- , defaultAzureParameters
- , initializeBackend
- -- * Utilities
- , findNamedVM
- -- * On-VM main
- , onVmMain
- -- * Re-exports from Azure Service Management
- , CloudService(..)
- , VirtualMachine(..)
- , Endpoint(..)
- , AzureSetup
- , Azure.cloudServices
- -- * Remote and local processes
- , ProcessPair(..)
- , RemoteProcess
- , LocalProcess
- , localSend
- , localExpect
- , remoteSend
- -- * High-level API
- , spawnNodeOnVM
- , terminateNode
- ) where
-
-import Prelude hiding (catch)
-import System.Environment (getEnv)
-import System.FilePath ((</>), takeFileName)
-import System.Environment.Executable (getExecutablePath)
-import System.IO
- ( stdout
- , hFlush
- , hSetBinaryMode
- , stdin
- , stdout
- , stderr
- , Handle
- , hClose
- )
-import qualified System.Posix.Process as Posix (forkProcess, createSession)
-import Data.Maybe (listToMaybe)
-import Data.Binary (Binary(get, put), encode, decode, getWord8, putWord8)
-import Data.Digest.Pure.MD5 (md5, MD5Digest)
-import qualified Data.ByteString as BSS
- ( ByteString
- , length
- , concat
- , hPut
- , hGet
- )
-import qualified Data.ByteString.Char8 as BSSC (pack)
-import qualified Data.ByteString.Lazy as BSL
- ( ByteString
- , readFile
- , length
- , fromChunks
- , toChunks
- , hPut
- , hGet
- )
-import Data.Typeable (Typeable)
-import Data.Foldable (forM_)
-import Control.Applicative ((<$>), (<*>))
-import Control.Monad (void, when)
-import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask)
-import Control.Exception
- ( Exception
- , catches
- , Handler(Handler)
- , throwIO
- , SomeException
- )
-import Control.Monad.IO.Class (MonadIO, liftIO)
-import Control.Concurrent.MVar (MVar, newEmptyMVar, readMVar, putMVar)
-
--- Azure
-import Network.Azure.ServiceManagement
- ( CloudService(..)
- , VirtualMachine(..)
- , Endpoint(..)
- , AzureSetup
- )
-import qualified Network.Azure.ServiceManagement as Azure
- ( cloudServices
- , azureSetup
- , vmSshEndpoint
- )
-
--- SSH
-import qualified Network.SSH.Client.LibSSH2 as SSH
- ( withSSH2
- , scpSendFile
- , withChannelBy
- , Session
- , readAllChannel
- , writeAllChannel
- , Channel
- )
-import qualified Network.SSH.Client.LibSSH2.Foreign as SSH
- ( openChannelSession
- , channelExecute
- , writeChannel
- , readChannel
- , channelSendEOF
- )
-import qualified Network.SSH.Client.LibSSH2.Errors as SSH
- ( ErrorCode
- , NULL_POINTER
- , getLastError
- )
-
--- CH
-import Control.Distributed.Process
- ( Process
- , Closure
- , RemoteTable
- , catch
- , unClosure
- , ProcessId
- , getSelfPid
- , NodeId
- , processNodeId
- , register
- , expect
- , nsendRemote
- )
-import Control.Distributed.Process.Serializable (Serializable)
-import qualified Control.Distributed.Process.Internal.Types as CH
- ( LocalNode
- , LocalProcess(processQueue)
- , Message
- , payloadToMessage
- , messageToPayload
- , createMessage
- )
-import Control.Distributed.Process.Node
- ( runProcess
- , forkProcess
- , newLocalNode
- , initRemoteTable
- )
-import Control.Distributed.Process.Internal.CQueue (CQueue, enqueue)
-import Network.Transport.TCP (createTransport, defaultTCPParameters)
-import Network.Transport.Internal (encodeInt32, decodeInt32, prependLength)
-
--- Static
-import Control.Distributed.Static
- ( Static
- , registerStatic
- , staticClosure
- , staticLabel
- )
-import Data.Rank1Dynamic (toDynamic)
-
--- | Azure backend
-data Backend = Backend {
- -- | Find virtual machines
- findVMs :: IO [VirtualMachine]
- -- | Copy the executable to a virtual machine
- , copyToVM :: VirtualMachine -> IO ()
- -- | Check the MD5 hash of the remote executable
- , checkMD5 :: VirtualMachine -> IO Bool
- -- | @runOnVM vm port pp@ starts a new CH node on machine @vm@ and then
- -- runs the specified process pair. The CH node will shut down when the
- -- /local/ process exists. @callOnVM@ returns the returned by the local
- -- process on exit.
- , callOnVM :: forall a. VirtualMachine -> String -> ProcessPair a -> IO a
- -- | Create a new CH node and run the specified process.
- -- The CH node will shut down when the /remote/ process exists. @spawnOnVM@
- -- returns as soon as the process has been spawned.
- , spawnOnVM :: VirtualMachine -> String -> RemoteProcess () -> IO ProcessId
- } deriving (Typeable)
-
--- | Azure connection parameters
-data AzureParameters = AzureParameters {
- azureSetup :: AzureSetup
- , azureSshUserName :: FilePath
- , azureSshPublicKey :: FilePath
- , azureSshPrivateKey :: FilePath
- , azureSshPassphrase :: String
- , azureSshKnownHosts :: FilePath
- , azureSshRemotePath :: FilePath
- , azureSshLocalPath :: FilePath
- }
-
-instance Binary AzureParameters where
- put params = do
- put (azureSetup params)
- put (azureSshUserName params)
- put (azureSshPublicKey params)
- put (azureSshPrivateKey params)
- put (azureSshPassphrase params)
- put (azureSshKnownHosts params)
- put (azureSshRemotePath params)
- put (azureSshLocalPath params)
- get =
- AzureParameters <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get
-
--- | Create default azure parameters
-defaultAzureParameters :: String -- ^ Azure subscription ID
- -> FilePath -- ^ Path to X509 certificate
- -> FilePath -- ^ Path to private key
- -> IO AzureParameters
-defaultAzureParameters sid x509 pkey = do
- home <- getEnv "HOME"
- user <- getEnv "USER"
- self <- getExecutablePath
- setup <- Azure.azureSetup sid x509 pkey
- return AzureParameters
- { azureSetup = setup
- , azureSshUserName = user
- , azureSshPublicKey = home </> ".ssh" </> "id_rsa.pub"
- , azureSshPrivateKey = home </> ".ssh" </> "id_rsa"
- , azureSshPassphrase = ""
- , azureSshKnownHosts = home </> ".ssh" </> "known_hosts"
- , azureSshRemotePath = takeFileName self
- , azureSshLocalPath = self
- }
-
--- | Initialize the backend
-initializeBackend :: AzureParameters -- ^ Connection parameters
- -> String -- ^ Cloud service name
- -> IO Backend
-initializeBackend params cloudService =
- return Backend {
- findVMs = apiFindVMs params cloudService
- , copyToVM = apiCopyToVM params
- , checkMD5 = apiCheckMD5 params
- , callOnVM = apiCallOnVM params cloudService
- , spawnOnVM = apiSpawnOnVM params cloudService
- }
-
--- | Find virtual machines
-apiFindVMs :: AzureParameters -> String -> IO [VirtualMachine]
-apiFindVMs params cloudService = do
- css <- Azure.cloudServices (azureSetup params)
- case filter ((== cloudService) . cloudServiceName) css of
- [cs] -> return $ cloudServiceVMs cs
- _ -> return []
-
--- | Start a CH node on the given virtual machine
-apiCopyToVM :: AzureParameters -> VirtualMachine -> IO ()
-apiCopyToVM params vm =
- void . withSSH2 params vm $ \s -> catchSshError s $
- SSH.scpSendFile s 0o700 (azureSshLocalPath params) (azureSshRemotePath params)
-
--- | Call a process on a VM
-apiCallOnVM :: AzureParameters
- -> String
- -> VirtualMachine
- -> String
- -> ProcessPair a
- -> IO a
-apiCallOnVM = runOnVM False
-
-apiSpawnOnVM :: AzureParameters
- -> String
- -> VirtualMachine
- -> String
- -> Closure (Backend -> Process ())
- -> IO ProcessId
-apiSpawnOnVM params cloudService vm port rproc =
- runOnVM True params cloudService vm port $
- ProcessPair rproc localExpect
-
--- | Internal generalization of 'spawnOnVM' and 'callOnVM'
-runOnVM :: Bool
- -> AzureParameters
- -> String
- -> VirtualMachine
- -> String
- -> ProcessPair a
- -> IO a
-runOnVM bg params cloudService vm port ppair =
- withSSH2 params vm $ \s -> do
- -- TODO: reduce duplication with apiCallOnVM
- let exe = "PATH=. " ++ azureSshRemotePath params
- ++ " onvm"
- ++ " " ++ vmIpAddress vm
- ++ " " ++ port
- ++ " " ++ cloudService
- ++ " " ++ show bg
- ++ " 2>&1"
- let paramsEnc = encode params
- let rprocEnc = encode (ppairRemote ppair)
- (status, r) <- SSH.withChannelBy (SSH.openChannelSession s) id $ \ch -> do
- SSH.channelExecute ch exe
- SSH.writeChannel ch (encodeInt32 (BSL.length rprocEnc))
- SSH.writeAllChannel ch rprocEnc
- SSH.writeChannel ch (encodeInt32 (BSL.length paramsEnc))
- SSH.writeAllChannel ch paramsEnc
- runLocalProcess (ppairLocal ppair) ch
- if status == 0
- then return r
- else error "runOnVM: Non-zero exit status" -- This would a bug
-
--- | Check the MD5 hash of the executable on the remote machine
-apiCheckMD5 :: AzureParameters -> VirtualMachine -> IO Bool
-apiCheckMD5 params vm = do
- hash <- localHash params
- withSSH2 params vm $ \s -> do
- (r, _) <- SSH.withChannelBy (SSH.openChannelSession s) id $ \ch -> do
- SSH.channelExecute ch "md5sum -c --status"
- SSH.writeChannel ch . BSSC.pack $ show hash ++ " " ++ azureSshRemotePath params
- SSH.channelSendEOF ch
- SSH.readAllChannel ch
- return (r == 0)
-
-withSSH2 :: AzureParameters -> VirtualMachine -> (SSH.Session -> IO a) -> IO a
-withSSH2 params (Azure.vmSshEndpoint -> Just ep) =
- SSH.withSSH2 (azureSshKnownHosts params)
- (azureSshPublicKey params)
- (azureSshPrivateKey params)
- (azureSshPassphrase params)
- (azureSshUserName params)
- (endpointVip ep)
- (read $ endpointPort ep)
-withSSH2 _ vm =
- error $ "withSSH2: No SSH endpoint for virtual machine " ++ vmName vm
-
-catchSshError :: SSH.Session -> IO a -> IO a
-catchSshError s io =
- catches io [ Handler handleErrorCode
- , Handler handleNullPointer
- ]
- where
- handleErrorCode :: SSH.ErrorCode -> IO a
- handleErrorCode _ = do
- (_, str) <- SSH.getLastError s
- error str
-
- handleNullPointer :: SSH.NULL_POINTER -> IO a
- handleNullPointer _ = do
- (_, str) <- SSH.getLastError s
- error str
-
-localHash :: AzureParameters -> IO MD5Digest
-localHash params = md5 <$> BSL.readFile (azureSshLocalPath params)
-
---------------------------------------------------------------------------------
--- Utilities --
---------------------------------------------------------------------------------
-
--- | Find a virtual machine with a particular name
-findNamedVM :: Backend -> String -> IO (Maybe VirtualMachine)
-findNamedVM backend vm =
- listToMaybe . filter ((== vm) . vmName) <$> findVMs backend
-
---------------------------------------------------------------------------------
--- Local and remote processes --
---------------------------------------------------------------------------------
-
--- | A process pair consists of a remote process and a local process. The local
--- process can send messages to the remote process using 'localSend' and wait
--- for messages from the remote process using 'localExpect'. The remote process
--- can send messages to the local process using 'remoteSend', and wait for
--- messages from the local process using the standard Cloud Haskell primitives.
---
--- See also 'callOnVM'.
-data ProcessPair a = ProcessPair {
- ppairRemote :: RemoteProcess ()
- , ppairLocal :: LocalProcess a
- }
-
--- | The process to run on the remote node (see 'ProcessPair' and 'callOnVM').
-type RemoteProcess a = Closure (Backend -> Process a)
-
--- | The process to run on the local node (see 'ProcessPair' and 'callOnVM').
-newtype LocalProcess a = LocalProcess { unLocalProcess :: ReaderT SSH.Channel IO a }
- deriving (Functor, Monad, MonadIO, MonadReader SSH.Channel)
-
-runLocalProcess :: LocalProcess a -> SSH.Channel -> IO a
-runLocalProcess = runReaderT . unLocalProcess
-
--- | Send a messages from the local process to the remote process
--- (see 'ProcessPair')
-localSend :: Serializable a => a -> LocalProcess ()
-localSend x = LocalProcess $ do
- ch <- ask
- liftIO $ mapM_ (SSH.writeChannel ch)
- . prependLength
- . CH.messageToPayload
- . CH.createMessage
- $ x
-
--- | Wait for a message from the remote process (see 'ProcessPair').
--- Note that unlike for the standard Cloud Haskell 'expect' it will result in a
--- runtime error if the remote process sends a message of type other than @a@.
---
--- Since it is relatively easy for the remote process to mess up the
--- communication protocol (for instance, by doing a putStr) we ask for the
--- length twice, as some sort of sanity check.
-localExpect :: Serializable a => LocalProcess a
-localExpect = LocalProcess $ do
- ch <- ask
- liftIO $ do
- isE <- readIntChannel ch
- len <- readIntChannel ch
- lenAgain <- readIntChannel ch
- when (len /= lenAgain) $ throwIO (userError "Internal error: protocol violation (perhaps the remote binary is not installed correctly?)")
- msg <- readSizeChannel ch len
- if isE /= 0
- then error (decode msg)
- else return (decode msg)
-
--- | Send a message from the remote process to the local process (see
--- 'ProcessPair'). Note that the remote process can use the standard Cloud
--- Haskell primitives to /receive/ messages from the local process.
-remoteSend :: Serializable a => a -> Process ()
-remoteSend = liftIO . remoteSend'
-
-remoteSend' :: Serializable a => a -> IO ()
-remoteSend' = remoteSendFlagged 0
-
--- | If the remote process encounters an error it can use 'remoteThrow'. This
--- will cause the exception to be raised (as a user-exception, not as the
--- original type) in the local process (as well as in the remote process).
-remoteThrow :: Exception e => e -> IO ()
-remoteThrow e = remoteSendFlagged 1 (show e) >> throwIO e
-
-remoteSendFlagged :: Serializable a => Int -> a -> IO ()
-remoteSendFlagged flags x = do
- let enc = encode x
- BSS.hPut stdout (encodeInt32 flags)
- -- See 'localExpect' for why we send the length twice
- BSS.hPut stdout (encodeInt32 (BSL.length enc))
- BSS.hPut stdout (encodeInt32 (BSL.length enc))
- BSL.hPut stdout enc
- hFlush stdout
-
---------------------------------------------------------------------------------
--- On-VM main --
---------------------------------------------------------------------------------
-
--- | Program main when run on the VM. A typical 'main' function looks like
---
--- > main :: IO ()
--- > main = do
--- > args <- getArgs
--- > case args of
--- > "onvm":args' -> onVmMain __remoteTable args'
--- > _ -> -- your normal main
-onVmMain :: (RemoteTable -> RemoteTable) -> [String] -> IO ()
-onVmMain rtable [host, port, cloudService, bg] = do
- hSetBinaryMode stdin True
- hSetBinaryMode stdout True
- Just rprocEnc <- getWithLength stdin
- Just paramsEnc <- getWithLength stdin
- backend <- initializeBackend (decode paramsEnc) cloudService
- let rproc = decode rprocEnc
- lprocMVar <- newEmptyMVar :: IO (MVar CH.LocalProcess)
- if read bg
- then
- void . Posix.forkProcess $ do
- -- We inherit the file descriptors from the parent, so the SSH
- -- session will not be terminated until we close them
- void Posix.createSession
- startCH rproc lprocMVar backend
- (\node proc -> runProcess node $ do
- us <- getSelfPid
- liftIO $ do
- remoteSend' us
- mapM_ hClose [stdin, stdout, stderr]
- proc)
- else do
- startCH rproc lprocMVar backend forkProcess
- lproc <- readMVar lprocMVar
- queueFromHandle stdin (CH.processQueue lproc)
- where
- startCH :: RemoteProcess ()
- -> MVar CH.LocalProcess
- -> Backend
- -> (CH.LocalNode -> Process () -> IO a)
- -> IO ()
- startCH rproc lprocMVar backend go = do
- mTransport <- createTransport host port defaultTCPParameters
- case mTransport of
- Left err -> remoteThrow err
- Right transport -> do
- node <- newLocalNode transport (rtable . __remoteTable $ initRemoteTable)
- void . go node $ do
- ask >>= liftIO . putMVar lprocMVar
- proc <- unClosure rproc :: Process (Backend -> Process ())
- catch (proc backend)
- (liftIO . (remoteThrow :: SomeException -> IO ()))
-onVmMain _ _
- = error "Invalid arguments passed on onVmMain"
-
--- | Read a 4-byte length @l@ and then an @l@-byte payload
---
--- Returns Nothing on EOF
-getWithLength :: Handle -> IO (Maybe BSL.ByteString)
-getWithLength h = do
- lenEnc <- BSS.hGet h 4
- if BSS.length lenEnc < 4
- then return Nothing
- else do
- let len = decodeInt32 lenEnc
- bs <- BSL.hGet h len
- if BSL.length bs < fromIntegral len
- then return Nothing
- else return (Just bs)
-
-queueFromHandle :: Handle -> CQueue CH.Message -> IO ()
-queueFromHandle h q = do
- mPayload <- getWithLength stdin
- forM_ mPayload $ \payload -> do
- enqueue q $ CH.payloadToMessage (BSL.toChunks payload)
- queueFromHandle h q
-
---------------------------------------------------------------------------------
--- SSH utilities --
---------------------------------------------------------------------------------
-
-readSizeChannel :: SSH.Channel -> Int -> IO BSL.ByteString
-readSizeChannel ch = go []
- where
- go :: [BSS.ByteString] -> Int -> IO BSL.ByteString
- go acc 0 = return (BSL.fromChunks $ reverse acc)
- go acc size = do
- bs <- SSH.readChannel ch (fromIntegral (0x400 `min` size))
- go (bs : acc) (size - BSS.length bs)
-
-readIntChannel :: SSH.Channel -> IO Int
-readIntChannel ch =
- decodeInt32 . BSS.concat . BSL.toChunks <$> readSizeChannel ch 4
-
---------------------------------------------------------------------------------
--- High-level API --
---------------------------------------------------------------------------------
-
-data ServiceProcessMsg =
- ServiceProcessTerminate
- deriving Typeable
-
-instance Binary ServiceProcessMsg where
- put ServiceProcessTerminate = putWord8 0
- get = do
- header <- getWord8
- case header of
- 0 -> return ServiceProcessTerminate
- _ -> fail "ServiceProcessMsg.get"
-
-serviceProcess :: Backend -> Process ()
-serviceProcess _backend = do
- us <- getSelfPid
- register "$azureBackendServiceProcess" us
- go
- where
- go = do
- msg <- expect
- case msg of
- ServiceProcessTerminate ->
- return ()
-
-serviceProcessStatic :: Static (Backend -> Process ())
-serviceProcessStatic = staticLabel "serviceProcess"
-
--- | Start a new Cloud Haskell node on the given virtual machine
-spawnNodeOnVM :: Backend -> VirtualMachine -> String -> IO NodeId
-spawnNodeOnVM backend vm port =
- processNodeId <$> spawnOnVM backend vm port (staticClosure serviceProcessStatic)
-
--- | Terminate a node started with 'spawnNodeOnVM'
-terminateNode :: NodeId -> Process ()
-terminateNode nid = nsendRemote nid "$azureBackendServiceProcess" ServiceProcessTerminate
-
-__remoteTable :: RemoteTable -> RemoteTable
-__remoteTable = registerStatic "serviceProcess" (toDynamic serviceProcess)
View
30 distributed-process-demos/LICENSE
@@ -1,30 +0,0 @@
-Copyright (c) 2012, Edsko de Vries
-
-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 Edsko de Vries 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.
View
2 distributed-process-demos/Setup.hs
@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain
View
154 distributed-process-demos/distributed-process-demos.cabal
@@ -1,154 +0,0 @@
--- Initial distributed-process-demos.cabal generated by cabal init. For
--- further documentation, see http://haskell.org/cabal/users-guide/
-
-name: distributed-process-demos
-version: 0.1.0.0
-synopsis: Cloud Haskell Demo Applications
--- description:
-homepage: http://github.com/haskell-distributed/distributed-process
-license: BSD3
-license-file: LICENSE
-author: Edsko de Vries
-maintainer: edsko@well-typed.com
-copyright: Well-Typed LLP
-category: Control
-build-type: Simple
-cabal-version: >=1.8
-
-flag use-simplelocalnet
- description: Use the SimpleLocalnet backend
- default: True
-
-flag use-azure
- description: Use the Azure backend
- default: True
-
-executable distributed-process-simplelocalnet-masterslave
- main-is: SimpleLocalnet.hs
- other-modules: MasterSlave
- PrimeFactors
- hs-source-dirs: src/MasterSlave src/Common
- build-depends: base ==4.5.*,
- distributed-process >= 0.3.2
- extensions: BangPatterns, CPP, TemplateHaskell
- ghc-options: -Wall
- if flag(use-simplelocalnet)
- build-depends: distributed-process-simplelocalnet
- cpp-options: -DUSE_SIMPLELOCALNET
- else
- buildable: False
-
-executable distributed-process-azure-masterslave
- main-is: Azure.hs
- other-modules: MasterSlave
- PrimeFactors
- hs-source-dirs: src/MasterSlave src/Common
- build-depends: base ==4.5.*,
- distributed-process >= 0.3.2
- extensions: BangPatterns, CPP, TemplateHaskell
- ghc-options: -Wall
- if flag(use-azure)
- build-depends: distributed-process-azure
- cpp-options: -DUSE_AZURE
- else
- buildable: False
-
-executable distributed-process-simplelocalnet-workpushing
- main-is: SimpleLocalnet.hs
- other-modules: WorkPushing
- PrimeFactors
- hs-source-dirs: src/WorkPushing src/Common
- build-depends: base ==4.5.*,
- distributed-process >= 0.3.2
- extensions: BangPatterns, CPP, TemplateHaskell
- ghc-options: -Wall
- if flag(use-simplelocalnet)
- build-depends: distributed-process-simplelocalnet
- cpp-options: -DUSE_SIMPLELOCALNET
- else
- buildable: False
-
-executable distributed-process-azure-workpushing
- main-is: Azure.hs
- other-modules: WorkPushing
- PrimeFactors
- hs-source-dirs: src/WorkPushing src/Common
- build-depends: base ==4.5.*,
- distributed-process >= 0.3.2
- extensions: BangPatterns, CPP, TemplateHaskell
- ghc-options: -Wall
- if flag(use-azure)
- build-depends: distributed-process-azure
- cpp-options: -DUSE_AZURE
- else
- buildable: False
-
-executable distributed-process-simplelocalnet-typedworkpushing
- main-is: SimpleLocalnet.hs
- other-modules: TypedWorkPushing
- PrimeFactors
- hs-source-dirs: src/TypedWorkPushing src/Common
- build-depends: base ==4.5.*,
- distributed-process >= 0.3.2
- extensions: BangPatterns, CPP, TemplateHaskell
- ghc-options: -Wall
- if flag(use-simplelocalnet)
- build-depends: distributed-process-simplelocalnet
- cpp-options: -DUSE_SIMPLELOCALNET
- else
- buildable: False
-
-executable distributed-process-azure-typedworkpushing
- main-is: Azure.hs
- other-modules: TypedWorkPushing
- PrimeFactors
- hs-source-dirs: src/TypedWorkPushing src/Common
- build-depends: base ==4.5.*,
- distributed-process >= 0.3.2
- extensions: BangPatterns, CPP, TemplateHaskell
- ghc-options: -Wall
- if flag(use-azure)
- build-depends: distributed-process-azure
- cpp-options: -DUSE_AZURE
- else
- buildable: False
-
-executable distributed-process-simplelocalnet-workstealing
- main-is: SimpleLocalnet.hs
- other-modules: WorkStealing
- PrimeFactors
- hs-source-dirs: src/WorkStealing src/Common
- build-depends: base ==4.5.*,
- distributed-process >= 0.3.2
- extensions: BangPatterns, CPP, TemplateHaskell
- ghc-options: -Wall
- if flag(use-simplelocalnet)
- build-depends: distributed-process-simplelocalnet
- cpp-options: -DUSE_SIMPLELOCALNET
- else
- buildable: False
-
-executable distributed-process-simplelocalnet-mapreduce
- main-is: SimpleLocalnet.hs
- other-modules: CountWords
- KMeans
- MapReduce
- MonoDistrMapReduce
- PolyDistrMapReduce
- hs-source-dirs: src/MapReduce
- build-depends: base ==4.5.*,
- distributed-process >= 0.3.2,
- distributed-static >= 0.2.0 && < 0.3,
- containers >= 0.4 && < 0.6,
- bytestring >= 0.9 && < 0.11,
- binary >= 0.5 && < 0.7,
- array >= 0.4 && < 0.5,
- random >= 1.0 && < 1.1
- extensions: BangPatterns, CPP, TemplateHaskell, ScopedTypeVariables
- ghc-options: -Wall -rtsopts -with-rtsopts=-K64M
- if flag(use-simplelocalnet)
- build-depends: distributed-process-simplelocalnet
- cpp-options: -DUSE_SIMPLELOCALNET
- else
- buildable: False
-
View
25 distributed-process-demos/src/Common/PrimeFactors.hs
@@ -1,25 +0,0 @@
--- | Prime factorization
---
--- Written by Dan Weston
--- <http://westondan.blogspot.ie/2007/07/simple-prime-factorization-code.html>
-module PrimeFactors where
-
-primes :: [Integer]
-primes = primes' (2:[3,5..])
- where
- primes' (x:xs) = x : primes' (filter (notDivisorOf x) xs)
- notDivisorOf d n = n `mod` d /= 0
-
-factors :: [Integer] -> Integer -> [Integer]
-factors qs@(p:ps) n
- | n <= 1 = []
- | m == 0 = p : factors qs d
- | otherwise = factors ps n
- where
- (d,m) = n `divMod` p
-
-primeFactors :: Integer -> [Integer]
-primeFactors = factors primes
-
-numPrimeFactors :: Integer -> Integer
-numPrimeFactors = fromIntegral . length . primeFactors
View
34 distributed-process-demos/src/MapReduce/CountWords.hs
@@ -1,34 +0,0 @@
-{-# LANGUAGE TupleSections #-}
-module CountWords
- ( Document
- , localCountWords
- , distrCountWords
- , __remoteTable
- ) where
-
-import Control.Distributed.Process
-import Control.Distributed.Process.Closure
-import MapReduce
-import MonoDistrMapReduce hiding (__remoteTable)
-
-type Document = String
-type Word = String
-type Frequency = Int
-
-countWords :: MapReduce FilePath Document Word Frequency Frequency
-countWords = MapReduce {
- mrMap = const (map (, 1) . words)
- , mrReduce = const sum
- }
-
-localCountWords :: Map FilePath Document -> Map Word Frequency
-localCountWords = localMapReduce countWords
-
-countWords_ :: () -> MapReduce FilePath Document Word Frequency Frequency
-countWords_ () = countWords
-
-remotable ['countWords_]
-
-distrCountWords :: [NodeId] -> Map FilePath Document -> Process (Map Word Frequency)
-distrCountWords = distrMapReduce ($(mkClosure 'countWords_) ())
-
View
127 distributed-process-demos/src/MapReduce/KMeans.hs
@@ -1,127 +0,0 @@
-{-# LANGUAGE TupleSections #-}
-module KMeans
- ( Point
- , Cluster
- , localKMeans
- , distrKMeans
- , createGnuPlot
- , __remoteTable
- ) where
-
-import System.IO
-import Data.List (minimumBy)
-import Data.Function (on)
-import Data.Array (Array, (!), bounds)
-import qualified Data.Map as Map (fromList, elems, toList, size)
-import Control.Distributed.Process
-import Control.Distributed.Process.Closure
-import MapReduce
-import PolyDistrMapReduce hiding (__remoteTable)
-
-type Point = (Double, Double)
-type Cluster = (Double, Double)
-
-average :: Fractional a => [a] -> a
-average xs = sum xs / fromIntegral (length xs)
-
-distanceSq :: Point -> Point -> Double
-distanceSq (x1, y1) (x2, y2) = a * a + b * b